diff options
252 files changed, 2693 insertions, 2591 deletions
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 48e6b37006..7c9a5c9a31 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -10,7 +10,7 @@ stages: variables: # Format: $IMAGE-V$DATE [Cache is not used as of today but kept here # for reference] - CACHEKEY: "bionic_coq-V2019-06-21-V1" + CACHEKEY: "bionic_coq-V2019-07-06-V22" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" @@ -9,7 +9,7 @@ WHAT DO YOU NEED ? - OCaml (version >= 4.05.0) (available at https://ocaml.org/) - (This version of Coq has been tested up to OCaml 4.07.0) + (This version of Coq has been tested up to OCaml 4.08.0) - The Num package, which used to be part of the OCaml standard library, if you are using an OCaml version >= 4.06.0 diff --git a/azure-pipelines.yml b/azure-pipelines.yml index c93920a884..fd99dc6d18 100644 --- a/azure-pipelines.yml +++ b/azure-pipelines.yml @@ -19,7 +19,7 @@ jobs: powershell -Command "(New-Object Net.WebClient).DownloadFile('http://www.cygwin.com/setup-x86_64.exe', 'setup-x86_64.exe')" SET CYGROOT=C:\cygwin64 SET CYGCACHE=%CYGROOT%\var\cache\setup - setup-x86_64.exe -qnNdO -R %CYGROOT% -l %CYGCACHE% -s %CYGMIRROR% -P rsync -P patch -P diffutils -P make -P unzip -P m4 -P findutils -P time -P wget -P curl -P git -P mingw64-x86_64-binutils,mingw64-x86_64-gcc-core,mingw64-x86_64-gcc-g++,mingw64-x86_64-pkg-config,mingw64-x86_64-windows_default_manifest -P mingw64-x86_64-headers,mingw64-x86_64-runtime,mingw64-x86_64-pthreads,mingw64-x86_64-zlib -P python + setup-x86_64.exe -qnNdO -R %CYGROOT% -l %CYGCACHE% -s %CYGMIRROR% -P rsync -P patch -P diffutils -P make -P unzip -P m4 -P findutils -P time -P wget -P curl -P git -P mingw64-x86_64-binutils,mingw64-x86_64-gcc-core,mingw64-x86_64-gcc-g++,mingw64-x86_64-pkg-config,mingw64-x86_64-windows_default_manifest -P mingw64-x86_64-headers,mingw64-x86_64-runtime,mingw64-x86_64-pthreads,mingw64-x86_64-zlib -P python2 -P python3 SET TARGET_ARCH=x86_64-w64-mingw32 SET CD_MFMT=%cd:\=/% @@ -52,9 +52,14 @@ jobs: - script: | set -e brew update + (cd $(brew --repository)/Library/Taps/homebrew/homebrew-core/ && git fetch --shallow-since=${HBCORE_DATE} && git checkout ${HBCORE_REF}) brew install gnu-time opam pkg-config gtksourceview3 adwaita-icon-theme pip3 install macpack displayName: 'Install system dependencies' + env: + HOMEBREW_NO_AUTO_UPDATE: "1" + HBCORE_DATE: "2019-06-18" + HBCORE_REF: "944a5b7d83e4b81c749d93831b514607bdd2b6a1" - script: | set -e @@ -67,7 +72,7 @@ jobs: opam list displayName: 'Install OCaml dependencies' env: - COMPILER: "4.07.1" + COMPILER: "4.08.0" FINDLIB_VER: ".1.8.0" OPAMYES: "true" diff --git a/checker/analyze.ml b/checker/analyze.ml index 77e70318dd..e145988b4f 100644 --- a/checker/analyze.ml +++ b/checker/analyze.ml @@ -395,8 +395,8 @@ end module IChannel = struct type t = in_channel - let input_byte = Pervasives.input_byte - let input_binary_int = Pervasives.input_binary_int + let input_byte = input_byte + let input_binary_int = input_binary_int end module IString = diff --git a/checker/check.ml b/checker/check.ml index 2840fc9ad6..ecf84fda9c 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -66,7 +66,7 @@ module LibraryOrdered = struct type t = DirPath.t let compare d1 d2 = - Pervasives.compare + compare (List.rev (DirPath.repr d1)) (List.rev (DirPath.repr d2)) end @@ -377,7 +377,7 @@ let intern_from_file ~intern_mode (dir, f) = let get_deps (dir, f) = try LibraryMap.find dir !depgraph with Not_found -> - let _ = intern_from_file (dir,f) in + let _ = intern_from_file ~intern_mode:Dep (dir,f) in LibraryMap.find dir !depgraph (* Read a compiled library and all dependencies, in reverse order. diff --git a/checker/values.ml b/checker/values.ml index cde2db2721..8dc09aed87 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -345,8 +345,26 @@ let v_compiled_lib = (** Library objects *) let v_obj = Dyn -let v_libobj = Tuple ("libobj", [|v_id;v_obj|]) -let v_libobjs = List v_libobj + +let rec v_aobjs = Sum("algebraic_objects", 0, + [| [|v_libobjs|]; + [|v_mp;v_subst|] + |]) +and v_substobjs = + Tuple("*", [|List v_uid;v_aobjs|]) +and v_libobjt = Sum("Libobject.t",0, + [| [| v_substobjs |]; + [| v_substobjs |]; + [| v_aobjs |]; + [| v_libobjs |]; + [| v_bool; v_mp |]; + [| v_obj |] + |]) + +and v_libobj = Tuple ("libobj", [|v_id;v_libobjt|]) + +and v_libobjs = List v_libobj + let v_libraryobjs = Tuple ("library_objects",[|v_libobjs;v_libobjs|]) (** STM objects *) diff --git a/default.nix b/default.nix index d5c6cdb8ad..2d101eed57 100644 --- a/default.nix +++ b/default.nix @@ -41,7 +41,8 @@ stdenv.mkDerivation rec { buildInputs = [ hostname - python2 time # coq-makefile timing tools + python2 # update-compat.py + python3 time # coq-makefile timing tools dune ] ++ (with ocamlPackages; [ ocaml findlib num ]) diff --git a/dev/base_include b/dev/base_include index b30bbaa3fa..4841db8953 100644 --- a/dev/base_include +++ b/dev/base_include @@ -134,7 +134,6 @@ open Tacticals open Tactics open Eqschemes -open ExplainErr open Class open ComDefinition open Indschemes diff --git a/dev/ci/azure-opam.sh b/dev/ci/azure-opam.sh index 9448a03f4f..34d748e1cc 100755 --- a/dev/ci/azure-opam.sh +++ b/dev/ci/azure-opam.sh @@ -2,7 +2,7 @@ set -e -x -OPAM_VARIANT=ocaml-variants.4.07.1+mingw64c +OPAM_VARIANT=ocaml-variants.4.08.0+mingw64c wget https://github.com/fdopen/opam-repository-mingw/releases/download/0.0.0.2/opam64.tar.xz -O opam64.tar.xz tar -xf opam64.tar.xz diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index f07a5cdb98..011c7fbdec 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -1,4 +1,4 @@ -# CACHEKEY: "bionic_coq-V2019-06-21-V1" +# CACHEKEY: "bionic_coq-V2019-07-06-V22" # ^^ Update when modifying this file. FROM ubuntu:bionic @@ -22,7 +22,7 @@ RUN pip3 install sphinx==1.7.8 sphinx_rtd_theme==0.2.5b2 \ antlr4-python3-runtime==4.7.1 sphinxcontrib-bibtex==0.4.0 # We need to install OPAM 2.0 manually for now. -RUN wget https://github.com/ocaml/opam/releases/download/2.0.3/opam-2.0.3-x86_64-linux -O /usr/bin/opam && chmod 755 /usr/bin/opam +RUN wget https://github.com/ocaml/opam/releases/download/2.0.4/opam-2.0.4-x86_64-linux -O /usr/bin/opam && chmod 755 /usr/bin/opam # Basic OPAM setup ENV NJOBS="2" \ @@ -37,8 +37,9 @@ ENV COMPILER="4.05.0" # Common OPAM packages. # `num` does not have a version number as the right version to install varies # with the compiler version. -ENV BASE_OPAM="num ocamlfind.1.8.0 dune.1.6.2 ounit.2.0.8 odoc.1.4.0" \ - CI_OPAM="menhir.20181113 elpi.1.4.0 ocamlgraph.1.8.8" +ENV BASE_OPAM="num ocamlfind.1.8.0 dune.1.10.0 ounit.2.0.8 odoc.1.4.0" \ + CI_OPAM="menhir.20190626 ocamlgraph.1.8.8" \ + BASE_ONLY_OPAM="elpi.1.4.0" # BASE switch; CI_OPAM contains Coq's CI dependencies. ENV COQIDE_OPAM="cairo2.0.6 lablgtk3-sourceview3.3.0.beta5" @@ -48,16 +49,16 @@ ENV COQIDE_OPAM="cairo2.0.6 lablgtk3-sourceview3.3.0.beta5" # base switch RUN opam init -a --disable-sandboxing --compiler="$COMPILER" default https://opam.ocaml.org && eval $(opam env) && opam update && \ - opam install $BASE_OPAM $COQIDE_OPAM $CI_OPAM + opam install $BASE_OPAM $COQIDE_OPAM $CI_OPAM $BASE_ONLY_OPAM # base+32bit switch RUN opam switch create "${COMPILER}+32bit" && eval $(opam env) && \ opam install $BASE_OPAM # EDGE switch -ENV COMPILER_EDGE="4.07.1" \ - COQIDE_OPAM_EDGE="cairo2.0.6 lablgtk3-sourceview3.3.0.beta5" \ - BASE_OPAM_EDGE="dune-release.1.1.0" +ENV COMPILER_EDGE="4.08.0" \ + COQIDE_OPAM_EDGE="cairo2.0.6 lablgtk3-sourceview3.3.0.beta6" \ + BASE_OPAM_EDGE="dune-release.1.3.1" # EDGE+flambda switch, we install CI_OPAM as to be able to use # `ci-template-flambda` with everything. diff --git a/dev/ci/user-overlays/10419-ejgallego-heads+test.sh b/dev/ci/user-overlays/10419-ejgallego-heads+test.sh new file mode 100644 index 0000000000..0ec0c3673a --- /dev/null +++ b/dev/ci/user-overlays/10419-ejgallego-heads+test.sh @@ -0,0 +1,18 @@ +if [ "$CI_PULL_REQUEST" = "10419" ] || [ "$CI_BRANCH" = "heads+test" ]; then + + elpi_CI_REF=heads+test + elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi + + equations_CI_REF=heads+test + equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations + + mtac2_CI_REF=heads+test + mtac2_CI_GITURL=https://github.com/ejgallego/Mtac2 + + paramcoq_CI_REF=heads+test + paramcoq_CI_GITURL=https://github.com/ejgallego/paramcoq + + quickchick_CI_REF=heads+test + quickchick_CI_GITURL=https://github.com/ejgallego/QuickChick + +fi diff --git a/dev/dune-workspace.all b/dev/dune-workspace.all index cf95941de5..c7f36ee964 100644 --- a/dev/dune-workspace.all +++ b/dev/dune-workspace.all @@ -3,5 +3,5 @@ ; Add custom flags here. Default developer profile is `dev` (context (opam (switch 4.05.0))) (context (opam (switch 4.05.0+32bit))) -(context (opam (switch 4.07.1))) -(context (opam (switch 4.07.1+flambda))) +(context (opam (switch 4.08.0))) +(context (opam (switch 4.08.0+flambda))) diff --git a/dev/tools/merge-pr.sh b/dev/tools/merge-pr.sh index 425f21de70..c0a3eeb11c 100755 --- a/dev/tools/merge-pr.sh +++ b/dev/tools/merge-pr.sh @@ -209,7 +209,8 @@ has_state() { [ "$(jq -rc 'map(select(.user.login == "'"$1"'") | .state) | any(. == "'"$2"'")' <<< "$reviews")" = true ] } -for reviewer in $(jq -rc 'map(.user.login) | unique | join(" ")' <<< "$reviews" ); do +author=$(echo "$PRDATA" | jq -rc '.user.login') +for reviewer in $(jq -rc 'map(.user.login | select(. != "'"$author"'")) | unique | join(" ")' <<< "$reviews" ); do if has_state "$reviewer" APPROVED; then msg=$(printf '%s\n' "$msg" | git interpret-trailers --trailer Reviewed-by="$reviewer") elif has_state "$reviewer" COMMENTED; then diff --git a/dev/tools/update-compat.py b/dev/tools/update-compat.py index 0338cd42c7..c7bb36b6d3 100755 --- a/dev/tools/update-compat.py +++ b/dev/tools/update-compat.py @@ -1,4 +1,4 @@ -#!/usr/bin/env python +#!/usr/bin/env python2 from __future__ import with_statement import os, re, sys, subprocess diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 8343853af5..aa28bce018 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -15,7 +15,6 @@ open Util open Pp open Names open Libnames -open Globnames open Univ open Environ open Printer @@ -141,7 +140,7 @@ let ppclosedglobconstridmap x = pp (pr_closed_glob_constr_idmap x) let pP s = pp (hov 0 s) -let safe_pr_global = function +let safe_pr_global = let open GlobRef in function | ConstRef kn -> pp (str "CONSTREF(" ++ Constant.debug_print kn ++ str ")") | IndRef (kn,i) -> pp (str "INDREF(" ++ MutInd.debug_print kn ++ str "," ++ int i ++ str ")") @@ -558,7 +557,7 @@ let encode_path ?loc prefix mpdir suffix id = make_qualid ?loc (DirPath.make (List.rev (Id.of_string prefix::dir@suffix))) id -let raw_string_of_ref ?loc _ = function +let raw_string_of_ref ?loc _ = let open GlobRef in function | ConstRef cst -> let (mp,id) = Constant.repr2 cst in encode_path ?loc "CST" (Some mp) [] (Label.to_id id) @@ -574,7 +573,7 @@ let raw_string_of_ref ?loc _ = function | VarRef id -> encode_path ?loc "SECVAR" None [] id -let short_string_of_ref ?loc _ = function +let short_string_of_ref ?loc _ = let open GlobRef in function | VarRef id -> qualid_of_ident ?loc id | ConstRef cst -> qualid_of_ident ?loc (Label.to_id (Constant.label cst)) | IndRef (kn,0) -> qualid_of_ident ?loc (Label.to_id (MutInd.label kn)) diff --git a/doc/changelog/01-kernel/10439-uniform-opaque-seff-handling.md b/doc/changelog/01-kernel/10439-uniform-opaque-seff-handling.md new file mode 100644 index 0000000000..e0573a2c74 --- /dev/null +++ b/doc/changelog/01-kernel/10439-uniform-opaque-seff-handling.md @@ -0,0 +1,4 @@ +- Internal definitions generated by abstract-like tactics are now inlined + inside universe Qed-terminated polymorphic definitions, similarly to what + happens for their monomorphic counterparts, + (`#10439 <https://github.com/coq/coq/pull/10439>`_, by Pierre-Marie Pédrot). diff --git a/doc/changelog/02-specification-language/10049-bidi-app.rst b/doc/changelog/02-specification-language/10049-bidi-app.rst index 79678c5242..279bb9272a 100644 --- a/doc/changelog/02-specification-language/10049-bidi-app.rst +++ b/doc/changelog/02-specification-language/10049-bidi-app.rst @@ -1,6 +1,6 @@ - New annotation in `Arguments` for bidirectionality hints: it is now possible to tell type inference to use type information from the context once the `n` first arguments of an application are known. The syntax is: - `Arguments foo x y & z`. - `#10049 <https://github.com/coq/coq/pull/10049>`_, by Maxime Dénès with - help from Enrico Tassi + `Arguments foo x y & z`. See :cmd:`Arguments (bidirectionality hints)` + (`#10049 <https://github.com/coq/coq/pull/10049>`_, by Maxime Dénès with + help from Enrico Tassi). diff --git a/doc/changelog/02-specification-language/10167-orpat-mixfix.rst b/doc/changelog/02-specification-language/10167-orpat-mixfix.rst index e3c3923348..2d17e569d3 100644 --- a/doc/changelog/02-specification-language/10167-orpat-mixfix.rst +++ b/doc/changelog/02-specification-language/10167-orpat-mixfix.rst @@ -7,6 +7,6 @@ + notation :g:`(p | q)` now potentially clashes with core pattern syntax, and should be avoided. ``-w disj-pattern-notation`` flags such :cmd:`Notation`. - see :ref:`extendedpatternmatching` for details + See :ref:`extendedpatternmatching` for details (`#10167 <https://github.com/coq/coq/pull/10167>`_, by Georges Gonthier). diff --git a/doc/changelog/02-specification-language/10215-rm-maybe-open-proof.rst b/doc/changelog/02-specification-language/10215-rm-maybe-open-proof.rst index 21ec7f8e5b..71b10aaaf4 100644 --- a/doc/changelog/02-specification-language/10215-rm-maybe-open-proof.rst +++ b/doc/changelog/02-specification-language/10215-rm-maybe-open-proof.rst @@ -1,11 +1,11 @@ -- Function always opens a proof when used with a ``measure`` or ``wf`` +- :cmd:`Function` always opens a proof when used with a ``measure`` or ``wf`` annotation, see :ref:`advanced-recursive-functions` for the updated documentation (`#10215 <https://github.com/coq/coq/pull/10215>`_, by Enrico Tassi). -- The legacy command Add Morphism always opens a proof and cannot be used +- The legacy command :cmd:`Add Morphism` always opens a proof and cannot be used inside a module type. In order to declare a module type parameter that - happens to be a morphism, use ``Parameter Morphism``. See + happens to be a morphism, use :cmd:`Declare Morphism`. See :ref:`deprecated_syntax_for_generalized_rewriting` for the updated documentation (`#10215 <https://github.com/coq/coq/pull/10215>`_, by Enrico Tassi). diff --git a/doc/changelog/03-notations/10180-deprecate-notations.rst b/doc/changelog/03-notations/10180-deprecate-notations.rst index 01f2e893ed..bce5db5865 100644 --- a/doc/changelog/03-notations/10180-deprecate-notations.rst +++ b/doc/changelog/03-notations/10180-deprecate-notations.rst @@ -2,5 +2,5 @@ attribute. The former `compat` annotation for notations is deprecated, and its semantics changed. It is now made equivalent to using a `deprecated` attribute, and is no longer connected with the `-compat` - command-line flag. + command-line flag (`#10180 <https://github.com/coq/coq/pull/10180>`_, by Maxime Dénès). diff --git a/doc/changelog/04-tactics/09288-injection-as.rst b/doc/changelog/04-tactics/09288-injection-as.rst index 6a74551f06..0cb669778c 100644 --- a/doc/changelog/04-tactics/09288-injection-as.rst +++ b/doc/changelog/04-tactics/09288-injection-as.rst @@ -1,4 +1,4 @@ - Documented syntax :n:`injection @term as [= {+ @intropattern} ]` as an alternative to :n:`injection @term as {+ @simple_intropattern}` using - the standard :n:`@injection_intropattern` syntax (`#09288 - <https://github.com/coq/coq/pull/09288>`_, by Hugo Herbelin). + the standard :n:`@injection_intropattern` syntax (`#9288 + <https://github.com/coq/coq/pull/9288>`_, by Hugo Herbelin). diff --git a/doc/changelog/04-tactics/10318-select-only-error.rst b/doc/changelog/04-tactics/10318-select-only-error.rst index 03ed15d948..b4f991316e 100644 --- a/doc/changelog/04-tactics/10318-select-only-error.rst +++ b/doc/changelog/04-tactics/10318-select-only-error.rst @@ -1,4 +1,4 @@ - The goal selector tactical ``only`` now checks that the goal range it is given is valid instead of ignoring goals out of the focus - range. (`#10318 <https://github.com/coq/coq/pull/10318>`_, by Gaëtan + range (`#10318 <https://github.com/coq/coq/pull/10318>`_, by Gaëtan Gilbert). diff --git a/doc/changelog/07-commands-and-options/09530-rm-unknown.rst b/doc/changelog/07-commands-and-options/09530-rm-unknown.rst index 78874cadb1..1c91800c65 100644 --- a/doc/changelog/07-commands-and-options/09530-rm-unknown.rst +++ b/doc/changelog/07-commands-and-options/09530-rm-unknown.rst @@ -1,5 +1,5 @@ - Deprecated flag `Refine Instance Mode` has been removed. - (`#09530 <https://github.com/coq/coq/pull/09530>`_, fixes + (`#9530 <https://github.com/coq/coq/pull/9530>`_, fixes `#3632 <https://github.com/coq/coq/issues/3632>`_, `#3890 <https://github.com/coq/coq/issues/3890>`_ and `#4638 <https://github.com/coq/coq/issues/4638>`_ diff --git a/doc/changelog/07-commands-and-options/10336-ambiguous-paths.rst b/doc/changelog/07-commands-and-options/10336-ambiguous-paths.rst new file mode 100644 index 0000000000..151c400b2c --- /dev/null +++ b/doc/changelog/07-commands-and-options/10336-ambiguous-paths.rst @@ -0,0 +1,5 @@ +- Improve the ambiguous paths warning to indicate which path is ambiguous with + new one + (`#10336 <https://github.com/coq/coq/pull/10336>`_, + closes `#3219 <https://github.com/coq/coq/issues/3219>`_, + by Kazuhiko Sakaguchi). diff --git a/doc/changelog/11-infrastructure-and-dependencies/10471-ocaml-408.rst b/doc/changelog/11-infrastructure-and-dependencies/10471-ocaml-408.rst new file mode 100644 index 0000000000..8bfd01d7a0 --- /dev/null +++ b/doc/changelog/11-infrastructure-and-dependencies/10471-ocaml-408.rst @@ -0,0 +1,5 @@ +- Coq now officially supports OCaml 4.08. + + see INSTALL files for details + (`#10471 <https://github.com/coq/coq/pull/10471>`_, + by Emilio Jesús Gallego Arias). diff --git a/doc/plugin_tutorial/tuto1/src/simple_declare.ml b/doc/plugin_tutorial/tuto1/src/simple_declare.ml index 68ae5628db..9dd4700db5 100644 --- a/doc/plugin_tutorial/tuto1/src/simple_declare.ml +++ b/doc/plugin_tutorial/tuto1/src/simple_declare.ml @@ -9,4 +9,4 @@ let edeclare ?hook ~name ~poly ~scope ~kind ~opaque sigma udecl body tyopt imps let declare_definition ~poly name sigma body = let udecl = UState.default_univ_decl in edeclare ~name ~poly ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) - ~kind:Decl_kinds.Definition ~opaque:false sigma udecl body None [] + ~kind:Decls.Definition ~opaque:false sigma udecl body None [] diff --git a/doc/plugin_tutorial/tuto1/src/simple_print.ml b/doc/plugin_tutorial/tuto1/src/simple_print.ml index ba989b1bac..88afec14d5 100644 --- a/doc/plugin_tutorial/tuto1/src/simple_print.ml +++ b/doc/plugin_tutorial/tuto1/src/simple_print.ml @@ -2,14 +2,15 @@ type constr is given in the coq-dpdgraph plugin. *) let simple_body_access gref = + let open Names.GlobRef in match gref with - | Globnames.VarRef _ -> + | VarRef _ -> failwith "variables are not covered in this example" - | Globnames.IndRef _ -> + | IndRef _ -> failwith "inductive types are not covered in this example" - | Globnames.ConstructRef _ -> + | ConstructRef _ -> failwith "constructors are not covered in this example" - | Globnames.ConstRef cst -> + | ConstRef cst -> let cb = Environ.lookup_constant cst (Global.env()) in match Global.body_of_constant_body Library.indirect_accessor cb with | Some(e, _, _) -> EConstr.of_constr e diff --git a/doc/sphinx/addendum/implicit-coercions.rst b/doc/sphinx/addendum/implicit-coercions.rst index d5523e8561..7fee62179b 100644 --- a/doc/sphinx/addendum/implicit-coercions.rst +++ b/doc/sphinx/addendum/implicit-coercions.rst @@ -145,19 +145,25 @@ Declaring Coercions .. exn:: Cannot recognize @class as a source class of @qualid. :undocumented: - .. exn:: @qualid does not respect the uniform inheritance condition. + .. warn:: @qualid does not respect the uniform inheritance condition. :undocumented: .. exn:: Found target class ... instead of ... :undocumented: - .. warn:: Ambiguous path. + .. warn:: New coercion path ... is ambiguous with existing ... - When the coercion :token:`qualid` is added to the inheritance graph, - invalid coercion paths are ignored. The :cmd:`Coercion` command tries to check - that they are convertible with existing ones on the same classes. - The paths for which this check fails are displayed by a warning in the form - :g:`[f₁;..;fₙ] : C >-> D`. + When the coercion :token:`qualid` is added to the inheritance graph, new + coercion paths which have the same classes as existing ones are ignored. + The :cmd:`Coercion` command tries to check the convertibility of new ones and + existing ones. The paths for which this check fails are displayed by a warning + in the form :g:`[f₁;..;fₙ] : C >-> D`. + + The convertibility checking procedure for coercion paths is complete for + paths consisting of coercions satisfying the uniform inheritance condition, + but some coercion paths could be reported as ambiguous even if they are + convertible with existing ones when they have coercions that don't satisfy + the uniform inheritance condition. .. cmdv:: Local Coercion @qualid : @class >-> @class diff --git a/doc/sphinx/addendum/type-classes.rst b/doc/sphinx/addendum/type-classes.rst index 2ba13db042..db3e20a9c6 100644 --- a/doc/sphinx/addendum/type-classes.rst +++ b/doc/sphinx/addendum/type-classes.rst @@ -470,7 +470,7 @@ Settings .. flag:: Typeclasses Dependency Order - This flag (on by default since 8.6) respects the dependency order + This flag (off by default) respects the dependency order between subgoals, meaning that subgoals on which other subgoals depend come first, while the non-dependent subgoals were put before the dependent ones previously (Coq 8.5 and below). This can result in diff --git a/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index cc4976587d..1b9e3ce0f3 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -487,7 +487,7 @@ used as a convenient shorthand for abstractions, especially in local definitions or type expressions. Wildcards may be interpreted as abstractions (see for example sections -:ref:`definitions_ssr` and ref:`structure_ssr`), or their content can be +:ref:`definitions_ssr` and :ref:`structure_ssr`), or their content can be inferred from the whole context of the goal (see for example section :ref:`abbreviations_ssr`). @@ -983,13 +983,13 @@ During the course of a proof |Coq| always present the user with a Fk : Pk … ================= - forall (xl : Tl ) …, + forall (xl : Tl) …, let ym := bm in … in Pn -> … -> C The *goal* to be proved appears below the double line; above the line is the *context* of the sequent, a set of declarations of *constants* -``ci`` , *defined constants* d i , and *facts* ``Fk`` that can be used to +``ci`` , *defined constants* ``dj`` , and *facts* ``Fk`` that can be used to prove the goal (usually, ``Ti`` , ``Tj : Type`` and ``Pk : Prop``). The various kinds of declarations can come in any order. The top part of the @@ -1893,9 +1893,9 @@ under fresh |SSR| names. case E : a => H. Show 2. -Combining the generation of named equations mechanism with thecase +Combining the generation of named equations mechanism with the :tacn:`case` tactic strengthens the power of a case analysis. On the other hand, -when combined with the elim tactic, this feature is mostly useful for +when combined with the :tacn:`elim` tactic, this feature is mostly useful for debug purposes, to trace the values of decomposed parameters and pinpoint failing branches. @@ -2022,7 +2022,7 @@ be substituted. The equation always refers to the first :token:`d_item` in the actual tactic call, before any padding with initial ``_``. Thus, if an inductive type - has two family parameters, it is possible to have|SSR| generate an + has two family parameters, it is possible to have |SSR| generate an equation for the second one by omitting the pattern for the first; note however that this will fail if the type of the second parameter depends on the value of the first parameter. @@ -2320,7 +2320,7 @@ For instance, the tactic: tactic; do 1? rewrite mult_comm. rewrites at most one time the lemma ``mult_comm`` in all the subgoals -generated by tactic , whereas the tactic: +generated by tactic, whereas the tactic: .. coqdoc:: @@ -2511,7 +2511,7 @@ which behave like: have: term ; first by tactic. move=> clear_switch i_item. -Note that the :token:`clear_switch` *precedes* the:token:`i_item`, which +Note that the :token:`clear_switch` *precedes* the :token:`i_item`, which allows to reuse a name of the context, possibly used by the proof of the assumption, to introduce the new assumption itself. @@ -2783,7 +2783,7 @@ The + the order of the generated subgoals is inversed -+ but the optional clear item is still performed in the *second* ++ the optional clear item is still performed in the *second* branch. This means that the tactic: .. coqdoc:: @@ -2929,7 +2929,7 @@ facts. If an :token:`ident` is prefixed with the ``@`` mark, then a let-in redex is created, which keeps track if its body (if any). The syntax -``( ident := c_pattern)`` allows to generalize an arbitrary term using a +:n:`(@ident := @c_pattern)` allows to generalize an arbitrary term using a given name. Note that its simplest form ``(x := y)`` is just a renaming of ``y`` into ``x``. In particular, this can be useful in order to simulate the generalization of a section variable, otherwise not allowed. Indeed @@ -3917,7 +3917,7 @@ definitely want to avoid repeating large subterms of the goal in the proof script. We do this by “clamping down” selected function symbols in the goal, which prevents them from being considered in simplification or rewriting steps. This clamping is accomplished by -using the occurrence switches (see section:ref:`abbreviations_ssr`) +using the occurrence switches (see section :ref:`abbreviations_ssr`) together with “term tagging” operations. |SSR| provides two levels of tagging. @@ -4385,7 +4385,7 @@ Contextual patterns in rewrite Note: the simplification rule ``addSn`` is applied only under the ``f`` symbol. - Then we simplify also the first addition and expand 0 into 0+0. + Then we simplify also the first addition and expand ``0`` into ``0 + 0``. .. coqtop:: all @@ -4738,7 +4738,7 @@ Interpreting assumptions Interpreting an assumption in the context of a proof consists in applying to it a lemma before generalizing, and/or decomposing this assumption. For instance, with the extensive use of boolean reflection -(see section :ref:`views_and_reflection_ssr`.4), it is quite frequent +(see section :ref:`views_and_reflection_ssr`), it is quite frequent to need to decompose the logical interpretation of (the boolean expression of) a fact, rather than the fact itself. This can be achieved by a combination of ``move : _ => _`` switches, like in the @@ -5201,7 +5201,7 @@ There are three steps in the behavior of an assumption view tactic: For a ``case/term`` tactic, the generalisation step is replaced by a case analysis step. -*View hints* are declared by the user (see section:ref:`views_and_reflection_ssr`.8) and are +*View hints* are declared by the user (see section :ref:`views_and_reflection_ssr`) and are stored in the Hint View database. The proof engine automatically detects from the shape of the top assumption ``top`` and of the view lemma ``term`` provided to the tactic the appropriate view hint in the diff --git a/engine/evarutil.ml b/engine/evarutil.ml index 911b189deb..ea71be8e43 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -331,11 +331,16 @@ let push_rel_decl_to_named_context let map_decl f d = NamedDecl.map_constr f d in - let replace_var_named_declaration id0 id decl = - let id' = NamedDecl.get_id decl in - let id' = if Id.equal id0 id' then id else id' in - let vsubst = [id0 , mkVar id] in - decl |> NamedDecl.set_id id' |> map_decl (replace_vars vsubst) + let rec replace_var_named_declaration id0 id = function + | [] -> [] + | decl :: nc -> + if Id.equal id0 (NamedDecl.get_id decl) then + (* Stop here, the variable cannot occur before its definition *) + (NamedDecl.set_id id decl) :: nc + else + let nc = replace_var_named_declaration id0 id nc in + let vsubst = [id0 , mkVar id] in + map_decl (fun c -> replace_vars vsubst c) decl :: nc in let extract_if_neq id = function | Anonymous -> None @@ -366,7 +371,7 @@ let push_rel_decl_to_named_context context. Unless [id] is a section variable. *) let subst = update_var id0 id subst in let d = decl |> NamedDecl.of_rel_decl (fun _ -> id0) |> map_decl (csubst_subst subst) in - let nc = List.map (replace_var_named_declaration id0 id) nc in + let nc = replace_var_named_declaration id0 id nc in (push_var id0 subst, Id.Set.add id avoid, d :: nc) | Some id0 when hypnaming = FailIfConflict -> user_err Pp.(Id.print id0 ++ str " is already used.") diff --git a/engine/logic_monad.ml b/engine/logic_monad.ml index 2354d2c5e8..7c06bb59f1 100644 --- a/engine/logic_monad.ml +++ b/engine/logic_monad.ml @@ -41,7 +41,7 @@ let _ = CErrors.register_handler begin function | Timeout -> CErrors.user_err ~hdr:"Some timeout function" (Pp.str"Timeout!") | Exception e -> CErrors.print e | TacticFailure e -> CErrors.print e - | _ -> Pervasives.raise CErrors.Unhandled + | _ -> raise CErrors.Unhandled end (** {6 Non-logical layer} *) @@ -70,11 +70,11 @@ struct let map f a = (); fun () -> f (a ()) end) - type 'a ref = 'a Pervasives.ref + type 'a ref = 'a Util.pervasives_ref let ignore a = (); fun () -> ignore (a ()) - let ref a = (); fun () -> Pervasives.ref a + let ref a = (); fun () -> ref a (** [Pervasives.(:=)] *) let (:=) r a = (); fun () -> r := a @@ -93,7 +93,7 @@ struct let (src, info) = CErrors.push src in h (e, info) () - let read_line = fun () -> try Pervasives.read_line () with e -> + let read_line = fun () -> try read_line () with e -> let (e, info) = CErrors.push e in raise ~info e () let print_char = fun c -> (); fun () -> print_char c diff --git a/engine/namegen.ml b/engine/namegen.ml index 77d45ce1e4..89c2fade62 100644 --- a/engine/namegen.ml +++ b/engine/namegen.ml @@ -24,7 +24,6 @@ open EConstr open Vars open Nameops open Libnames -open Globnames open Context.Rel.Declaration module RelDecl = Context.Rel.Declaration @@ -72,7 +71,7 @@ let is_imported_modpath = function in find_prefix (Lib.current_mp ()) | _ -> false -let is_imported_ref = function +let is_imported_ref = let open GlobRef in function | VarRef _ -> false | IndRef (kn,_) | ConstructRef ((kn,_),_) -> @@ -90,7 +89,7 @@ let is_global id = let is_constructor id = try match Nametab.locate (qualid_of_ident id) with - | ConstructRef _ -> true + | GlobRef.ConstructRef _ -> true | _ -> false with Not_found -> false @@ -102,7 +101,7 @@ let is_section_variable id = (**********************************************************************) (* Generating "intuitive" names from its type *) -let global_of_constr = function +let global_of_constr = let open GlobRef in function | Const (c, _) -> ConstRef c | Ind (i, _) -> IndRef i | Construct (c, _) -> ConstructRef c @@ -149,8 +148,8 @@ let hdchar env sigma c = | Cast (c,_,_) | App (c,_) -> hdrec k c | Proj (kn,_) -> lowercase_first_char (Label.to_id (Constant.label (Projection.constant kn))) | Const (kn,_) -> lowercase_first_char (Label.to_id (Constant.label kn)) - | Ind (x,_) -> (try lowercase_first_char (Nametab.basename_of_global (IndRef x)) with Not_found when !Flags.in_debugger -> "zz") - | Construct (x,_) -> (try lowercase_first_char (Nametab.basename_of_global (ConstructRef x)) with Not_found when !Flags.in_debugger -> "zz") + | Ind (x,_) -> (try lowercase_first_char (Nametab.basename_of_global (GlobRef.IndRef x)) with Not_found when !Flags.in_debugger -> "zz") + | Construct (x,_) -> (try lowercase_first_char (Nametab.basename_of_global (GlobRef.ConstructRef x)) with Not_found when !Flags.in_debugger -> "zz") | Var id -> lowercase_first_char id | Sort s -> sort_hdchar (ESorts.kind sigma s) | Rel n -> diff --git a/engine/proofview.ml b/engine/proofview.ml index c4a624e462..8b5bd4cd80 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -542,7 +542,7 @@ let tclDISPATCHGEN join tacs = let tacs = CList.map branch tacs in InfoL.tag (Info.Dispatch) (tclDISPATCHGEN0 join tacs) -let tclDISPATCH tacs = tclDISPATCHGEN Pervasives.ignore tacs +let tclDISPATCH tacs = tclDISPATCHGEN ignore tacs let tclDISPATCHL tacs = tclDISPATCHGEN CList.rev tacs @@ -910,7 +910,7 @@ let tclPROGRESS t = exception Timeout let _ = CErrors.register_handler begin function | Timeout -> CErrors.user_err ~hdr:"Proofview.tclTIMEOUT" (Pp.str"Tactic timeout!") - | _ -> Pervasives.raise CErrors.Unhandled + | _ -> raise CErrors.Unhandled end let tclTIMEOUT n t = diff --git a/engine/termops.ml b/engine/termops.ml index 1ed2d93b3c..2ab2f60421 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -1058,7 +1058,7 @@ let is_section_variable id = with Not_found -> false let global_of_constr sigma c = - let open Globnames in + let open GlobRef in match EConstr.kind sigma c with | Const (c, u) -> ConstRef c, u | Ind (i, u) -> IndRef i, u @@ -1067,7 +1067,7 @@ let global_of_constr sigma c = | _ -> raise Not_found let is_global sigma c t = - let open Globnames in + let open GlobRef in match c, EConstr.kind sigma t with | ConstRef c, Const (c', _) -> Constant.equal c c' | IndRef i, Ind (i', _) -> eq_ind i i' @@ -1379,7 +1379,7 @@ let dependency_closure env sigma sign hyps = List.rev lh let global_app_of_constr sigma c = - let open Globnames in + let open GlobRef in match EConstr.kind sigma c with | Const (c, u) -> (ConstRef c, u), None | Ind (i, u) -> (IndRef i, u), None diff --git a/engine/univGen.ml b/engine/univGen.ml index a347bba188..b1ed3b2694 100644 --- a/engine/univGen.ml +++ b/engine/univGen.ml @@ -56,15 +56,15 @@ let fresh_global_instance ?loc ?names env gr = u, ctx let fresh_constant_instance env c = - let u, ctx = fresh_global_instance env (ConstRef c) in + let u, ctx = fresh_global_instance env (GlobRef.ConstRef c) in (c, u), ctx let fresh_inductive_instance env ind = - let u, ctx = fresh_global_instance env (IndRef ind) in + let u, ctx = fresh_global_instance env (GlobRef.IndRef ind) in (ind, u), ctx let fresh_constructor_instance env c = - let u, ctx = fresh_global_instance env (ConstructRef c) in + let u, ctx = fresh_global_instance env (GlobRef.ConstructRef c) in (c, u), ctx let fresh_global_instance ?loc ?names env gr = @@ -84,10 +84,10 @@ let fresh_global_or_constr_instance env = function let global_of_constr c = match kind c with - | Const (c, u) -> ConstRef c, u - | Ind (i, u) -> IndRef i, u - | Construct (c, u) -> ConstructRef c, u - | Var id -> VarRef id, Instance.empty + | Const (c, u) -> GlobRef.ConstRef c, u + | Ind (i, u) -> GlobRef.IndRef i, u + | Construct (c, u) -> GlobRef.ConstructRef c, u + | Var id -> GlobRef.VarRef id, Instance.empty | _ -> raise Not_found let fresh_sort_in_family = function diff --git a/gramlib/grammar.ml b/gramlib/grammar.ml index f9d18e7190..f96cfebed5 100644 --- a/gramlib/grammar.ml +++ b/gramlib/grammar.ml @@ -871,39 +871,33 @@ and print_rule : type s tr p. formatter -> (s, tr, p) ty_symbols -> unit = and print_level : type s. _ -> _ -> s ex_symbols list -> _ = fun ppf pp_print_space rules -> fprintf ppf "@[<hov 0>[ "; - let _ = - List.fold_left - (fun sep (ExS rule) -> - fprintf ppf "%t%a" sep print_rule rule; - fun ppf -> fprintf ppf "%a| " pp_print_space ()) - (fun ppf -> ()) rules + let () = + Format.pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf "%a| " pp_print_space ()) + (fun ppf (ExS rule) -> print_rule ppf rule) + ppf rules in fprintf ppf " ]@]" let print_levels ppf elev = - let _ = - List.fold_left - (fun sep (Level lev) -> - let rules = - List.map (fun (ExS t) -> ExS (TCns (MayRec2, Sself, t))) (flatten_tree lev.lsuffix) @ - flatten_tree lev.lprefix - in - fprintf ppf "%t@[<hov 2>" sep; - begin match lev.lname with + Format.pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf "@,| ") + (fun ppf (Level lev) -> + let rules = + List.map (fun (ExS t) -> ExS (TCns (MayRec2, Sself, t))) (flatten_tree lev.lsuffix) @ + flatten_tree lev.lprefix + in + fprintf ppf "@[<hov 2>"; + begin match lev.lname with Some n -> fprintf ppf "%a@;<1 2>" print_str n | None -> () - end; - begin match lev.assoc with + end; + begin match lev.assoc with LeftA -> fprintf ppf "LEFTA" | RightA -> fprintf ppf "RIGHTA" | NonA -> fprintf ppf "NONA" - end; - fprintf ppf "@]@;<1 2>"; - print_level ppf pp_force_newline rules; - fun ppf -> fprintf ppf "@,| ") - (fun ppf -> ()) elev - in - () + end; + fprintf ppf "@]@;<1 2>"; + print_level ppf pp_force_newline rules) + ppf elev let print_entry ppf e = fprintf ppf "@[<v 0>[ "; diff --git a/ide/coq.ml b/ide/coq.ml index 92c24b3b85..889cc3be36 100644 --- a/ide/coq.ml +++ b/ide/coq.ml @@ -102,7 +102,7 @@ let display_coqtop_answer cmd lines = let rec filter_coq_opts args = let argstr = String.concat " " (List.map Filename.quote args) in - let cmd = Filename.quote (coqtop_path ()) ^" -nois -filteropts " ^ argstr in + let cmd = Filename.quote (coqtop_path ()) ^" -nois -batch " ^ argstr in let cmd = requote cmd in let filtered_args = ref [] in let errlines = ref [] in diff --git a/ide/idetop.ml b/ide/idetop.ml index c6a8fdaa55..7c6fa8951b 100644 --- a/ide/idetop.ml +++ b/ide/idetop.ml @@ -392,7 +392,7 @@ let handle_exn (e, info) = let loc_of e = match Loc.get_loc e with | Some loc -> Some (Loc.unloc loc) | _ -> None in - let mk_msg () = CErrors.print ~info e in + let mk_msg () = CErrors.iprint (e,info) in match e with | e -> match Stateid.get info with @@ -496,7 +496,10 @@ let msg_format = ref (fun () -> (* The loop ignores the command line arguments as the current model delegates its handing to the toplevel container. *) -let loop ~opts:_ ~state = +let loop run_mode ~opts:_ state = + match run_mode with + | Coqtop.Batch -> exit 0 + | Coqtop.Interactive -> let open Vernac.State in set_doc state.doc; init_signal_handler (); @@ -549,16 +552,42 @@ let rec parse = function x :: parse rest | [] -> [] -let () = Usage.add_to_usage "coqidetop" -" --xml_format=Ppcmds serialize pretty printing messages using the std_ppcmds format\ +let coqidetop_specific_usage = Usage.{ + executable_name = "coqidetop"; + extra_args = ""; + extra_options = "\n\ +coqidetop specific options:\n\ +\n --xml_formatinclude dir (idem)\ +\n --xml_format=Ppcmds serialize pretty printing messages using the std_ppcmds format\ \n --help-XML-protocol print documentation of the Coq XML protocol\n" +} -let islave_init ~opts extra_args = - let args = parse extra_args in - CoqworkmgrApi.(init High); - opts, args +let islave_parse ~opts extra_args = + let open Coqtop in + let run_mode, extra_args = coqtop_toplevel.parse_extra ~opts extra_args in + let extra_args = parse extra_args in + (* One of the role of coqidetop is to find the name of buffers to open *) + (* in the command line; Coqide is waiting these names on stdout *) + (* (see filter_coq_opts in coq.ml), so we send them now *) + print_string (String.concat "\n" extra_args); + run_mode, [] + +let islave_init run_mode ~opts = + if run_mode = Coqtop.Batch then Flags.quiet := true; + Coqtop.init_toploop opts + +let islave_default_opts = + Coqargs.{ default with + config = { default.config with + stm_flags = { default.config.stm_flags with + Stm.AsyncOpts.async_proofs_worker_priority = CoqworkmgrApi.High }}} let () = let open Coqtop in - let custom = { init = islave_init; run = loop; opts = Coqargs.default } in + let custom = { + parse_extra = islave_parse ; + help = coqidetop_specific_usage; + init = islave_init; + run = loop; + opts = islave_default_opts } in start_coq custom diff --git a/ide/protocol/richpp.ml b/ide/protocol/richpp.ml index 507b985d2f..463d93af0d 100644 --- a/ide/protocol/richpp.ml +++ b/ide/protocol/richpp.ml @@ -94,7 +94,7 @@ let rich_pp width ppcmds = print_close_tag = ignore; } in - pp_set_formatter_tag_functions ft tag_functions; + pp_set_formatter_tag_functions ft tag_functions [@warning "-3"]; pp_set_mark_tags ft true; (* Setting the formatter *) @@ -107,9 +107,9 @@ let rich_pp width ppcmds = (* The whole output must be a valid document. To that end, we nest the document inside <pp> tags. *) pp_open_box ft 0; - pp_open_tag ft "pp"; + pp_open_tag ft "pp" [@warning "-3"]; Pp.(pp_with ft ppcmds); - pp_close_tag ft (); + pp_close_tag ft () [@warning "-3"]; pp_close_box ft (); (* Get the resulting XML tree. *) diff --git a/ide/session.ml b/ide/session.ml index 3792730455..a9c106a765 100644 --- a/ide/session.ml +++ b/ide/session.ml @@ -275,9 +275,9 @@ let make_table_widget ?sort cd cb = let make_sorting i (_, c) = let sort (store : GTree.model) it1 it2 = match c with | `IntC c -> - Pervasives.compare (store#get ~row:it1 ~column:c) (store#get ~row:it2 ~column:c) + compare (store#get ~row:it1 ~column:c) (store#get ~row:it2 ~column:c) | `StringC c -> - Pervasives.compare (store#get ~row:it1 ~column:c) (store#get ~row:it2 ~column:c) + compare (store#get ~row:it1 ~column:c) (store#get ~row:it2 ~column:c) in store#set_sort_func i sort in diff --git a/ide/wg_Completion.ml b/ide/wg_Completion.ml index 7758d89ed8..98390e810f 100644 --- a/ide/wg_Completion.ml +++ b/ide/wg_Completion.ml @@ -15,7 +15,7 @@ struct (* we use first size, then usual comparison *) let d = String.length s1 - String.length s2 in if d <> 0 then d - else Pervasives.compare s1 s2 + else compare s1 s2 end module Proposals = Set.Make(StringOrd) diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 8573dccdf9..96392edb11 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -16,7 +16,6 @@ open Names open Nameops open Termops open Libnames -open Globnames open Namegen open Impargs open CAst @@ -69,7 +68,7 @@ let print_no_symbol = ref false (* Turning notations and scopes on and off for printing *) module IRuleSet = Set.Make(struct type t = interp_rule - let compare x y = Pervasives.compare x y + let compare x y = compare x y end) let inactive_notations_table = @@ -361,7 +360,7 @@ let mkPat ?loc qid l = CAst.make ?loc @@ if List.is_empty l then CPatAtom (Some qid) else CPatCstr (qid,None,l) let pattern_printable_in_both_syntax (ind,_ as c) = - let impl_st = extract_impargs_data (implicits_of_global (ConstructRef c)) in + let impl_st = extract_impargs_data (implicits_of_global (GlobRef.ConstructRef c)) in let nb_params = Inductiveops.inductive_nparams (Global.env()) ind in List.exists (fun (_,impls) -> (List.length impls >= nb_params) && @@ -416,7 +415,7 @@ let rec extern_cases_pattern_in_scope (custom,scopes as allscopes) vars pat = (* we don't want to have 'x := _' in our patterns *) acc | Some c, _ -> - ((extern_reference ?loc Id.Set.empty (ConstRef c), pat) :: acc) + ((extern_reference ?loc Id.Set.empty (GlobRef.ConstRef c), pat) :: acc) | _ -> raise No_match in ip q tail acc | _ -> assert false @@ -424,14 +423,14 @@ let rec extern_cases_pattern_in_scope (custom,scopes as allscopes) vars pat = CPatRecord(List.rev (ip projs args [])) with Not_found | No_match | Exit -> - let c = extern_reference Id.Set.empty (ConstructRef cstrsp) in + let c = extern_reference Id.Set.empty (GlobRef.ConstructRef cstrsp) in if Constrintern.get_asymmetric_patterns () then if pattern_printable_in_both_syntax cstrsp then CPatCstr (c, None, args) else CPatCstr (c, Some (add_patt_for_params (fst cstrsp) args), []) else let full_args = add_patt_for_params (fst cstrsp) args in - match drop_implicits_in_patt (ConstructRef cstrsp) 0 full_args with + match drop_implicits_in_patt (GlobRef.ConstructRef cstrsp) 0 full_args with | Some true_args -> CPatCstr (c, None, true_args) | None -> CPatCstr (c, Some full_args, []) in @@ -500,7 +499,7 @@ and extern_notation_pattern allscopes vars t = function match DAst.get t with | PatCstr (cstr,args,na) -> let t = if na = Anonymous then t else DAst.make ?loc (PatCstr (cstr,args,Anonymous)) in - let p = apply_notation_to_pattern ?loc (ConstructRef cstr) + let p = apply_notation_to_pattern ?loc (GlobRef.ConstructRef cstr) (match_notation_constr_cases_pattern t pat) allscopes vars keyrule in insert_pat_alias ?loc p na | PatVar Anonymous -> CAst.make ?loc @@ CPatAtom None @@ -513,7 +512,7 @@ let rec extern_notation_ind_pattern allscopes vars ind args = function | (keyrule,pat,n as _rule)::rules -> try if is_inactive_rule keyrule then raise No_match; - apply_notation_to_pattern (IndRef ind) + apply_notation_to_pattern (GlobRef.IndRef ind) (match_notation_constr_ind_pattern ind args pat) allscopes vars keyrule with No_match -> extern_notation_ind_pattern allscopes vars ind args rules @@ -522,7 +521,7 @@ let extern_ind_pattern_in_scope (custom,scopes as allscopes) vars ind args = (* pboutill: There are letins in pat which is incompatible with notations and not explicit application. *) if !Flags.in_debugger||Inductiveops.inductive_has_local_defs (Global.env()) ind then - let c = extern_reference vars (IndRef ind) in + let c = extern_reference vars (GlobRef.IndRef ind) in let args = List.map (extern_cases_pattern_in_scope allscopes vars) args in CAst.make @@ CPatCstr (c, Some (add_patt_for_params ind args), []) else @@ -531,9 +530,9 @@ let extern_ind_pattern_in_scope (custom,scopes as allscopes) vars ind args = extern_notation_ind_pattern allscopes vars ind args (uninterp_ind_pattern_notations ind) with No_match -> - let c = extern_reference vars (IndRef ind) in + let c = extern_reference vars (GlobRef.IndRef ind) in let args = List.map (extern_cases_pattern_in_scope allscopes vars) args in - match drop_implicits_in_patt (IndRef ind) 0 args with + match drop_implicits_in_patt (GlobRef.IndRef ind) 0 args with |Some true_args -> CAst.make @@ CPatCstr (c, None, true_args) |None -> CAst.make @@ CPatCstr (c, Some args, []) @@ -825,7 +824,7 @@ let rec extern inctx scopes vars r = begin try if !Flags.raw_print then raise Exit; - let cstrsp = match ref with ConstructRef c -> c | _ -> raise Not_found in + let cstrsp = match ref with GlobRef.ConstructRef c -> c | _ -> raise Not_found in let struc = Recordops.lookup_structure (fst cstrsp) in if PrintingRecord.active (fst cstrsp) then () @@ -858,7 +857,7 @@ let rec extern inctx scopes vars r = (* we give up since the constructor is not complete *) | (arg, scopes) :: tail -> let head = extern true scopes vars arg in - ip q locs' tail ((extern_reference ?loc Id.Set.empty (ConstRef c), head) :: acc) + ip q locs' tail ((extern_reference ?loc Id.Set.empty (GlobRef.ConstRef c), head) :: acc) in CRecord (List.rev (ip projs locals args [])) with @@ -1238,7 +1237,7 @@ let rec glob_of_pat avoid env sigma pat = DAst.make @@ match pat with GVar id | PMeta None -> GHole (Evar_kinds.InternalHole, IntroAnonymous,None) | PMeta (Some n) -> GPatVar (Evar_kinds.FirstOrderPatVar n) - | PProj (p,c) -> GApp (DAst.make @@ GRef (ConstRef (Projection.constant p),None), + | PProj (p,c) -> GApp (DAst.make @@ GRef (GlobRef.ConstRef (Projection.constant p),None), [glob_of_pat avoid env sigma c]) | PApp (f,args) -> GApp (glob_of_pat avoid env sigma f,Array.map_to_list (glob_of_pat avoid env sigma) args) diff --git a/interp/constrintern.ml b/interp/constrintern.ml index be8f99028c..f341071728 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -375,20 +375,17 @@ let check_hidden_implicit_parameters ?loc id impls = let pure_push_name_env (id,implargs) env = {env with ids = Id.Set.add id env.ids; impls = Id.Map.add id implargs env.impls} -let push_name_env ?(global_level=false) ntnvars implargs env = +let push_name_env ntnvars implargs env = let open CAst in function | { loc; v = Anonymous } -> - if global_level then - user_err ?loc (str "Anonymous variables not allowed"); env | { loc; v = Name id } -> check_hidden_implicit_parameters ?loc id env.impls ; if Id.Map.is_empty ntnvars && Id.equal id ldots_var then error_ldots_var ?loc; set_var_scope ?loc id false (env.tmp_scope,env.scopes) ntnvars; - if global_level then Dumpglob.dump_definition CAst.(make ?loc id) true "var" - else Dumpglob.dump_binding ?loc id; + Dumpglob.dump_binding ?loc id; pure_push_name_env (id,implargs) env let remember_binders_impargs env bl = @@ -400,7 +397,7 @@ let remember_binders_impargs env bl = let restore_binders_impargs env l = List.fold_right pure_push_name_env l env -let intern_generalized_binder ?(global_level=false) intern_type ntnvars +let intern_generalized_binder intern_type ntnvars env {loc;v=na} b' t ty = let ids = (match na with Anonymous -> fun x -> x | Name na -> Id.Set.add na) env.ids in let ty, ids' = @@ -410,7 +407,7 @@ let intern_generalized_binder ?(global_level=false) intern_type ntnvars let ty' = intern_type {env with ids = ids; unb = true} ty in let fvs = Implicit_quantifiers.generalizable_vars_of_glob_constr ~bound:ids ~allowed:ids' ty' in let env' = List.fold_left - (fun env {loc;v=x} -> push_name_env ~global_level ntnvars (Variable,[],[],[])(*?*) env (make ?loc @@ Name x)) + (fun env {loc;v=x} -> push_name_env ntnvars (Variable,[],[],[])(*?*) env (make ?loc @@ Name x)) env fvs in let bl = List.map CAst.(map (fun id -> @@ -419,9 +416,7 @@ let intern_generalized_binder ?(global_level=false) intern_type ntnvars in let na = match na with | Anonymous -> - if global_level then na - else - let name = + let name = let id = match ty with | { v = CApp ((_, { v = CRef (qid,_) } ), _) } when qualid_is_ident qid -> @@ -430,7 +425,7 @@ let intern_generalized_binder ?(global_level=false) intern_type ntnvars in Implicit_quantifiers.make_fresh ids' (Global.env ()) id in Name name | _ -> na - in (push_name_env ~global_level ntnvars (impls_type_list ty')(*?*) env' (make ?loc na)), (make ?loc (na,b',ty')) :: List.rev bl + in (push_name_env ntnvars (impls_type_list ty')(*?*) env' (make ?loc na)), (make ?loc (na,b',ty')) :: List.rev bl let intern_assumption intern ntnvars env nal bk ty = let intern_type env = intern (set_type_scope env) in @@ -481,7 +476,7 @@ let intern_cases_pattern_as_binder ?loc ntnvars env p = let na = make ?loc @@ Name id in env,((disjpat,il),id),na -let intern_local_binder_aux ?(global_level=false) intern ntnvars (env,bl) = function +let intern_local_binder_aux intern ntnvars (env,bl) = function | CLocalAssum(nal,bk,ty) -> let env, bl' = intern_assumption intern ntnvars env nal bk ty in let bl' = List.map (fun {loc;v=(na,c,t)} -> DAst.make ?loc @@ GLocalAssum (na,c,t)) bl' in @@ -652,7 +647,7 @@ let terms_of_binders bl = | PatVar (Name id) -> CRef (qualid_of_ident id, None) | PatVar (Anonymous) -> error_cannot_coerce_wildcard_term ?loc () | PatCstr (c,l,_) -> - let qid = qualid_of_path ?loc (Nametab.path_of_global (ConstructRef c)) in + let qid = qualid_of_path ?loc (Nametab.path_of_global (GlobRef.ConstructRef c)) in let hole = CAst.make ?loc @@ CHole (None,IntroAnonymous,None) in let params = List.make (Inductiveops.inductive_nparams (Global.env()) (fst c)) hole in CAppExpl ((None,qid,None),params @ List.map term_of_pat l)) pt in @@ -954,16 +949,17 @@ let intern_var env (ltacvars,ntnvars) namedctx loc id us = (* Is [id] a goal or section variable *) let _ = Environ.lookup_named_ctxt id namedctx in try - (* [id] a section variable *) - (* Redundant: could be done in intern_qualid *) - let ref = VarRef id in - let impls = implicits_of_global ref in - let scopes = find_arguments_scope ref in - Dumpglob.dump_reference ?loc "<>" (string_of_qualid (Decls.variable_secpath id)) "var"; - DAst.make ?loc @@ GRef (ref, us), impls, scopes, [] + (* [id] a section variable *) + (* Redundant: could be done in intern_qualid *) + let ref = GlobRef.VarRef id in + let impls = implicits_of_global ref in + let scopes = find_arguments_scope ref in + Dumpglob.dump_secvar ?loc id; (* this raises Not_found when not a section variable *) + (* Someday we should stop relying on Dumglob raising exceptions *) + DAst.make ?loc @@ GRef (ref, us), impls, scopes, [] with e when CErrors.noncritical e -> - (* [id] a goal variable *) - gvar (loc,id) us, [], [], [] + (* [id] a goal variable *) + gvar (loc,id) us, [], [], [] let find_appl_head_data c = match DAst.get c with @@ -1018,7 +1014,7 @@ let glob_sort_of_level (level: glob_level) : glob_sort = let intern_qualid ?(no_secvar=false) qid intern env ntnvars us args = let loc = qid.loc in match intern_extended_global_of_qualid qid with - | TrueGlobal (VarRef _) when no_secvar -> + | TrueGlobal (GlobRef.VarRef _) when no_secvar -> (* Rule out section vars since these should have been found by intern_var *) raise Not_found | TrueGlobal ref -> (DAst.make ?loc @@ GRef (ref, us)), Some ref, args @@ -1067,6 +1063,7 @@ let check_applied_projection isproj realref qid = match isproj with | None -> () | Some projargs -> + let open GlobRef in let is_prim = match realref with | None | Some (IndRef _ | ConstructRef _ | VarRef _) -> false | Some (ConstRef c) -> @@ -1223,7 +1220,9 @@ let insert_local_defs_in_pattern (ind,j) l = | _ -> assert false in aux decls l -let add_local_defs_and_check_length loc env g pl args = match g with +let add_local_defs_and_check_length loc env g pl args = + let open GlobRef in + match g with | ConstructRef cstr -> (* We consider that no variables corresponding to local binders have been given in the "explicit" arguments, which come from a @@ -1263,14 +1262,14 @@ let add_implicits_check_length fail nargs nargs_with_letin impls_st len_pl1 pl2 let add_implicits_check_constructor_length env loc c len_pl1 pl2 = let nargs = Inductiveops.constructor_nallargs env c in let nargs' = Inductiveops.constructor_nalldecls env c in - let impls_st = implicits_of_global (ConstructRef c) in + let impls_st = implicits_of_global (GlobRef.ConstructRef c) in add_implicits_check_length (error_wrong_numarg_constructor ?loc env c) nargs nargs' impls_st len_pl1 pl2 let add_implicits_check_ind_length env loc c len_pl1 pl2 = let nallargs = inductive_nallargs env c in let nalldecls = inductive_nalldecls env c in - let impls_st = implicits_of_global (IndRef c) in + let impls_st = implicits_of_global (GlobRef.IndRef c) in add_implicits_check_length (error_wrong_numarg_inductive ?loc env c) nallargs nalldecls impls_st len_pl1 pl2 @@ -1287,6 +1286,7 @@ let chop_params_pattern loc ind args with_letin = args let find_constructor loc add_params ref = + let open GlobRef in let (ind,_ as cstr) = match ref with | ConstructRef cstr -> cstr | IndRef _ -> @@ -1321,7 +1321,7 @@ let check_duplicate ?loc fields = pr_qualid r ++ str ".") let inductive_of_record loc record = - let inductive = IndRef (inductive_of_constructor record.Recordops.s_CONST) in + let inductive = GlobRef.IndRef (inductive_of_constructor record.Recordops.s_CONST) in Nametab.shortest_qualid_of_global ?loc Id.Set.empty inductive (** [sort_fields ~complete loc fields completer] expects a list @@ -1352,7 +1352,7 @@ let sort_fields ~complete loc fields completer = let nparams = record.Recordops.s_EXPECTEDPARAM in (* the reference constructor of the record *) let base_constructor = - let global_record_id = ConstructRef record.Recordops.s_CONST in + let global_record_id = GlobRef.ConstructRef record.Recordops.s_CONST in try Nametab.shortest_qualid_of_global ?loc Id.Set.empty global_record_id with Not_found -> anomaly (str "Environment corruption for records.") in @@ -1367,7 +1367,7 @@ let sort_fields ~complete loc fields completer = match projs with | [] -> (idx, acc_first_idx, acc) | (Some field_glob_id) :: projs -> - let field_glob_ref = ConstRef field_glob_id in + let field_glob_ref = GlobRef.ConstRef field_glob_id in let first_field = GlobRef.equal field_glob_ref first_field_glob_ref in begin match proj_kinds with | [] -> anomaly (Pp.str "Number of projections mismatch.") @@ -1411,7 +1411,7 @@ let sort_fields ~complete loc fields completer = raise (InternalizationError(loc, NotAProjectionOf (field_ref, inductive_ref))) in let remaining_projs, (field_index, _) = - let the_proj (idx, glob_id) = GlobRef.equal field_glob_ref (ConstRef glob_id) in + let the_proj (idx, glob_id) = GlobRef.equal field_glob_ref (GlobRef.ConstRef glob_id) in try CList.extract_first the_proj remaining_projs with Not_found -> let ind1 = inductive_of_record loc record in @@ -1522,12 +1522,12 @@ let drop_notations_pattern looked_for genv = let ensure_kind top loc g = try if top then looked_for g else - match g with ConstructRef _ -> () | _ -> raise Not_found + match g with GlobRef.ConstructRef _ -> () | _ -> raise Not_found with Not_found -> error_invalid_pattern_notation ?loc () in let test_kind top = - if top then looked_for else function ConstructRef _ -> () | _ -> raise Not_found + if top then looked_for else function GlobRef.ConstructRef _ -> () | _ -> raise Not_found in (* [rcp_of_glob] : from [glob_constr] to [raw_cases_pattern_expr] *) let rec rcp_of_glob scopes x = DAst.(map (function @@ -1740,7 +1740,7 @@ let rec intern_pat genv ntnvars aliases pat = let intern_cases_pattern genv ntnvars scopes aliases pat = intern_pat genv ntnvars aliases - (drop_notations_pattern (function ConstructRef _ -> () | _ -> raise Not_found) genv scopes pat) + (drop_notations_pattern (function GlobRef.ConstructRef _ -> () | _ -> raise Not_found) genv scopes pat) let _ = intern_cases_pattern_fwd := @@ -1749,13 +1749,13 @@ let _ = let intern_ind_pattern genv ntnvars scopes pat = let no_not = try - drop_notations_pattern (function (IndRef _ | ConstructRef _) -> () | _ -> raise Not_found) genv scopes pat + drop_notations_pattern (function (GlobRef.IndRef _ | GlobRef.ConstructRef _) -> () | _ -> raise Not_found) genv scopes pat with InternalizationError(loc,NotAConstructor _) -> error_bad_inductive_type ?loc in let loc = no_not.CAst.loc in match DAst.get no_not with | RCPatCstr (head, expl_pl, pl) -> - let c = (function IndRef ind -> ind | _ -> error_bad_inductive_type ?loc) head in + let c = (function GlobRef.IndRef ind -> ind | _ -> error_bad_inductive_type ?loc) head in let with_letin, pl2 = add_implicits_check_ind_length genv loc c (List.length expl_pl) pl in let idslpl = List.map (intern_pat genv ntnvars empty_alias) (expl_pl@pl2) in @@ -1794,7 +1794,7 @@ let set_hole_implicit i b c = Loc.tag ?loc (Evar_kinds.ImplicitArg (r,i,b),IntroAnonymous,None) | _ -> anomaly (Pp.str "Only refs have implicits.") end - | GVar id -> Loc.tag ?loc (Evar_kinds.ImplicitArg (VarRef id,i,b),IntroAnonymous,None) + | GVar id -> Loc.tag ?loc (Evar_kinds.ImplicitArg (GlobRef.VarRef id,i,b),IntroAnonymous,None) | _ -> anomaly (Pp.str "Only refs have implicits.") let exists_implicit_name id = @@ -2165,7 +2165,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let loc = tm'.CAst.loc in match DAst.get tm', na with | GVar id, None when not (Id.Map.mem id (snd lvar)) -> Some id, CAst.make ?loc @@ Name id - | GRef (VarRef id, _), None -> Some id, CAst.make ?loc @@ Name id + | GRef (GlobRef.VarRef id, _), None -> Some id, CAst.make ?loc @@ Name id | _, None -> None, CAst.make Anonymous | _, Some ({ CAst.loc; v = na } as lna) -> None, lna in (* the "in" part *) @@ -2424,12 +2424,12 @@ let interp_binder_evars env sigma na t = let my_intern_constr env lvar acc c = internalize env acc false lvar c -let intern_context global_level env impl_env binders = +let intern_context env impl_env binders = try let lvar = (empty_ltac_sign, Id.Map.empty) in let lenv, bl = List.fold_left (fun (lenv, bl) b -> - let (env, bl) = intern_local_binder_aux ~global_level (my_intern_constr env lvar) Id.Map.empty (lenv, bl) b in + let (env, bl) = intern_local_binder_aux (my_intern_constr env lvar) Id.Map.empty (lenv, bl) b in (env, bl)) ({ids = extract_ids env; unb = false; tmp_scope = None; scopes = []; impls = impl_env}, []) binders in @@ -2465,7 +2465,7 @@ let interp_glob_context_evars ?(program_mode=false) env sigma k bl = (env,sigma,[],k+1,[]) (List.rev bl) in sigma, ((env, par), List.rev impls) -let interp_context_evars ?program_mode ?(global_level=false) ?(impl_env=empty_internalization_env) ?(shift=0) env sigma params = - let int_env,bl = intern_context global_level env impl_env params in +let interp_context_evars ?program_mode ?(impl_env=empty_internalization_env) ?(shift=0) env sigma params = + let int_env,bl = intern_context env impl_env params in let sigma, x = interp_glob_context_evars ?program_mode env sigma shift bl in sigma, (int_env, x) diff --git a/interp/constrintern.mli b/interp/constrintern.mli index 6c1f4898d9..2e7b832e55 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -90,7 +90,7 @@ val intern_gen : typing_constraint -> env -> evar_map -> val intern_pattern : env -> cases_pattern_expr -> lident list * (Id.t Id.Map.t * cases_pattern) list -val intern_context : bool -> env -> internalization_env -> local_binder_expr list -> internalization_env * glob_decl list +val intern_context : env -> internalization_env -> local_binder_expr list -> internalization_env * glob_decl list (** {6 Composing internalization with type inference (pretyping) } *) @@ -158,7 +158,7 @@ val interp_binder_evars : env -> evar_map -> Name.t -> constr_expr -> evar_map * (** Interpret contexts: returns extended env and context *) val interp_context_evars : - ?program_mode:bool -> ?global_level:bool -> ?impl_env:internalization_env -> ?shift:int -> + ?program_mode:bool -> ?impl_env:internalization_env -> ?shift:int -> env -> evar_map -> local_binder_expr list -> evar_map * (internalization_env * ((env * rel_context) * Impargs.manual_implicits)) diff --git a/interp/decls.ml b/interp/decls.ml new file mode 100644 index 0000000000..d9d33b5e0b --- /dev/null +++ b/interp/decls.ml @@ -0,0 +1,80 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** This module registers tables for some non-logical informations + associated declarations *) + +open Names +open Libnames + +type theorem_kind = + | Theorem + | Lemma + | Fact + | Remark + | Property + | Proposition + | Corollary + +type definition_object_kind = + | Definition + | Coercion + | SubClass + | CanonicalStructure + | Example + | Fixpoint + | CoFixpoint + | Scheme + | StructureComponent + | IdentityCoercion + | Instance + | Method + | Let + +type assumption_object_kind = Definitional | Logical | Conjectural | Context + +(* [assumption_kind] + + | Local | Global + ------------------------------------ + Definitional | Variable | Parameter + Logical | Hypothesis | Axiom + +*) + +(** Kinds *) + +type logical_kind = + | IsPrimitive + | IsAssumption of assumption_object_kind + | IsDefinition of definition_object_kind + | IsProof of theorem_kind + +(** Data associated to section variables and local definitions *) + +type variable_data = { + opaque:bool; + kind:logical_kind; +} + +let vartab = + Summary.ref (Id.Map.empty : (variable_data*DirPath.t) Id.Map.t) ~name:"VARIABLE" + +let secpath () = drop_dirpath_prefix (Lib.library_dp()) (Lib.cwd()) +let add_variable_data id o = vartab := Id.Map.add id (o,secpath()) !vartab + +let variable_opacity id = let {opaque},_ = Id.Map.find id !vartab in opaque +let variable_kind id = let {kind},_ = Id.Map.find id !vartab in kind + +let variable_secpath id = + let _, dir = Id.Map.find id !vartab in + make_qualid dir id + +let variable_exists id = Id.Map.mem id !vartab diff --git a/library/decls.mli b/interp/decls.mli index f88958bb04..56866aeb43 100644 --- a/library/decls.mli +++ b/interp/decls.mli @@ -10,7 +10,49 @@ open Names open Libnames -open Decl_kinds + +type theorem_kind = + | Theorem + | Lemma + | Fact + | Remark + | Property + | Proposition + | Corollary + +type definition_object_kind = + | Definition + | Coercion + | SubClass + | CanonicalStructure + | Example + | Fixpoint + | CoFixpoint + | Scheme + | StructureComponent + | IdentityCoercion + | Instance + | Method + | Let + +type assumption_object_kind = Definitional | Logical | Conjectural | Context + +(* [assumption_kind] + + | Local | Global + ------------------------------------ + Definitional | Variable | Parameter + Logical | Hypothesis | Axiom + +*) + +(** Kinds used in library *) + +type logical_kind = + | IsPrimitive + | IsAssumption of assumption_object_kind + | IsDefinition of definition_object_kind + | IsProof of theorem_kind (** This module manages non-kernel informations about declarations. It is either non-logical informations or logical informations that @@ -19,23 +61,18 @@ open Decl_kinds (** Registration and access to the table of variable *) type variable_data = { - path:DirPath.t; opaque:bool; - univs:Univ.ContextSet.t; - poly:bool; kind:logical_kind; } val add_variable_data : variable -> variable_data -> unit -val variable_path : variable -> DirPath.t + +(* Only used in dumpglob *) val variable_secpath : variable -> qualid val variable_kind : variable -> logical_kind -val variable_opacity : variable -> bool -val variable_context : variable -> Univ.ContextSet.t -val variable_polymorphic : variable -> bool -val variable_exists : variable -> bool -(** Registration and access to the table of constants *) +(* User in Lemma, Very dubious *) +val variable_opacity : variable -> bool -val add_constant_kind : Constant.t -> logical_kind -> unit -val constant_kind : Constant.t -> logical_kind +(* Used in declare, very dubious *) +val variable_exists : variable -> bool diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml index e1269025a4..8d6a266c30 100644 --- a/interp/dumpglob.ml +++ b/interp/dumpglob.ml @@ -12,13 +12,13 @@ open Util (* Dump of globalization (to be used by coqdoc) *) -let glob_file = ref Pervasives.stdout +let glob_file = ref stdout let open_glob_file f = - glob_file := Pervasives.open_out f + glob_file := open_out f let close_glob_file () = - Pervasives.close_out !glob_file + close_out !glob_file type glob_output_t = | NoGlob @@ -37,7 +37,7 @@ let dump_to_dotglob () = glob_output := MultFiles let dump_into_file f = if String.equal f "stdout" then - (glob_output := StdOut; glob_file := Pervasives.stdout) + (glob_output := StdOut; glob_file := stdout) else (glob_output := File f; open_glob_file f) @@ -45,7 +45,7 @@ let feedback_glob () = glob_output := Feedback let dump_string s = if dump () && !glob_output != Feedback then - Pervasives.output_string !glob_file s + output_string !glob_file s let start_dump_glob ~vfile ~vofile = match !glob_output with @@ -69,7 +69,7 @@ let previous_state = ref MultFiles let pause () = previous_state := !glob_output; glob_output := NoGlob let continue () = glob_output := !previous_state -open Decl_kinds +open Decls open Declarations let type_of_logical_kind = function @@ -104,16 +104,24 @@ let type_of_logical_kind = function | Corollary -> "thm") | IsPrimitive -> "prim" + +(** Data associated to global parameters and constants *) + +let csttab = Summary.ref (Names.Cmap.empty : logical_kind Names.Cmap.t) ~name:"CONSTANT" +let add_constant_kind kn k = csttab := Names.Cmap.add kn k !csttab +let constant_kind kn = Names.Cmap.find kn !csttab + let type_of_global_ref gr = if Typeclasses.is_class gr then "class" else + let open Names.GlobRef in match gr with - | Globnames.ConstRef cst -> - type_of_logical_kind (Decls.constant_kind cst) - | Globnames.VarRef v -> - "var" ^ type_of_logical_kind (Decls.variable_kind v) - | Globnames.IndRef ind -> + | ConstRef cst -> + type_of_logical_kind (constant_kind cst) + | VarRef v -> + "var" ^ type_of_logical_kind (Decls.variable_kind v) + | IndRef ind -> let (mib,oib) = Inductive.lookup_mind_specif (Global.env ()) ind in if mib.Declarations.mind_record <> Declarations.NotRecord then begin match mib.Declarations.mind_finite with @@ -127,7 +135,7 @@ let type_of_global_ref gr = | BiFinite -> "variant" | CoFinite -> "coind" end - | Globnames.ConstructRef _ -> "constr" + | ConstructRef _ -> "constr" let remove_sections dir = let cwd = Lib.cwd_except_section () in @@ -159,6 +167,9 @@ let dump_reference ?loc modpath ident ty = let filepath = Names.DirPath.to_string (Lib.library_dp ()) in dump_ref ?loc filepath modpath ident ty +let dump_secvar ?loc id = + dump_reference ?loc "<>" (Libnames.string_of_qualid (Decls.variable_secpath id)) "var" + let dump_modref ?loc mp ty = let (dp, l) = Lib.split_modpath mp in let filepath = Names.DirPath.to_string dp in diff --git a/interp/dumpglob.mli b/interp/dumpglob.mli index 18955985a0..60d62a1cb2 100644 --- a/interp/dumpglob.mli +++ b/interp/dumpglob.mli @@ -32,6 +32,7 @@ val dump_definition : Names.lident -> bool -> string -> unit val dump_moddef : ?loc:Loc.t -> Names.ModPath.t -> string -> unit val dump_modref : ?loc:Loc.t -> Names.ModPath.t -> string -> unit val dump_reference : ?loc:Loc.t -> string -> string -> string -> unit +val dump_secvar : ?loc:Loc.t -> Names.Id.t -> unit val dump_libref : ?loc:Loc.t -> Names.DirPath.t -> string -> unit val dump_notation_location : (int * int) list -> Constrexpr.notation -> (Notation.notation_location * Notation_term.scope_name option) -> unit @@ -45,3 +46,6 @@ val dump_constraint : Names.lname -> bool -> string -> unit val dump_string : string -> unit val type_of_global_ref : Names.GlobRef.t -> string + +(** Registration of constant information *) +val add_constant_kind : Names.Constant.t -> Decls.logical_kind -> unit diff --git a/interp/impargs.ml b/interp/impargs.ml index 9977b29310..0466efa991 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -394,18 +394,18 @@ let compute_mib_implicits flags kn = (Array.mapi (* No need to lift, arities contain no de Bruijn *) (fun i mip -> (* No need to care about constraints here *) - let ty, _ = Typeops.type_of_global_in_context env (IndRef (kn,i)) in + let ty, _ = Typeops.type_of_global_in_context env (GlobRef.IndRef (kn,i)) in let r = Inductive.relevance_of_inductive env (kn,i) in Context.Rel.Declaration.LocalAssum (Context.make_annot (Name mip.mind_typename) r, ty)) mib.mind_packets) in let env_ar = Environ.push_rel_context ar env in let imps_one_inductive i mip = let ind = (kn,i) in - let ar, _ = Typeops.type_of_global_in_context env (IndRef ind) in - ((IndRef ind,compute_semi_auto_implicits env sigma flags (of_constr ar)), + let ar, _ = Typeops.type_of_global_in_context env (GlobRef.IndRef ind) in + ((GlobRef.IndRef ind,compute_semi_auto_implicits env sigma flags (of_constr ar)), Array.mapi (fun j (ctx, cty) -> let c = of_constr (Term.it_mkProd_or_LetIn cty ctx) in - (ConstructRef (ind,j+1),compute_semi_auto_implicits env_ar sigma flags c)) + (GlobRef.ConstructRef (ind,j+1),compute_semi_auto_implicits env_ar sigma flags c)) mip.mind_nf_lc) in Array.mapi imps_one_inductive mib.mind_packets @@ -424,7 +424,7 @@ let compute_var_implicits flags id = (* Implicits of a global reference. *) -let compute_global_implicits flags = function +let compute_global_implicits flags = let open GlobRef in function | VarRef id -> compute_var_implicits flags id | ConstRef kn -> compute_constant_implicits flags kn | IndRef (kn,i) -> @@ -579,11 +579,11 @@ let declare_implicits local ref = let declare_var_implicits id = let flags = !implicit_args in - declare_implicits_gen ImplLocal flags (VarRef id) + declare_implicits_gen ImplLocal flags (GlobRef.VarRef id) let declare_constant_implicits con = let flags = !implicit_args in - declare_implicits_gen (ImplConstant flags) flags (ConstRef con) + declare_implicits_gen (ImplConstant flags) flags (GlobRef.ConstRef con) let declare_mib_implicits kn = let flags = !implicit_args in diff --git a/interp/interp.mllib b/interp/interp.mllib index 33573edcce..cb6c527c83 100644 --- a/interp/interp.mllib +++ b/interp/interp.mllib @@ -10,6 +10,7 @@ Notation Syntax_def Smartlocate Constrexpr_ops +Decls Dumpglob Reserve Impargs diff --git a/interp/notation.ml b/interp/notation.ml index d58125e29b..d88182241b 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -57,7 +57,7 @@ let pr_notation (from,ntn) = qstring ntn ++ match from with InConstrEntrySomeLev module NotationOrd = struct type t = notation - let compare = Pervasives.compare + let compare = pervasives_compare end module NotationSet = Set.Make(NotationOrd) @@ -305,7 +305,7 @@ let glob_constr_keys c = match DAst.get c with | _ -> [Oth] let cases_pattern_key c = match DAst.get c with - | PatCstr (ref,_,_) -> RefKey (canonical_gr (ConstructRef ref)) + | PatCstr (ref,_,_) -> RefKey (canonical_gr (GlobRef.ConstructRef ref)) | _ -> Oth let notation_constr_key = function (* Rem: NApp(NRef ref,[]) stands for @ref *) @@ -492,10 +492,10 @@ exception NotAValidPrimToken considered for parsing. *) let rec constr_of_glob env sigma g = match DAst.get g with - | Glob_term.GRef (ConstructRef c, _) -> + | Glob_term.GRef (GlobRef.ConstructRef c, _) -> let sigma,c = Evd.fresh_constructor_instance env sigma c in sigma,mkConstructU c - | Glob_term.GRef (IndRef c, _) -> + | Glob_term.GRef (GlobRef.IndRef c, _) -> let sigma,c = Evd.fresh_inductive_instance env sigma c in sigma,mkIndU c | Glob_term.GApp (gc, gcl) -> @@ -511,10 +511,10 @@ let rec glob_of_constr token_kind ?loc env sigma c = match Constr.kind c with let c = glob_of_constr token_kind ?loc env sigma c in let cel = List.map (glob_of_constr token_kind ?loc env sigma) (Array.to_list ca) in DAst.make ?loc (Glob_term.GApp (c, cel)) - | Construct (c, _) -> DAst.make ?loc (Glob_term.GRef (ConstructRef c, None)) - | Const (c, _) -> DAst.make ?loc (Glob_term.GRef (ConstRef c, None)) - | Ind (ind, _) -> DAst.make ?loc (Glob_term.GRef (IndRef ind, None)) - | Var id -> DAst.make ?loc (Glob_term.GRef (VarRef id, None)) + | Construct (c, _) -> DAst.make ?loc (Glob_term.GRef (GlobRef.ConstructRef c, None)) + | Const (c, _) -> DAst.make ?loc (Glob_term.GRef (GlobRef.ConstRef c, None)) + | Ind (ind, _) -> DAst.make ?loc (Glob_term.GRef (GlobRef.IndRef ind, None)) + | Var id -> DAst.make ?loc (Glob_term.GRef (GlobRef.VarRef id, None)) | Int i -> DAst.make ?loc (Glob_term.GInt i) | _ -> Loc.raise ?loc (PrimTokenNotationError(token_kind,env,sigma,UnexpectedTerm c)) @@ -593,7 +593,7 @@ let rec rawnum_compare s s' = try for i = 0 to d-1 do if s.[i] != '0' then raise (Comp 1) done; for i = d to l-1 do - let c = Pervasives.compare s.[i] s'.[i-d] in + let c = pervasives_compare s.[i] s'.[i-d] in if c != 0 then raise (Comp c) done; 0 @@ -836,7 +836,7 @@ let q_byte () = qualid_of_ref "core.byte.type" let unsafe_locate_ind q = match Nametab.locate q with - | IndRef i -> i + | GlobRef.IndRef i -> i | _ -> raise Not_found let locate_list () = unsafe_locate_ind (q_list ()) @@ -1219,7 +1219,7 @@ let uninterp_cases_pattern_notations c = keymap_find (cases_pattern_key c) !notations_key_table let uninterp_ind_pattern_notations ind = - keymap_find (RefKey (canonical_gr (IndRef ind))) !notations_key_table + keymap_find (RefKey (canonical_gr (GlobRef.IndRef ind))) !notations_key_table let availability_of_notation (ntn_scope,ntn) scopes = let f scope = @@ -1242,7 +1242,7 @@ type entry_coercion = notation list module EntryCoercionOrd = struct type t = notation_entry * notation_entry - let compare = Pervasives.compare + let compare = pervasives_compare end module EntryCoercionMap = Map.Make(EntryCoercionOrd) diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index fdf12faa04..2fa78bb9f3 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -781,7 +781,7 @@ let rec pat_binder_of_term t = DAst.map (function | GVar id -> PatVar (Name id) | GApp (t, l) -> begin match DAst.get t with - | GRef (ConstructRef cstr,_) -> + | GRef (GlobRef.ConstructRef cstr,_) -> let nparams = Inductiveops.inductive_nparams (Global.env()) (fst cstr) in let _,l = List.chop nparams l in PatCstr (cstr, List.map pat_binder_of_term l, Anonymous) @@ -1337,10 +1337,10 @@ let rec match_cases_pattern metas (terms,termlists,(),() as sigma) a1 a2 = match DAst.get a1, a2 with | r1, NVar id2 when Id.List.mem_assoc id2 metas -> (bind_env_cases_pattern sigma id2 a1),(0,[]) | PatVar Anonymous, NHole _ -> sigma,(0,[]) - | PatCstr ((ind,_ as r1),largs,Anonymous), NRef (ConstructRef r2) when eq_constructor r1 r2 -> + | PatCstr ((ind,_ as r1),largs,Anonymous), NRef (GlobRef.ConstructRef r2) when eq_constructor r1 r2 -> let l = try add_patterns_for_params_remove_local_defs (Global.env ()) r1 largs with Not_found -> raise No_match in sigma,(0,l) - | PatCstr ((ind,_ as r1),args1,Anonymous), NApp (NRef (ConstructRef r2),l2) + | PatCstr ((ind,_ as r1),args1,Anonymous), NApp (NRef (GlobRef.ConstructRef r2),l2) when eq_constructor r1 r2 -> let l1 = try add_patterns_for_params_remove_local_defs (Global.env()) r1 args1 with Not_found -> raise No_match in let le2 = List.length l2 in @@ -1362,9 +1362,9 @@ and match_cases_pattern_no_more_args metas sigma a1 a2 = let match_ind_pattern metas sigma ind pats a2 = match a2 with - | NRef (IndRef r2) when eq_ind ind r2 -> + | NRef (GlobRef.IndRef r2) when eq_ind ind r2 -> sigma,(0,pats) - | NApp (NRef (IndRef r2),l2) + | NApp (NRef (GlobRef.IndRef r2),l2) when eq_ind ind r2 -> let le2 = List.length l2 in if Int.equal le2 0 (* Special case of a notation for a @Cstr *) || le2 > List.length pats diff --git a/interp/smartlocate.ml b/interp/smartlocate.ml index 74fe5d1c80..5d36ceca38 100644 --- a/interp/smartlocate.ml +++ b/interp/smartlocate.ml @@ -52,7 +52,7 @@ let locate_global_with_alias ?(head=false) qid = let global_inductive_with_alias qid = try match locate_global_with_alias qid with - | IndRef ind -> ind + | Names.GlobRef.IndRef ind -> ind | ref -> user_err ?loc:qid.CAst.loc ~hdr:"global_inductive" (pr_qualid qid ++ spc () ++ str "is not an inductive type.") diff --git a/kernel/entries.ml b/kernel/entries.ml index bc389e9fcf..47e2f72b0e 100644 --- a/kernel/entries.ml +++ b/kernel/entries.ml @@ -99,11 +99,14 @@ type primitive_entry = { type 'a proof_output = constr Univ.in_universe_context_set * 'a type 'a const_entry_body = 'a proof_output Future.computation -type 'a constant_entry = - | DefinitionEntry of definition_entry - | OpaqueEntry of 'a const_entry_body opaque_entry - | ParameterEntry of parameter_entry - | PrimitiveEntry of primitive_entry +(** Dummy wrapper type discriminable from unit *) +type 'a seff_wrap = { seff_wrap : 'a } + +type _ constant_entry = + | DefinitionEntry : definition_entry -> unit constant_entry + | OpaqueEntry : 'a const_entry_body opaque_entry -> 'a seff_wrap constant_entry + | ParameterEntry : parameter_entry -> unit constant_entry + | PrimitiveEntry : primitive_entry -> unit constant_entry (** {6 Modules } *) diff --git a/kernel/environ.ml b/kernel/environ.ml index 32f9069747..9a75f0b682 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -95,6 +95,7 @@ type env = { env_typing_flags : typing_flags; retroknowledge : Retroknowledge.retroknowledge; indirect_pterms : Opaqueproof.opaquetab; + native_symbols : Nativevalues.symbols DPmap.t; } let empty_named_context_val = { @@ -123,7 +124,9 @@ let empty_env = { }; env_typing_flags = Declareops.safe_flags Conv_oracle.empty; retroknowledge = Retroknowledge.empty; - indirect_pterms = Opaqueproof.empty_opaquetab } + indirect_pterms = Opaqueproof.empty_opaquetab; + native_symbols = DPmap.empty; +} (* Rel context *) @@ -763,3 +766,7 @@ let is_type_in_type env r = | ConstructRef cstr -> type_in_type_ind (inductive_of_constructor cstr) env let set_retroknowledge env r = { env with retroknowledge = r } + +let set_native_symbols env native_symbols = { env with native_symbols } +let add_native_symbols dir syms env = + { env with native_symbols = DPmap.add dir syms env.native_symbols } diff --git a/kernel/environ.mli b/kernel/environ.mli index a4cd576bcc..6cd4f96645 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -74,6 +74,7 @@ type env = private { env_typing_flags : typing_flags; retroknowledge : Retroknowledge.retroknowledge; indirect_pterms : Opaqueproof.opaquetab; + native_symbols : Nativevalues.symbols DPmap.t; } val oracle : env -> Conv_oracle.oracle @@ -351,3 +352,6 @@ val no_link_info : link_info (** Primitives *) val set_retroknowledge : env -> Retroknowledge.retroknowledge -> env + +val set_native_symbols : env -> Nativevalues.symbols DPmap.t -> env +val add_native_symbols : DirPath.t -> Nativevalues.symbols -> env -> env diff --git a/kernel/names.ml b/kernel/names.ml index 85dc8267bb..9802d4f531 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -356,6 +356,9 @@ module ModPath = struct end +module DPset = Set.Make(DirPath) +module DPmap = Map.Make(DirPath) + module MPset = Set.Make(ModPath) module MPmap = CMap.Make(ModPath) diff --git a/kernel/names.mli b/kernel/names.mli index 65c5d6c139..78eb9295d4 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -161,6 +161,9 @@ sig val print : t -> Pp.t end +module DPset : Set.S with type elt = DirPath.t +module DPmap : Map.ExtS with type key = DirPath.t and module Set := DPset + (** {6 Names of structure elements } *) module Label : diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index fc9e69d9e3..1a5455cf3a 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -141,23 +141,11 @@ let fresh_gnormtbl l = (** Symbols (pre-computed values) **) -type symbol = - | SymbValue of Nativevalues.t - | SymbSort of Sorts.t - | SymbName of Name.t - | SymbConst of Constant.t - | SymbMatch of annot_sw - | SymbInd of inductive - | SymbMeta of metavariable - | SymbEvar of Evar.t - | SymbLevel of Univ.Level.t - | SymbProj of (inductive * int) - let dummy_symb = SymbValue (dummy_value ()) let eq_symbol sy1 sy2 = match sy1, sy2 with - | SymbValue v1, SymbValue v2 -> Pervasives.(=) v1 v2 (** FIXME: how is this even valid? *) + | SymbValue v1, SymbValue v2 -> (=) v1 v2 (** FIXME: how is this even valid? *) | SymbSort s1, SymbSort s2 -> Sorts.equal s1 s2 | SymbName n1, SymbName n2 -> Name.equal n1 n2 | SymbConst kn1, SymbConst kn2 -> Constant.equal kn1 kn2 @@ -194,10 +182,6 @@ let symb_tbl = HashtblSymbol.create 211 let clear_symbols () = HashtblSymbol.clear symb_tbl -type symbols = symbol array - -let empty_symbols = [||] - let get_value tbl i = match tbl.(i) with | SymbValue v -> v diff --git a/kernel/nativecode.mli b/kernel/nativecode.mli index 955c4ad899..ed395368b2 100644 --- a/kernel/nativecode.mli +++ b/kernel/nativecode.mli @@ -12,6 +12,7 @@ open Constr open Declarations open Environ open Nativelambda +open Nativevalues (** This file defines the mllambda code generation phase of the native compiler. mllambda represents a fragment of ML, and can easily be printed @@ -25,11 +26,6 @@ val pp_global : Format.formatter -> global -> unit val mk_open : string -> global (* Precomputed values for a compilation unit *) -type symbol -type symbols - -val empty_symbols : symbols - val clear_symbols : unit -> unit val get_value : symbols -> int -> Nativevalues.t diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml index a98523ba66..dd010e5cad 100644 --- a/kernel/nativeconv.ml +++ b/kernel/nativeconv.ml @@ -154,7 +154,7 @@ let native_conv_gen pb sigma env univs t1 t2 = let fn = compile ml_filename code ~profile:false in if !Flags.debug then Feedback.msg_debug (Pp.str "Running test..."); let t0 = Sys.time () in - call_linker ~fatal:true prefix fn (Some upds); + call_linker env ~fatal:true ~prefix fn (Some upds); let t1 = Sys.time () in let time_info = Format.sprintf "Evaluation done in %.5f@." (t1 -. t0) in if !Flags.debug then Feedback.msg_debug (Pp.str time_info); diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml index 94a8b1310a..1cef729916 100644 --- a/kernel/nativelib.ml +++ b/kernel/nativelib.ml @@ -21,8 +21,7 @@ let get_load_paths = let open_header = ["Nativevalues"; "Nativecode"; "Nativelib"; - "Nativeconv"; - "Declaremods"] + "Nativeconv"] let open_header = List.map mk_open open_header (* Directory where compiled files are stored *) @@ -129,9 +128,19 @@ let compile_library dir code fn = let _ = call_compiler fn in if (not !Flags.debug) && Sys.file_exists fn then Sys.remove fn +let native_symbols = ref Names.DPmap.empty + +let get_library_native_symbols dir = + try Names.DPmap.find dir !native_symbols + with Not_found -> + CErrors.user_err ~hdr:"get_library_native_symbols" + Pp.((str "Linker error in the native compiler. Are you using Require inside a nested Module declaration?") ++ fnl () ++ + (str "This use case is not supported, but disabling the native compiler may help.")) + (* call_linker links dynamically the code for constants in environment or a *) (* conversion test. *) -let call_linker ?(fatal=true) prefix f upds = +let call_linker ?(fatal=true) env ~prefix f upds = + native_symbols := env.Environ.native_symbols; rt1 := dummy_value (); rt2 := dummy_value (); if not (Sys.file_exists f) then @@ -150,6 +159,6 @@ let call_linker ?(fatal=true) prefix f upds = else if !Flags.debug then Feedback.msg_debug CErrors.(iprint exn)); match upds with Some upds -> update_locations upds | _ -> () -let link_library ~prefix ~dirname ~basename = +let link_library env ~prefix ~dirname ~basename = let f = dirname / output_dir / basename in - call_linker ~fatal:false prefix f None + call_linker env ~fatal:false ~prefix f None diff --git a/kernel/nativelib.mli b/kernel/nativelib.mli index 194efecd9a..52d18acca6 100644 --- a/kernel/nativelib.mli +++ b/kernel/nativelib.mli @@ -30,10 +30,23 @@ val compile : string -> global list -> profile:bool -> string but will perform some extra tweaks to handle [code] as a Coq lib. *) val compile_library : Names.DirPath.t -> global list -> string -> unit -val call_linker : - ?fatal:bool -> string -> string -> code_location_updates option -> unit - -val link_library : prefix:string -> dirname:string -> basename:string -> unit +val call_linker + : ?fatal:bool + -> Environ.env + -> prefix:string + -> string + -> code_location_updates option + -> unit + +val link_library + : Environ.env + -> prefix:string + -> dirname:string + -> basename:string + -> unit val rt1 : Nativevalues.t ref val rt2 : Nativevalues.t ref + +val get_library_native_symbols : Names.DirPath.t -> Nativevalues.symbols +(** Strictly for usage by code produced by native compute. *) diff --git a/kernel/nativelibrary.mli b/kernel/nativelibrary.mli index 168bf646af..c53a626528 100644 --- a/kernel/nativelibrary.mli +++ b/kernel/nativelibrary.mli @@ -16,4 +16,4 @@ open Nativecode compiler *) val dump_library : ModPath.t -> DirPath.t -> env -> module_signature -> - global list * symbols + global list * Nativevalues.symbols diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml index b3ad3949dc..e54118c775 100644 --- a/kernel/nativevalues.ml +++ b/kernel/nativevalues.ml @@ -66,6 +66,23 @@ type atom = | Aevar of Evar.t * t array | Aproj of (inductive * int) * accumulator +type symbol = + | SymbValue of t + | SymbSort of Sorts.t + | SymbName of Name.t + | SymbConst of Constant.t + | SymbMatch of annot_sw + | SymbInd of inductive + | SymbMeta of metavariable + | SymbEvar of Evar.t + | SymbLevel of Univ.Level.t + | SymbProj of (inductive * int) + +type symbols = symbol array + +let empty_symbols = [| |] + + let accumulate_tag = 0 (** Unique pointer used to drive the accumulator function *) diff --git a/kernel/nativevalues.mli b/kernel/nativevalues.mli index b5b4569a24..b54f437e73 100644 --- a/kernel/nativevalues.mli +++ b/kernel/nativevalues.mli @@ -56,6 +56,22 @@ type atom = | Aevar of Evar.t * t array (* arguments *) | Aproj of (inductive * int) * accumulator +type symbol = + | SymbValue of t + | SymbSort of Sorts.t + | SymbName of Name.t + | SymbConst of Constant.t + | SymbMatch of annot_sw + | SymbInd of inductive + | SymbMeta of metavariable + | SymbEvar of Evar.t + | SymbLevel of Univ.Level.t + | SymbProj of (inductive * int) + +type symbols = symbol array + +val empty_symbols : symbols + (* Constructors *) val mk_accu : atom -> t diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 2c434d4edf..ea45f699ce 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -113,8 +113,6 @@ type library_info = DirPath.t * vodigest (** Functor and funsig parameters, most recent first *) type module_parameters = (MBId.t * module_type_body) list -module DPMap = Map.Make(DirPath) - type safe_environment = { env : Environ.env; modpath : ModPath.t; @@ -127,10 +125,10 @@ type safe_environment = univ : Univ.ContextSet.t; future_cst : Univ.ContextSet.t Future.computation list; engagement : engagement option; - required : vodigest DPMap.t; + required : vodigest DPmap.t; loads : (ModPath.t * module_body) list; local_retroknowledge : Retroknowledge.action list; - native_symbols : Nativecode.symbols DPMap.t } +} and modvariant = | NONE @@ -156,10 +154,10 @@ let empty_environment = future_cst = []; univ = Univ.ContextSet.empty; engagement = None; - required = DPMap.empty; + required = DPmap.empty; loads = []; local_retroknowledge = []; - native_symbols = DPMap.empty } +} let is_initial senv = match senv.revstruct, senv.modvariant with @@ -396,7 +394,7 @@ let check_initial senv = assert (is_initial senv) let check_required current_libs needed = let check (id,required) = try - let actual = DPMap.find id current_libs in + let actual = DPmap.find id current_libs in if not(digest_match ~actual ~required) then CErrors.user_err Pp.(pr_sequence str ["Inconsistent assumptions over module"; DirPath.to_string id; "."]) @@ -430,12 +428,11 @@ let push_named_def (id,de) senv = let env'' = safe_push_named (LocalDef (x, c, typ)) senv.env in { senv with env = env'' } -let push_named_assum ((id,t,poly),ctx) senv = - let senv' = push_context_set poly ctx senv in - let t, r = Term_typing.translate_local_assum senv'.env t in - let x = Context.make_annot id r in - let env'' = safe_push_named (LocalAssum (x,t)) senv'.env in - {senv' with env=env''} +let push_named_assum (x,t) senv = + let t, r = Term_typing.translate_local_assum senv.env t in + let x = Context.make_annot x r in + let env'' = safe_push_named (LocalAssum (x,t)) senv.env in + {senv with env=env''} (** {6 Insertion of new declarations to current environment } *) @@ -530,7 +527,7 @@ let update_resolver f senv = { senv with modresolver = f senv.modresolver } (** Insertion of constants and parameters in environment *) type 'a effect_entry = -| EffectEntry : private_constants effect_entry +| EffectEntry : private_constants Entries.seff_wrap effect_entry | PureEntry : unit effect_entry type global_declaration = @@ -672,6 +669,9 @@ let check_signatures curmb sl = | None -> 0 | Some (n, _) -> n +type side_effect_declaration = +| DefinitionEff : Entries.definition_entry -> side_effect_declaration +| OpaqueEff : unit Entries.const_entry_body Entries.opaque_entry -> side_effect_declaration let constant_entry_of_side_effect eff = let cb = eff.seff_body in @@ -689,7 +689,7 @@ let constant_entry_of_side_effect eff = | Def b -> Mod_subst.force_constr b | _ -> assert false in if Declareops.is_opaque cb then - OpaqueEntry { + OpaqueEff { opaque_entry_body = Future.from_val ((p, Univ.ContextSet.empty), ()); opaque_entry_secctx = cb.const_hyps; opaque_entry_feedback = None; @@ -697,7 +697,7 @@ let constant_entry_of_side_effect eff = opaque_entry_universes = univs; } else - DefinitionEntry { + DefinitionEff { const_entry_body = p; const_entry_secctx = Some cb.const_hyps; const_entry_feedback = None; @@ -733,7 +733,15 @@ let export_side_effects mb env (b_ctx, eff) = let env, cb = let kn = eff.seff_constant in let ce = constant_entry_of_side_effect eff in - let cb = Term_typing.translate_constant Term_typing.Pure env kn ce in + let open Entries in + let open Term_typing in + let cb = match ce with + | DefinitionEff ce -> + Term_typing.translate_constant Pure env kn (DefinitionEntry ce) + | OpaqueEff ce -> + let handle _env c () = (c, Univ.ContextSet.empty, 0) in + Term_typing.translate_constant (SideEffects handle) env kn (OpaqueEntry ce) + in let map cu = let (c, u) = Future.force cu in let () = match u with @@ -825,7 +833,7 @@ let add_constant (type a) ~(side_effect : a effect_entry) ~in_section l decl sen seff_constant = kn; seff_body = cb; } in - SideEffects.add eff empty_private_constants + { Entries.seff_wrap = SideEffects.add eff empty_private_constants } in (kn, eff), senv @@ -987,8 +995,8 @@ let propagate_senv newdef newenv newresolver senv oldsenv = required = senv.required; loads = senv.loads@oldsenv.loads; local_retroknowledge = - senv.local_retroknowledge@oldsenv.local_retroknowledge; - native_symbols = senv.native_symbols} + senv.local_retroknowledge@oldsenv.local_retroknowledge; + } let end_module l restype senv = let mp = senv.modpath in @@ -998,6 +1006,7 @@ let end_module l restype senv = let mbids = List.rev_map fst params in let mb = build_module_body params restype senv in let newenv = Environ.set_opaque_tables oldsenv.env (Environ.opaque_tables senv.env) in + let newenv = Environ.set_native_symbols newenv senv.env.Environ.native_symbols in let newenv = set_engagement_opt newenv senv.engagement in let senv'= propagate_loads { senv with @@ -1028,6 +1037,7 @@ let end_modtype l senv = let () = check_empty_context senv in let mbids = List.rev_map fst params in let newenv = Environ.set_opaque_tables oldsenv.env (Environ.opaque_tables senv.env) in + let newenv = Environ.set_native_symbols newenv senv.env.Environ.native_symbols in let newenv = Environ.push_context_set ~strict:true senv.univ newenv in let newenv = set_engagement_opt newenv senv.engagement in let senv' = propagate_loads {senv with env=newenv} in @@ -1091,19 +1101,13 @@ type compiled_library = { comp_mod : module_body; comp_deps : library_info array; comp_enga : engagement; - comp_natsymbs : Nativecode.symbols + comp_natsymbs : Nativevalues.symbols } let module_of_library lib = lib.comp_mod type native_library = Nativecode.global list -let get_library_native_symbols senv dir = - try DPMap.find dir senv.native_symbols - with Not_found -> CErrors.user_err ~hdr:"get_library_native_symbols" - Pp.((str "Linker error in the native compiler. Are you using Require inside a nested Module declaration?") ++ fnl () ++ - (str "This use case is not supported, but disabling the native compiler may help.")) - (** FIXME: MS: remove?*) let current_modpath senv = senv.modpath let current_dirpath senv = Names.ModPath.dp (current_modpath senv) @@ -1143,12 +1147,12 @@ let export ?except ~output_native_objects senv dir = let ast, symbols = if output_native_objects then Nativelibrary.dump_library mp dir senv.env str - else [], Nativecode.empty_symbols + else [], Nativevalues.empty_symbols in let lib = { comp_name = dir; comp_mod = mb; - comp_deps = Array.of_list (DPMap.bindings senv.required); + comp_deps = Array.of_list (DPmap.bindings senv.required); comp_enga = Environ.engagement senv.env; comp_natsymbs = symbols } in @@ -1168,17 +1172,18 @@ let import lib cst vodigest senv = (Univ.ContextSet.union mb.mod_constraints cst) senv.env in + let env = + let linkinfo = Nativecode.link_info_of_dirpath lib.comp_name in + Modops.add_linked_module mb linkinfo env + in + let env = Environ.add_native_symbols lib.comp_name lib.comp_natsymbs env in mp, { senv with - env = - (let linkinfo = - Nativecode.link_info_of_dirpath lib.comp_name - in - Modops.add_linked_module mb linkinfo env); + env; modresolver = Mod_subst.add_delta_resolver mb.mod_delta senv.modresolver; - required = DPMap.add lib.comp_name vodigest senv.required; + required = DPmap.add lib.comp_name vodigest senv.required; loads = (mp,mb)::senv.loads; - native_symbols = DPMap.add lib.comp_name lib.comp_natsymbs senv.native_symbols } + } (** {6 Safe typing } *) diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 885becc40a..2406b6add1 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -69,9 +69,7 @@ val is_joined_environment : safe_environment -> bool (** Insertion of local declarations (Local or Variables) *) -val push_named_assum : - (Id.t * Constr.types * bool (* polymorphic *)) - Univ.in_universe_context_set -> safe_transformer0 +val push_named_assum : (Id.t * Constr.types) -> safe_transformer0 (** Returns the full universe context necessary to typecheck the definition (futures are forced) *) @@ -81,7 +79,7 @@ val push_named_def : (** Insertion of global axioms or definitions *) type 'a effect_entry = -| EffectEntry : private_constants effect_entry +| EffectEntry : private_constants Entries.seff_wrap effect_entry | PureEntry : unit effect_entry type global_declaration = @@ -177,8 +175,6 @@ type native_library = Nativecode.global list val module_of_library : compiled_library -> Declarations.module_body -val get_library_native_symbols : safe_environment -> DirPath.t -> Nativecode.symbols - val start_library : DirPath.t -> ModPath.t safe_transformer val export : diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 5844bd89f8..b65e62ba30 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -31,7 +31,7 @@ type 'a effect_handler = type _ trust = | Pure : unit trust -| SideEffects : 'a effect_handler -> 'a trust +| SideEffects : 'a effect_handler -> 'a Entries.seff_wrap trust let skip_trusted_seff sl b e = let rec aux sl b e acc = @@ -124,22 +124,14 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = Future.chain body begin fun ((body,uctx),side_eff) -> (* don't redeclare universes which are declared for the type *) let uctx = Univ.ContextSet.diff uctx univs in - let j, uctx = match trust with - | Pure -> - let env = push_context_set uctx env in - let j = Typeops.infer env body in - let _ = Typeops.judge_of_cast env j DEFAULTcast tyj in - j, uctx - | SideEffects handle -> - let (body, uctx', valid_signatures) = handle env body side_eff in - let uctx = Univ.ContextSet.union uctx uctx' in - let env = push_context_set uctx env in - let body,env,ectx = skip_trusted_seff valid_signatures body env in - let j = Typeops.infer env body in - let j = unzip ectx j in - let _ = Typeops.judge_of_cast env j DEFAULTcast tyj in - j, uctx - in + let SideEffects handle = trust in + let (body, uctx', valid_signatures) = handle env body side_eff in + let uctx = Univ.ContextSet.union uctx uctx' in + let env = push_context_set uctx env in + let body,env,ectx = skip_trusted_seff valid_signatures body env in + let j = Typeops.infer env body in + let j = unzip ectx j in + let _ = Typeops.judge_of_cast env j DEFAULTcast tyj in let c = j.uj_val in feedback_completion_typecheck feedback_id; c, Opaqueproof.PrivateMonomorphic uctx @@ -164,12 +156,9 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = let sbst, auctx = Univ.abstract_universes nas uctx in let usubst = Univ.make_instance_subst sbst in let proofterm = Future.chain body begin fun ((body, ctx), side_eff) -> - let body, ctx = match trust with - | Pure -> body, ctx - | SideEffects handle -> - let body, ctx', _ = handle env body side_eff in - body, Univ.ContextSet.union ctx ctx' - in + let SideEffects handle = trust in + let body, ctx', _ = handle env body side_eff in + let ctx = Univ.ContextSet.union ctx ctx' in (** [ctx] must contain local universes, such that it has no impact on the rest of the graph (up to transitivity). *) let env = push_subgraph ctx env in @@ -195,10 +184,7 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = | DefinitionEntry c -> let { const_entry_type = typ; _ } = c in let { const_entry_body = body; const_entry_feedback = feedback_id; _ } = c in - let () = match trust with - | Pure -> () - | SideEffects _ -> assert false - in + let Pure = trust in let env, usubst, univs = match c.const_entry_universes with | Monomorphic_entry ctx -> let env = push_context_set ~strict:true ctx env in diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli index 225abd60f8..ef01ece185 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -24,7 +24,7 @@ type 'a effect_handler = type _ trust = | Pure : unit trust -| SideEffects : 'a effect_handler -> 'a trust +| SideEffects : 'a effect_handler -> 'a Entries.seff_wrap trust val translate_local_def : env -> Id.t -> section_def_entry -> constr * Sorts.relevance * types diff --git a/lib/cErrors.ml b/lib/cErrors.ml index a42504701f..b9735d0579 100644 --- a/lib/cErrors.ml +++ b/lib/cErrors.ml @@ -25,52 +25,15 @@ let _ = in Printexc.register_printer pr -let make_anomaly ?label pp = - Anomaly (label, pp) - let anomaly ?loc ?label pp = Loc.raise ?loc (Anomaly (label, pp)) exception UserError of string option * Pp.t (* User errors *) -let todo s = prerr_string ("TODO: "^s^"\n") - let user_err ?loc ?hdr strm = Loc.raise ?loc (UserError (hdr, strm)) -let invalid_arg ?loc s = Loc.raise ?loc (Invalid_argument s) - -exception AlreadyDeclared of Pp.t (* for already declared Schemes *) -let alreadydeclared pps = raise (AlreadyDeclared(pps)) - exception Timeout -let handle_stack = ref [] - -exception Unhandled - -let register_handler h = handle_stack := h::!handle_stack - -let is_handled e = - let is_handled_by h = (try let _ = h e in true with | Unhandled -> false) in - List.exists is_handled_by !handle_stack - -let is_anomaly = function -| Anomaly _ -> true -| exn -> not (is_handled exn) - -(** [print_gen] is a general exception printer which tries successively - all the handlers of a list, and finally a [bottom] handler if all - others have failed *) - -let rec print_gen bottom stk e = - match stk with - | [] -> bottom e - | h::stk' -> - try h e - with - | Unhandled -> print_gen bottom stk' e - | any -> print_gen bottom stk' any - (** Only anomalies should reach the bottom of the handler stack. In usual situation, the [handle_stack] is treated as it if was always non-empty with [print_anomaly] as its bottom handler. *) @@ -103,17 +66,67 @@ let print_anomaly askreport e = else hov 0 (raw_anomaly e) +let handle_stack = ref [] + +exception Unhandled + +let register_handler h = handle_stack := h::!handle_stack + +let is_handled e = + let is_handled_by h = (try let _ = h e in true with | Unhandled -> false) in + List.exists is_handled_by !handle_stack + +let is_anomaly = function +| Anomaly _ -> true +| exn -> not (is_handled exn) + +(** Printing of additional error info, from Exninfo *) +let additional_error_info_handler = ref [] + +let register_additional_error_info (f : Exninfo.info -> (Pp.t option Loc.located) option) = + additional_error_info_handler := f :: !additional_error_info_handler + +(** [print_gen] is a general exception printer which tries successively + all the handlers of a list, and finally a [bottom] handler if all + others have failed *) + +let rec print_gen ~anomaly ~extra_msg stk (e, info) = + match stk with + | [] -> + print_anomaly anomaly e + | h::stk' -> + try + let err_msg = h e in + Option.cata (fun msg -> msg ++ err_msg) err_msg extra_msg + with + | Unhandled -> print_gen ~anomaly ~extra_msg stk' (e,info) + | any -> print_gen ~anomaly ~extra_msg stk' (any,info) + +let print_gen ~anomaly (e, info) = + let extra_info = + try CList.find_map (fun f -> Some (f info)) !additional_error_info_handler + with Not_found -> None + in + let extra_msg, info = match extra_info with + | None -> None, info + | Some (loc, msg) -> + let info = Option.cata (fun l -> Loc.add_loc info l) info loc in + msg, info + in + print_gen ~anomaly ~extra_msg !handle_stack (e,info) + (** The standard exception printer *) -let print ?(info = Exninfo.null) e = - print_gen (print_anomaly true) !handle_stack e ++ print_backtrace info +let iprint (e, info) = + print_gen ~anomaly:true (e,info) ++ print_backtrace info -let iprint (e, info) = print ~info e +let print e = + iprint (e, Exninfo.info e) (** Same as [print], except that the "Please report" part of an anomaly isn't printed (used in Ltac debugging). *) -let print_no_report e = print_gen (print_anomaly false) !handle_stack e let iprint_no_report (e, info) = - print_gen (print_anomaly false) !handle_stack e ++ print_backtrace info + print_gen ~anomaly:false (e,info) ++ print_backtrace info +let print_no_report e = iprint_no_report (e, Exninfo.info e) (** Predefined handlers **) diff --git a/lib/cErrors.mli b/lib/cErrors.mli index 51ec5c907a..02eaf6bd0b 100644 --- a/lib/cErrors.mli +++ b/lib/cErrors.mli @@ -21,9 +21,6 @@ val push : exn -> Exninfo.iexn [Anomaly] is used for system errors and [UserError] for the user's ones. *) -val make_anomaly : ?label:string -> Pp.t -> exn -(** Create an anomaly. *) - val anomaly : ?loc:Loc.t -> ?label:string -> Pp.t -> 'a (** Raise an anomaly, with an optional location and an optional label identifying the anomaly. *) @@ -41,17 +38,6 @@ val user_err : ?loc:Loc.t -> ?hdr:string -> Pp.t -> 'a (** Main error raising primitive. [user_err ?loc ?hdr pp] signals an error [pp] with optional header and location [hdr] [loc] *) -exception AlreadyDeclared of Pp.t -val alreadydeclared : Pp.t -> 'a - -val invalid_arg : ?loc:Loc.t -> string -> 'a - -(** [todo] is for running of an incomplete code its implementation is - "do nothing" (or print a message), but this function should not be - used in a released code *) - -val todo : string -> unit - exception Timeout (** [register_handler h] registers [h] as a handler. @@ -75,7 +61,7 @@ exception Unhandled val register_handler : (exn -> Pp.t) -> unit (** The standard exception printer *) -val print : ?info:Exninfo.info -> exn -> Pp.t +val print : exn -> Pp.t val iprint : Exninfo.iexn -> Pp.t (** Same as [print], except that the "Please report" part of an anomaly @@ -89,3 +75,10 @@ val iprint_no_report : Exninfo.iexn -> Pp.t Typical example: [Sys.Break], [Assert_failure], [Anomaly] ... *) val noncritical : exn -> bool + +(** Register a printer for errors carrying additional information on + exceptions. This method is fragile and should be considered + deprecated *) +val register_additional_error_info + : (Exninfo.info -> (Pp.t option Loc.located) option) + -> unit diff --git a/lib/future.ml b/lib/future.ml index f6e9cee140..01fb7d0297 100644 --- a/lib/future.ml +++ b/lib/future.ml @@ -68,7 +68,7 @@ and 'a computation = 'a comput ref let unnamed = "unnamed" let create ?(name=unnamed) ?(uuid=UUID.fresh ()) f x = - ref (Ongoing (name, CEphemeron.create (uuid, f, Pervasives.ref x))) + ref (Ongoing (name, CEphemeron.create (uuid, f, ref x))) let get x = match !x with | Finished v -> unnamed, UUID.invalid, id, ref (Val v) @@ -197,9 +197,9 @@ let pp_with ft pp = | Ppcmd_print_break(m,n) -> pp_print_break ft m n | Ppcmd_force_newline -> pp_force_newline ft () | Ppcmd_comment coms -> List.iter (pr_com ft) coms - | Ppcmd_tag(tag, s) -> pp_open_tag ft tag; + | Ppcmd_tag(tag, s) -> pp_open_tag ft tag [@warning "-3"]; pp_cmd s; - pp_close_tag ft () + pp_close_tag ft () [@warning "-3"] in try pp_cmd pp with reraise -> diff --git a/lib/util.ml b/lib/util.ml index bac06b5701..61678f7669 100644 --- a/lib/util.ml +++ b/lib/util.ml @@ -8,6 +8,13 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +type 'a pervasives_ref = 'a ref +let pervasives_ref = ref +let pervasives_compare = compare +let (!) = (!) +let (+) = (+) +let (-) = (-) + (* Mapping under pairs *) let on_fst f (a,b) = (f a,b) diff --git a/lib/util.mli b/lib/util.mli index 8ccb4b3f08..b6347126e0 100644 --- a/lib/util.mli +++ b/lib/util.mli @@ -8,6 +8,13 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +type 'a pervasives_ref = 'a ref +val pervasives_ref : 'a -> 'a ref +val pervasives_compare : 'a -> 'a -> int +val (!) : 'a ref -> 'a +val (+) : int -> int -> int +val (-) : int -> int -> int + (** This module contains numerous utility functions on strings, lists, arrays, etc. *) diff --git a/library/coqlib.ml b/library/coqlib.ml index 7cd2e50274..b1e4ef2b00 100644 --- a/library/coqlib.ml +++ b/library/coqlib.ml @@ -13,7 +13,6 @@ open Util open Pp open Names open Libnames -open Globnames let make_dir l = DirPath.make (List.rev_map Id.of_string l) @@ -46,7 +45,7 @@ let has_ref s = CString.Map.mem s !table let check_ind_ref s ind = match CString.Map.find s !table with - | IndRef r -> eq_ind r ind + | GlobRef.IndRef r -> eq_ind r ind | _ -> false | exception Not_found -> false @@ -157,32 +156,32 @@ let type_of_id = Constant.make2 datatypes_module @@ Label.make "IDProp" let nat_kn = MutInd.make2 datatypes_module @@ Label.make "nat" let nat_path = Libnames.make_path (make_dir datatypes_module_name) (Id.of_string "nat") -let glob_nat = IndRef (nat_kn,0) +let glob_nat = GlobRef.IndRef (nat_kn,0) let path_of_O = ((nat_kn,0),1) let path_of_S = ((nat_kn,0),2) -let glob_O = ConstructRef path_of_O -let glob_S = ConstructRef path_of_S +let glob_O = GlobRef.ConstructRef path_of_O +let glob_S = GlobRef.ConstructRef path_of_S (** Booleans *) let bool_kn = MutInd.make2 datatypes_module @@ Label.make "bool" -let glob_bool = IndRef (bool_kn,0) +let glob_bool = GlobRef.IndRef (bool_kn,0) let path_of_true = ((bool_kn,0),1) let path_of_false = ((bool_kn,0),2) -let glob_true = ConstructRef path_of_true -let glob_false = ConstructRef path_of_false +let glob_true = GlobRef.ConstructRef path_of_true +let glob_false = GlobRef.ConstructRef path_of_false (** Equality *) let eq_kn = MutInd.make2 logic_module @@ Label.make "eq" -let glob_eq = IndRef (eq_kn,0) +let glob_eq = GlobRef.IndRef (eq_kn,0) let identity_kn = MutInd.make2 datatypes_module @@ Label.make "identity" -let glob_identity = IndRef (identity_kn,0) +let glob_identity = GlobRef.IndRef (identity_kn,0) let jmeq_kn = MutInd.make2 jmeq_module @@ Label.make "JMeq" -let glob_jmeq = IndRef (jmeq_kn,0) +let glob_jmeq = GlobRef.IndRef (jmeq_kn,0) (* Sigma data *) type coq_sigma_data = { diff --git a/library/decl_kinds.ml b/library/decl_kinds.ml index 6eb582baef..17746645ee 100644 --- a/library/decl_kinds.ml +++ b/library/decl_kinds.ml @@ -8,58 +8,4 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(** Informal mathematical status of declarations *) - type binding_kind = Explicit | Implicit - -type private_flag = bool - -type cumulative_inductive_flag = bool - -type theorem_kind = - | Theorem - | Lemma - | Fact - | Remark - | Property - | Proposition - | Corollary - -type definition_object_kind = - | Definition - | Coercion - | SubClass - | CanonicalStructure - | Example - | Fixpoint - | CoFixpoint - | Scheme - | StructureComponent - | IdentityCoercion - | Instance - | Method - | Let - -type assumption_object_kind = Definitional | Logical | Conjectural | Context - -(* [assumption_kind] - - | Local | Global - ------------------------------------ - Definitional | Variable | Parameter - Logical | Hypothesis | Axiom - -*) -(** Kinds used in proofs *) - -type goal_object_kind = - | DefinitionBody of definition_object_kind - | Proof of theorem_kind - -(** Kinds used in library *) - -type logical_kind = - | IsPrimitive - | IsAssumption of assumption_object_kind - | IsDefinition of definition_object_kind - | IsProof of theorem_kind diff --git a/library/declaremods.ml b/library/declaremods.ml index fc3e667c20..eea129eae7 100644 --- a/library/declaremods.ml +++ b/library/declaremods.ml @@ -44,22 +44,6 @@ let inl2intopt = function | InlineAt i -> Some i | DefaultInline -> default_inline () -(** {6 Substitutive objects} - - - The list of bound identifiers is nonempty only if the objects - are owned by a functor - - - Then comes either the object segment itself (for interactive - modules), or a compact way to store derived objects (path to - a earlier module + substitution). -*) - -type algebraic_objects = - | Objs of Lib.lib_objects - | Ref of ModPath.t * substitution - -type substitutive_objects = MBId.t list * algebraic_objects - (** ModSubstObjs : a cache of module substitutive objects This table is common to modules and module types. @@ -99,17 +83,45 @@ module ModSubstObjs : let sobjs_no_functor (mbids,_) = List.is_empty mbids -let subst_aobjs sub = function - | Objs o -> Objs (Lib.subst_objects sub o) - | Ref (mp, sub0) -> Ref (mp, join sub0 sub) - -let subst_sobjs sub (mbids,aobjs) = (mbids, subst_aobjs sub aobjs) +let rec subst_aobjs sub = function + | Objs o as objs -> + let o' = subst_objects sub o in + if o == o' then objs else Objs o' + | Ref (mp, sub0) as r -> + let sub0' = join sub0 sub in + if sub0' == sub0 then r else Ref (mp, sub0') + +and subst_sobjs sub (mbids,aobjs as sobjs) = + let aobjs' = subst_aobjs sub aobjs in + if aobjs' == aobjs then sobjs else (mbids, aobjs') + +and subst_objects subst seg = + let subst_one (id,obj as node) = + match obj with + | AtomicObject obj -> + let obj' = Libobject.subst_object (subst,obj) in + if obj' == obj then node else (id, AtomicObject obj') + | ModuleObject sobjs -> + let sobjs' = subst_sobjs subst sobjs in + if sobjs' == sobjs then node else (id, ModuleObject sobjs') + | ModuleTypeObject sobjs -> + let sobjs' = subst_sobjs subst sobjs in + if sobjs' == sobjs then node else (id, ModuleTypeObject sobjs') + | IncludeObject aobjs -> + let aobjs' = subst_aobjs subst aobjs in + if aobjs' == aobjs then node else (id, IncludeObject aobjs') + | ImportObject { export; mp } -> + let mp' = subst_mp subst mp in + if mp'==mp then node else (id, ImportObject { export; mp = mp' }) + | KeepObject _ -> assert false + in + List.Smart.map subst_one seg let expand_aobjs = function | Objs o -> o | Ref (mp, sub) -> match ModSubstObjs.get mp with - | (_,Objs o) -> Lib.subst_objects sub o + | (_,Objs o) -> subst_objects sub o | _ -> assert false (* Invariant : any alias points to concrete objs *) let expand_sobjs (_,aobjs) = expand_aobjs aobjs @@ -216,27 +228,41 @@ let do_module' exists iter_objects i ((sp,kn),sobjs) = (** Nota: Interactive modules and module types cannot be recached! This used to be checked here via a flag along the substobjs. *) -let cache_module = do_module' false Lib.load_objects 1 -let load_module = do_module' false Lib.load_objects -let open_module = do_module' true Lib.open_objects -let subst_module (subst,sobjs) = subst_sobjs subst sobjs -let classify_module sobjs = Substitute sobjs +(** {6 Declaration of module type substitutive objects} *) -let (in_module : substitutive_objects -> obj), - (out_module : obj -> substitutive_objects) = - declare_object_full {(default_object "MODULE") with - cache_function = cache_module; - load_function = load_module; - open_function = open_module; - subst_function = subst_module; - classify_function = classify_module } +(** Nota: Interactive modules and module types cannot be recached! + This used to be checked more properly here. *) +let do_modtype i sp mp sobjs = + if Nametab.exists_modtype sp then + anomaly (pr_path sp ++ str " already exists."); + Nametab.push_modtype (Nametab.Until i) sp mp; + ModSubstObjs.set mp sobjs -(** {6 Declaration of module keep objects} *) +(** {6 Declaration of substitutive objects for Include} *) -let cache_keep _ = anomaly (Pp.str "This module should not be cached!") +let rec load_object i (name, obj) = + match obj with + | AtomicObject o -> Libobject.load_object i (name, o) + | ModuleObject sobjs -> do_module' false load_objects i (name, sobjs) + | ModuleTypeObject sobjs -> + let (sp,kn) = name in + do_modtype i sp (mp_of_kn kn) sobjs + | IncludeObject aobjs -> load_include i (name, aobjs) + | ImportObject _ -> () + | KeepObject objs -> load_keep i (name, objs) + +and load_objects i prefix objs = + List.iter (fun (id, obj) -> load_object i (Lib.make_oname prefix id, obj)) objs + +and load_include i ((sp,kn), aobjs) = + let obj_dir = Libnames.dirpath sp in + let obj_mp = KerName.modpath kn in + let prefix = Nametab.{ obj_dir; obj_mp; obj_sec = DirPath.empty } in + let o = expand_aobjs aobjs in + load_objects i prefix o -let load_keep i ((sp,kn),kobjs) = +and load_keep i ((sp,kn),kobjs) = (* Invariant : seg isn't empty *) let obj_dir = dir_of_sp sp and obj_mp = mp_of_kn kn in let prefix = Nametab.{ obj_dir ; obj_mp; obj_sec = DirPath.empty } in @@ -247,37 +273,29 @@ let load_keep i ((sp,kn),kobjs) = assert Nametab.(eq_op prefix' prefix); assert (List.is_empty kobjs0); ModObjs.set obj_mp (prefix,sobjs,kobjs); - Lib.load_objects i prefix kobjs - -let open_keep i ((sp,kn),kobjs) = - let obj_dir = dir_of_sp sp and obj_mp = mp_of_kn kn in - let prefix = Nametab.{ obj_dir; obj_mp; obj_sec = DirPath.empty } in - Lib.open_objects i prefix kobjs - -let in_modkeep : Lib.lib_objects -> obj = - declare_object {(default_object "MODULE KEEP") with - cache_function = cache_keep; - load_function = load_keep; - open_function = open_keep } - - -(** {6 Declaration of module type substitutive objects} *) - -(** Nota: Interactive modules and module types cannot be recached! - This used to be checked more properly here. *) - -let do_modtype i sp mp sobjs = - if Nametab.exists_modtype sp then - anomaly (pr_path sp ++ str " already exists."); - Nametab.push_modtype (Nametab.Until i) sp mp; - ModSubstObjs.set mp sobjs + load_objects i prefix kobjs -let cache_modtype ((sp,kn),sobjs) = do_modtype 1 sp (mp_of_kn kn) sobjs -let load_modtype i ((sp,kn),sobjs) = do_modtype i sp (mp_of_kn kn) sobjs -let subst_modtype (subst,sobjs) = subst_sobjs subst sobjs -let classify_modtype sobjs = Substitute sobjs +(** {6 Implementation of Import and Export commands} *) -let open_modtype i ((sp,kn),_) = +let rec really_import_module mp = + (* May raise Not_found for unknown module and for functors *) + let prefix,sobjs,keepobjs = ModObjs.get mp in + open_objects 1 prefix sobjs; + open_objects 1 prefix keepobjs + +and open_object i (name, obj) = + match obj with + | AtomicObject o -> Libobject.open_object i (name, o) + | ModuleObject sobjs -> do_module' true open_objects i (name, sobjs) + | ModuleTypeObject sobjs -> open_modtype i (name, sobjs) + | IncludeObject aobjs -> open_include i (name, aobjs) + | ImportObject { mp; _ } -> open_import i mp + | KeepObject objs -> open_keep i (name, objs) + +and open_objects i prefix objs = + List.iter (fun (id, obj) -> open_object i (Lib.make_oname prefix id, obj)) objs + +and open_modtype i ((sp,kn),_) = let mp = mp_of_kn kn in let mp' = try Nametab.locate_modtype (qualid_of_path sp) @@ -287,41 +305,61 @@ let open_modtype i ((sp,kn),_) = assert (ModPath.equal mp mp'); Nametab.push_modtype (Nametab.Exactly i) sp mp -let (in_modtype : substitutive_objects -> obj), - (out_modtype : obj -> substitutive_objects) = - declare_object_full {(default_object "MODULE TYPE") with - cache_function = cache_modtype; - open_function = open_modtype; - load_function = load_modtype; - subst_function = subst_modtype; - classify_function = classify_modtype } - - -(** {6 Declaration of substitutive objects for Include} *) - -let do_include do_load do_open i ((sp,kn),aobjs) = +and open_include i ((sp,kn), aobjs) = let obj_dir = Libnames.dirpath sp in let obj_mp = KerName.modpath kn in let prefix = Nametab.{ obj_dir; obj_mp; obj_sec = DirPath.empty } in let o = expand_aobjs aobjs in - if do_load then Lib.load_objects i prefix o; - if do_open then Lib.open_objects i prefix o - -let cache_include = do_include true true 1 -let load_include = do_include true false -let open_include = do_include false true -let subst_include (subst,aobjs) = subst_aobjs subst aobjs -let classify_include aobjs = Substitute aobjs + open_objects i prefix o -let (in_include : algebraic_objects -> obj), - (out_include : obj -> algebraic_objects) = - declare_object_full {(default_object "INCLUDE") with - cache_function = cache_include; - load_function = load_include; - open_function = open_include; - subst_function = subst_include; - classify_function = classify_include } +and open_import i mp = + if Int.equal i 1 then really_import_module mp +and open_keep i ((sp,kn),kobjs) = + let obj_dir = dir_of_sp sp and obj_mp = mp_of_kn kn in + let prefix = Nametab.{ obj_dir; obj_mp; obj_sec = DirPath.empty } in + open_objects i prefix kobjs + +let rec cache_object (name, obj) = + match obj with + | AtomicObject o -> Libobject.cache_object (name, o) + | ModuleObject sobjs -> do_module' false load_objects 1 (name, sobjs) + | ModuleTypeObject sobjs -> + let (sp,kn) = name in + do_modtype 1 sp (mp_of_kn kn) sobjs + | IncludeObject aobjs -> cache_include (name, aobjs) + | ImportObject { mp } -> really_import_module mp + | KeepObject objs -> cache_keep (name, objs) + +and cache_include ((sp,kn), aobjs) = + let obj_dir = Libnames.dirpath sp in + let obj_mp = KerName.modpath kn in + let prefix = Nametab.{ obj_dir; obj_mp; obj_sec = DirPath.empty } in + let o = expand_aobjs aobjs in + load_objects 1 prefix o; + open_objects 1 prefix o + +and cache_keep ((sp,kn),kobjs) = + anomaly (Pp.str "This module should not be cached!") + +(* Adding operations with containers *) + +let add_leaf id obj = + if ModPath.equal (Lib.current_mp ()) ModPath.initial then + user_err Pp.(str "No session module started (use -top dir)"); + let oname = Lib.make_foname id in + cache_object (oname,obj); + Lib.add_entry oname (Lib.Leaf obj); + oname + +let add_leaves id objs = + let oname = Lib.make_foname id in + let add_obj obj = + Lib.add_entry oname (Lib.Leaf obj); + load_object 1 (oname,obj) + in + List.iter add_obj objs; + oname (** {6 Handler for missing entries in ModSubstObjs} *) @@ -331,11 +369,11 @@ let (in_include : algebraic_objects -> obj), let mp_id mp id = MPdot (mp, Label.of_id id) -let rec register_mod_objs mp (id,obj) = match object_tag obj with - | "MODULE" -> ModSubstObjs.set (mp_id mp id) (out_module obj) - | "MODULE TYPE" -> ModSubstObjs.set (mp_id mp id) (out_modtype obj) - | "INCLUDE" -> - List.iter (register_mod_objs mp) (expand_aobjs (out_include obj)) +let rec register_mod_objs mp (id,obj) = match obj with + | ModuleObject sobjs -> ModSubstObjs.set (mp_id mp id) sobjs + | ModuleTypeObject sobjs -> ModSubstObjs.set (mp_id mp id) sobjs + | IncludeObject aobjs -> + List.iter (register_mod_objs mp) (expand_aobjs aobjs) | _ -> () let handle_missing_substobjs mp = match mp with @@ -387,15 +425,18 @@ let rec replace_module_object idl mp0 objs0 mp1 objs1 = match idl, objs0 with | _,[] -> [] | id::idl,(id',obj)::tail when Id.equal id id' -> - assert (String.equal (object_tag obj) "MODULE"); - let mp_id = MPdot(mp0, Label.of_id id) in - let objs = match idl with - | [] -> Lib.subst_objects (map_mp mp1 mp_id empty_delta_resolver) objs1 - | _ -> - let objs_id = expand_sobjs (out_module obj) in - replace_module_object idl mp_id objs_id mp1 objs1 - in - (id, in_module ([], Objs objs))::tail + begin match obj with + | ModuleObject sobjs -> + let mp_id = MPdot(mp0, Label.of_id id) in + let objs = match idl with + | [] -> subst_objects (map_mp mp1 mp_id empty_delta_resolver) objs1 + | _ -> + let objs_id = expand_sobjs sobjs in + replace_module_object idl mp_id objs_id mp1 objs1 + in + (id, ModuleObject ([], Objs objs))::tail + | _ -> assert false + end | idl,lobj::tail -> lobj::replace_module_object idl mp0 tail mp1 objs1 let type_of_mod mp env = function @@ -450,7 +491,7 @@ let process_module_binding mbid me = let sobjs = get_module_sobjs false (Global.env()) (default_inline ()) me in let subst = map_mp (get_module_path me) mp empty_delta_resolver in let sobjs = subst_sobjs subst sobjs in - do_module false Lib.load_objects 1 dir mp sobjs [] + do_module false load_objects 1 dir mp sobjs [] (** Process a declaration of functor parameter(s) (Id1 .. Idn : Typ) i.e. possibly multiple names with the same module type. @@ -473,7 +514,7 @@ let intern_arg interp_modast (acc, cst) (idl,(typ,ann)) = let mp = MPbound mbid in let resolver = Global.add_module_parameter mbid mty inl in let sobjs = subst_sobjs (map_mp mp0 mp resolver) sobjs in - do_module false Lib.load_objects 1 dir mp sobjs []; + do_module false load_objects 1 dir mp sobjs []; (mbid,mty,inl)::acc in let acc = List.fold_left fold acc idl in @@ -632,13 +673,13 @@ let end_module () = | Some (mty, _) -> subst_sobjs (map_mp (get_module_path mty) mp resolver) sobjs in - let node = in_module sobjs in + let node = ModuleObject sobjs in (* We add the keep objects, if any, and if this isn't a functor *) let objects = match keep, mbids with | [], _ | _, _ :: _ -> special@[node] - | _ -> special@[node;in_modkeep keep] + | _ -> special@[node;KeepObject keep] in - let newoname = Lib.add_leaves id objects in + let newoname = add_leaves id objects in (* Name consistency check : start_ vs. end_module, kernel vs. library *) assert (eq_full_path (fst newoname) (fst oldoname)); @@ -705,7 +746,7 @@ let declare_module interp_modast id args res mexpr_o fs = check_subtypes mp subs; let sobjs = subst_sobjs (map_mp mp0 mp resolver) sobjs in - ignore (Lib.add_leaf id (in_module sobjs)); + ignore (add_leaf id (ModuleObject sobjs)); mp end @@ -734,7 +775,7 @@ let end_modtype () = let mp, mbids = Global.end_modtype fs id in let modtypeobjs = (mbids, Objs substitute) in check_subtypes_mt mp sub_mty_l; - let oname = Lib.add_leaves id (special@[in_modtype modtypeobjs]) + let oname = add_leaves id (special@[ModuleTypeObject modtypeobjs]) in (* Check name consistence : start_ vs. end_modtype, kernel vs. library *) assert (eq_full_path (fst oname) (fst oldoname)); @@ -779,7 +820,7 @@ let declare_modtype interp_modast id args mtys (mty,ann) fs = (* Subtyping checks *) check_subtypes_mt mp sub_mty_l; - ignore (Lib.add_leaf id (in_modtype sobjs)); + ignore (add_leaf id (ModuleTypeObject sobjs)); mp end @@ -834,7 +875,7 @@ let declare_one_include interp_modast (me_ast,annot) = let resolver = Global.add_include me is_mod inl in let subst = join subst_self (map_mp base_mp cur_mp resolver) in let aobjs = subst_aobjs subst aobjs in - ignore (Lib.add_leaf (Lib.current_mod_id ()) (in_include aobjs)) + ignore (add_leaf (Lib.current_mod_id ()) (IncludeObject aobjs)) let declare_include interp me_asts = List.iter (declare_one_include interp) me_asts @@ -913,10 +954,7 @@ let register_library dir cenv (objs:library_objects) digest univ = anomaly (Pp.str "Unexpected disk module name."); in let sobjs,keepobjs = objs in - do_module false Lib.load_objects 1 dir mp ([],Objs sobjs) keepobjs - -let get_library_native_symbols dir = - Safe_typing.get_library_native_symbols (Global.safe_env ()) dir + do_module false load_objects 1 dir mp ([],Objs sobjs) keepobjs let start_library dir = let mp = Global.start_library dir in @@ -937,45 +975,16 @@ let end_library ?except ~output_native_objects dir = let substitute, keep, _ = Lib.classify_segment lib_stack in cenv,(substitute,keep),ast - - -(** {6 Implementation of Import and Export commands} *) - -let really_import_module mp = - (* May raise Not_found for unknown module and for functors *) - let prefix,sobjs,keepobjs = ModObjs.get mp in - Lib.open_objects 1 prefix sobjs; - Lib.open_objects 1 prefix keepobjs - -let cache_import (_,(_,mp)) = really_import_module mp - -let open_import i obj = - if Int.equal i 1 then cache_import obj - -let classify_import (export,_ as obj) = - if export then Substitute obj else Dispose - -let subst_import (subst,(export,mp as obj)) = - let mp' = subst_mp subst mp in - if mp'==mp then obj else (export,mp') - -let in_import : bool * ModPath.t -> obj = - declare_object {(default_object "IMPORT MODULE") with - cache_function = cache_import; - open_function = open_import; - subst_function = subst_import; - classify_function = classify_import } - let import_module export mp = - Lib.add_anonymous_leaf (in_import (export,mp)) - + really_import_module mp; + Lib.add_anonymous_entry (Lib.Leaf (ImportObject { export; mp })) (** {6 Iterators} *) let iter_all_segments f = - let rec apply_obj prefix (id,obj) = match object_tag obj with - | "INCLUDE" -> - let objs = expand_aobjs (out_include obj) in + let rec apply_obj prefix (id,obj) = match obj with + | IncludeObject aobjs -> + let objs = expand_aobjs aobjs in List.iter (apply_obj prefix) objs | _ -> f (Lib.make_oname prefix id) obj in diff --git a/library/declaremods.mli b/library/declaremods.mli index 93aadd25de..ada53dbff0 100644 --- a/library/declaremods.mli +++ b/library/declaremods.mli @@ -94,8 +94,6 @@ val register_library : Safe_typing.compiled_library -> library_objects -> Safe_typing.vodigest -> Univ.ContextSet.t -> unit -val get_library_native_symbols : library_name -> Nativecode.symbols - val start_library : library_name -> unit val end_library : @@ -130,7 +128,7 @@ val declare_include : (together with their section path). *) val iter_all_segments : - (Libobject.object_name -> Libobject.obj -> unit) -> unit + (Libobject.object_name -> Libobject.t -> unit) -> unit val debug_print_modtab : unit -> Pp.t diff --git a/library/decls.ml b/library/decls.ml deleted file mode 100644 index 5cb35323dd..0000000000 --- a/library/decls.ml +++ /dev/null @@ -1,51 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(** This module registers tables for some non-logical informations - associated declarations *) - -open Names -open Decl_kinds -open Libnames - -(** Datas associated to section variables and local definitions *) - -type variable_data = { - path:DirPath.t; - opaque:bool; - univs:Univ.ContextSet.t; - poly:bool; - kind:logical_kind; -} - -let vartab = - Summary.ref (Id.Map.empty : variable_data Id.Map.t) ~name:"VARIABLE" - -let add_variable_data id o = vartab := Id.Map.add id o !vartab - -let variable_path id = let {path} = Id.Map.find id !vartab in path -let variable_opacity id = let {opaque} = Id.Map.find id !vartab in opaque -let variable_kind id = let {kind} = Id.Map.find id !vartab in kind -let variable_context id = let {univs} = Id.Map.find id !vartab in univs -let variable_polymorphic id = let {poly} = Id.Map.find id !vartab in poly - -let variable_secpath id = - let dir = drop_dirpath_prefix (Lib.library_dp()) (variable_path id) in - make_qualid dir id - -let variable_exists id = Id.Map.mem id !vartab - -(** Datas associated to global parameters and constants *) - -let csttab = Summary.ref (Cmap.empty : logical_kind Cmap.t) ~name:"CONSTANT" - -let add_constant_kind kn k = csttab := Cmap.add kn k !csttab - -let constant_kind kn = Cmap.find kn !csttab diff --git a/library/global.mli b/library/global.mli index 51307b3604..d034bc4208 100644 --- a/library/global.mli +++ b/library/global.mli @@ -38,7 +38,7 @@ val sprop_allowed : unit -> bool (** Variables, Local definitions, constants, inductive types *) -val push_named_assum : (Id.t * Constr.types * bool) Univ.in_universe_context_set -> unit +val push_named_assum : (Id.t * Constr.types) -> unit val push_named_def : (Id.t * Entries.section_def_entry) -> unit val export_private_constants : in_section:bool -> diff --git a/library/globnames.ml b/library/globnames.ml index 71447c4b81..acb05f9ac0 100644 --- a/library/globnames.ml +++ b/library/globnames.ml @@ -12,12 +12,14 @@ open Names open Constr open Mod_subst -(*s Global reference is a kernel side type for all references together *) type global_reference = GlobRef.t = - | VarRef of variable (** A reference to the section-context. *) - | ConstRef of Constant.t (** A reference to the environment. *) - | IndRef of inductive (** A reference to an inductive type. *) - | ConstructRef of constructor (** A reference to a constructor of an inductive type. *) + | VarRef of variable [@ocaml.deprecated "Use Names.GlobRef.VarRef"] + | ConstRef of Constant.t [@ocaml.deprecated "Use Names.GlobRef.ConstRef"] + | IndRef of inductive [@ocaml.deprecated "Use Names.GlobRef.IndRef"] + | ConstructRef of constructor [@ocaml.deprecated "Use Names.GlobRef.ConstructRef"] +[@@ocaml.deprecated "Use Names.GlobRef.t"] + +open GlobRef let isVarRef = function VarRef _ -> true | _ -> false let isConstRef = function ConstRef _ -> true | _ -> false @@ -90,7 +92,7 @@ let printable_constr_of_global = function type syndef_name = KerName.t type extended_global_reference = - | TrueGlobal of global_reference + | TrueGlobal of GlobRef.t | SynDef of syndef_name (* We order [extended_global_reference] via their user part @@ -122,6 +124,6 @@ module ExtRefOrdered = struct end -type global_reference_or_constr = - | IsGlobal of global_reference +type global_reference_or_constr = + | IsGlobal of GlobRef.t | IsConstr of constr diff --git a/library/globnames.mli b/library/globnames.mli index 547755b088..fc0de96e36 100644 --- a/library/globnames.mli +++ b/library/globnames.mli @@ -12,12 +12,11 @@ open Names open Constr open Mod_subst -(** {6 Global reference is a kernel side type for all references together } *) type global_reference = GlobRef.t = - | VarRef of variable (** A reference to the section-context. *) - | ConstRef of Constant.t (** A reference to the environment. *) - | IndRef of inductive (** A reference to an inductive type. *) - | ConstructRef of constructor (** A reference to a constructor of an inductive type. *) + | VarRef of variable [@ocaml.deprecated "Use Names.GlobRef.VarRef"] + | ConstRef of Constant.t [@ocaml.deprecated "Use Names.GlobRef.ConstRef"] + | IndRef of inductive [@ocaml.deprecated "Use Names.GlobRef.IndRef"] + | ConstructRef of constructor [@ocaml.deprecated "Use Names.GlobRef.ConstructRef"] [@@ocaml.deprecated "Use Names.GlobRef.t"] val isVarRef : GlobRef.t -> bool diff --git a/library/keys.ml b/library/keys.ml index 30ecc9dfdb..9964992433 100644 --- a/library/keys.ml +++ b/library/keys.ml @@ -94,7 +94,7 @@ let subst_keys (subst,(k,k')) = (subst_key subst k, subst_key subst k') let discharge_key = function - | KGlob (VarRef _ as g) when Lib.is_in_section g -> None + | KGlob (GlobRef.VarRef _ as g) when Lib.is_in_section g -> None | x -> Some x let discharge_keys (_,(k,k')) = @@ -114,16 +114,15 @@ let declare_equiv_keys ref ref' = Lib.add_anonymous_leaf (inKeys (ref,ref')) let constr_key kind c = - let open Globnames in - try - let rec aux k = + try + let rec aux k = match kind k with - | Const (c, _) -> KGlob (ConstRef c) - | Ind (i, u) -> KGlob (IndRef i) - | Construct (c,u) -> KGlob (ConstructRef c) - | Var id -> KGlob (VarRef id) + | Const (c, _) -> KGlob (GlobRef.ConstRef c) + | Ind (i, u) -> KGlob (GlobRef.IndRef i) + | Construct (c,u) -> KGlob (GlobRef.ConstructRef c) + | Var id -> KGlob (GlobRef.VarRef id) | App (f, _) -> aux f - | Proj (p, _) -> KGlob (ConstRef (Projection.constant p)) + | Proj (p, _) -> KGlob (GlobRef.ConstRef (Projection.constant p)) | Cast (p, _, _) -> aux p | Lambda _ -> KLam | Prod _ -> KProd diff --git a/library/kindops.ml b/library/kindops.ml deleted file mode 100644 index 0bf55c62a9..0000000000 --- a/library/kindops.ml +++ /dev/null @@ -1,37 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -open Decl_kinds - -(** Operations about types defined in [Decl_kinds] *) - -let logical_kind_of_goal_kind = function - | DefinitionBody d -> IsDefinition d - | Proof s -> IsProof s - -let string_of_theorem_kind = function - | Theorem -> "Theorem" - | Lemma -> "Lemma" - | Fact -> "Fact" - | Remark -> "Remark" - | Property -> "Property" - | Proposition -> "Proposition" - | Corollary -> "Corollary" - -let string_of_definition_object_kind = function - | Definition -> "Definition" - | Example -> "Example" - | Coercion -> "Coercion" - | SubClass -> "SubClass" - | CanonicalStructure -> "Canonical Structure" - | Instance -> "Instance" - | Let -> "Let" - | (StructureComponent|Scheme|CoFixpoint|Fixpoint|IdentityCoercion|Method) -> - CErrors.anomaly (Pp.str "Internal definition kind.") diff --git a/library/lib.ml b/library/lib.ml index 3eb74808e4..d461644d56 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -13,7 +13,6 @@ open CErrors open Util open Names open Libnames -open Globnames open Libobject open Context.Named.Declaration @@ -28,7 +27,7 @@ let make_oname Nametab.{ obj_dir; obj_mp } id = (* let make_oname (dirpath,(mp,dir)) id = *) type node = - | Leaf of obj + | Leaf of Libobject.t | CompilingLibrary of Nametab.object_prefix | OpenedModule of is_type * export * Nametab.object_prefix * Summary.frozen | OpenedSection of Nametab.object_prefix * Summary.frozen @@ -37,7 +36,8 @@ type library_entry = object_name * node type library_segment = library_entry list -type lib_objects = (Names.Id.t * obj) list +type lib_atomic_objects = (Id.t * Libobject.obj) list +type lib_objects = (Names.Id.t * Libobject.t) list let module_kind is_type = if is_type then "module type" else "module" @@ -45,10 +45,10 @@ let module_kind is_type = let iter_objects f i prefix = List.iter (fun (id,obj) -> f i (make_oname prefix id, obj)) -let load_objects i pr = iter_objects load_object i pr -let open_objects i pr = iter_objects open_object i pr +let load_atomic_objects i pr = iter_objects load_object i pr +let open_atomic_objects i pr = iter_objects open_object i pr -let subst_objects subst seg = +let subst_atomic_objects subst seg = let subst_one = fun (id,obj as node) -> let obj' = subst_object (subst,obj) in if obj' == obj then node else @@ -67,15 +67,28 @@ let classify_segment seg = let rec clean ((substl,keepl,anticipl) as acc) = function | (_,CompilingLibrary _) :: _ | [] -> acc | ((sp,kn),Leaf o) :: stk -> - let id = Names.Label.to_id (Names.KerName.label kn) in - (match classify_object o with - | Dispose -> clean acc stk - | Keep o' -> - clean (substl, (id,o')::keepl, anticipl) stk - | Substitute o' -> - clean ((id,o')::substl, keepl, anticipl) stk - | Anticipate o' -> - clean (substl, keepl, o'::anticipl) stk) + let id = Names.Label.to_id (Names.KerName.label kn) in + begin match o with + | ModuleObject _ | ModuleTypeObject _ | IncludeObject _ -> + clean ((id,o)::substl, keepl, anticipl) stk + | KeepObject _ -> + clean (substl, (id,o)::keepl, anticipl) stk + | ImportObject { export } -> + if export then + clean ((id,o)::substl, keepl, anticipl) stk + else + clean acc stk + | AtomicObject obj -> + begin match classify_object obj with + | Dispose -> clean acc stk + | Keep o' -> + clean (substl, (id,AtomicObject o')::keepl, anticipl) stk + | Substitute o' -> + clean ((id,AtomicObject o')::substl, keepl, anticipl) stk + | Anticipate o' -> + clean (substl, keepl, AtomicObject o'::anticipl) stk + end + end | (_,OpenedSection _) :: _ -> user_err Pp.(str "there are still opened sections") | (_,OpenedModule (ty,_,_,_)) :: _ -> user_err ~hdr:"Lib.classify_segment" @@ -223,19 +236,19 @@ let add_leaf id obj = user_err Pp.(str "No session module started (use -top dir)"); let oname = make_foname id in cache_object (oname,obj); - add_entry oname (Leaf obj); + add_entry oname (Leaf (AtomicObject obj)); oname let add_discharged_leaf id obj = let oname = make_foname id in let newobj = rebuild_object obj in cache_object (oname,newobj); - add_entry oname (Leaf newobj) + add_entry oname (Leaf (AtomicObject newobj)) let add_leaves id objs = let oname = make_foname id in let add_obj obj = - add_entry oname (Leaf obj); + add_entry oname (Leaf (AtomicObject obj)); load_object 1 (oname,obj) in List.iter add_obj objs; @@ -246,9 +259,9 @@ let add_anonymous_leaf ?(cache_first = true) obj = let oname = make_foname id in if cache_first then begin cache_object (oname,obj); - add_entry oname (Leaf obj) + add_entry oname (Leaf (AtomicObject obj)) end else begin - add_entry oname (Leaf obj); + add_entry oname (Leaf (AtomicObject obj)); cache_object (oname,obj) end @@ -535,7 +548,7 @@ let empty_segment = { abstr_uctx = Univ.AUContext.empty; } -let section_segment_of_reference = function +let section_segment_of_reference = let open GlobRef in function | ConstRef c -> section_segment_of_constant c | IndRef (kn,_) | ConstructRef ((kn,_),_) -> section_segment_of_mutual_inductive kn @@ -544,7 +557,7 @@ let section_segment_of_reference = function let variable_section_segment_of_reference gr = (section_segment_of_reference gr).abstr_ctx -let section_instance = function +let section_instance = let open GlobRef in function | VarRef id -> let eq = function | Variable {id=id'} -> Names.Id.equal id id' @@ -583,7 +596,12 @@ let open_section id = let discharge_item ((sp,_ as oname),e) = match e with | Leaf lobj -> - Option.map (fun o -> (basename sp,o)) (discharge_object (oname,lobj)) + begin match lobj with + | ModuleObject _ | ModuleTypeObject _ | IncludeObject _ | KeepObject _ + | ImportObject _ -> None + | AtomicObject obj -> + Option.map (fun o -> (basename sp,o)) (discharge_object (oname,obj)) + end | OpenedSection _ | OpenedModule _ | CompilingLibrary _ -> anomaly (Pp.str "discharge_item.") @@ -628,7 +646,7 @@ let init () = (* Misc *) -let mp_of_global = function +let mp_of_global = let open GlobRef in function | VarRef id -> !lib_state.path_prefix.Nametab.obj_mp | ConstRef cst -> Names.Constant.modpath cst | IndRef ind -> Names.ind_modpath ind @@ -647,12 +665,12 @@ let rec split_modpath = function (dp, Names.Label.to_id l :: ids) let library_part = function - |VarRef id -> library_dp () - |ref -> dp_of_mp (mp_of_global ref) + | GlobRef.VarRef id -> library_dp () + | ref -> dp_of_mp (mp_of_global ref) let discharge_proj_repr = Projection.Repr.map_npars (fun mind npars -> - if not (is_in_section (IndRef (mind,0))) then mind, npars + if not (is_in_section (GlobRef.IndRef (mind,0))) then mind, npars else let modlist = replacement_context () in let _, newpars = Mindmap.find mind (snd modlist) in mind, npars + Array.length newpars) diff --git a/library/lib.mli b/library/lib.mli index 2cd43b66b3..01366ddfd0 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -20,22 +20,24 @@ type is_type = bool (* Module Type or just Module *) type export = bool option (* None for a Module Type *) val make_oname : Nametab.object_prefix -> Names.Id.t -> Libobject.object_name +val make_foname : Names.Id.t -> Libnames.full_path * Names.KerName.t type node = - | Leaf of Libobject.obj + | Leaf of Libobject.t | CompilingLibrary of Nametab.object_prefix | OpenedModule of is_type * export * Nametab.object_prefix * Summary.frozen | OpenedSection of Nametab.object_prefix * Summary.frozen type library_segment = (Libobject.object_name * node) list -type lib_objects = (Id.t * Libobject.obj) list +type lib_atomic_objects = (Id.t * Libobject.obj) list +type lib_objects = (Id.t * Libobject.t) list (** {6 Object iteration functions. } *) -val open_objects : int -> Nametab.object_prefix -> lib_objects -> unit -val load_objects : int -> Nametab.object_prefix -> lib_objects -> unit -val subst_objects : Mod_subst.substitution -> lib_objects -> lib_objects +val open_atomic_objects : int -> Nametab.object_prefix -> lib_atomic_objects -> unit +val load_atomic_objects : int -> Nametab.object_prefix -> lib_atomic_objects -> unit +val subst_atomic_objects : Mod_subst.substitution -> lib_atomic_objects -> lib_atomic_objects (*val load_and_subst_objects : int -> Libnames.Nametab.object_prefix -> Mod_subst.substitution -> lib_objects -> lib_objects*) (** [classify_segment seg] verifies that there are no OpenedThings, @@ -44,12 +46,17 @@ val subst_objects : Mod_subst.substitution -> lib_objects -> lib_objects [Substitute], [Keep], [Anticipate] respectively. The order of each returned list is the same as in the input list. *) val classify_segment : - library_segment -> lib_objects * lib_objects * Libobject.obj list + library_segment -> lib_objects * lib_objects * Libobject.t list (** [segment_of_objects prefix objs] forms a list of Leafs *) val segment_of_objects : Nametab.object_prefix -> lib_objects -> library_segment +(** {6 ... } *) +(** Low-level adding operations *) + +val add_entry : Libobject.object_name -> node -> unit +val add_anonymous_entry : node -> unit (** {6 ... } *) (** Adding operations (which call the [cache] method, and getting the diff --git a/library/libnames.ml b/library/libnames.ml index 18af216e46..485f8837e8 100644 --- a/library/libnames.ml +++ b/library/libnames.ml @@ -128,11 +128,6 @@ let path_of_string s = let pr_path sp = str (string_of_path sp) -let restrict_path n sp = - let dir, s = repr_path sp in - let dir' = List.firstn n (DirPath.repr dir) in - make_path (DirPath.make dir') s - (*s qualified names *) type qualid_r = full_path type qualid = qualid_r CAst.t diff --git a/library/libnames.mli b/library/libnames.mli index 4455e29818..ffd7032fff 100644 --- a/library/libnames.mli +++ b/library/libnames.mli @@ -57,8 +57,6 @@ val pr_path : full_path -> Pp.t module Spmap : CSig.MapS with type key = full_path -val restrict_path : int -> full_path -> full_path - (** {6 ... } *) (** A [qualid] is a partially qualified ident; it includes fully qualified names (= absolute names) and all intermediate partial diff --git a/library/libobject.ml b/library/libobject.ml index 72791661bc..27e7810e6c 100644 --- a/library/libobject.ml +++ b/library/libobject.ml @@ -9,6 +9,7 @@ (************************************************************************) open Pp +open Names module Dyn = Dyn.Make () @@ -34,7 +35,7 @@ let default_object s = { open_function = (fun _ _ -> ()); subst_function = (fun _ -> CErrors.anomaly (str "The object " ++ str s ++ str " does not know how to substitute!")); - classify_function = (fun obj -> Keep obj); + classify_function = (fun atomic_obj -> Keep atomic_obj); discharge_function = (fun _ -> None); rebuild_function = (fun x -> x)} @@ -52,8 +53,35 @@ let default_object s = { let ident_subst_function (_,a) = a + type obj = Dyn.t (* persistent dynamic objects *) +(** {6 Substitutive objects} + + - The list of bound identifiers is nonempty only if the objects + are owned by a functor + + - Then comes either the object segment itself (for interactive + modules), or a compact way to store derived objects (path to + a earlier module + substitution). +*) + +type algebraic_objects = + | Objs of objects + | Ref of Names.ModPath.t * Mod_subst.substitution + +and t = + | ModuleObject of substitutive_objects + | ModuleTypeObject of substitutive_objects + | IncludeObject of algebraic_objects + | KeepObject of objects + | ImportObject of { export : bool; mp : ModPath.t } + | AtomicObject of obj + +and objects = (Names.Id.t * t) list + +and substitutive_objects = MBId.t list * algebraic_objects + type dynamic_object_declaration = { dyn_cache_function : object_name * obj -> unit; dyn_load_function : int -> object_name * obj -> unit; @@ -77,9 +105,9 @@ let declare_object_full odecl = and substituter (sub,lobj) = infun (odecl.subst_function (sub,outfun lobj)) and classifier lobj = match odecl.classify_function (outfun lobj) with | Dispose -> Dispose - | Substitute obj -> Substitute (infun obj) - | Keep obj -> Keep (infun obj) - | Anticipate (obj) -> Anticipate (infun obj) + | Substitute atomic_obj -> Substitute (infun atomic_obj) + | Keep atomic_obj -> Keep (infun atomic_obj) + | Anticipate (atomic_obj) -> Anticipate (infun atomic_obj) and discharge (oname,lobj) = Option.map infun (odecl.discharge_function (oname,outfun lobj)) and rebuild lobj = infun (odecl.rebuild_function (outfun lobj)) diff --git a/library/libobject.mli b/library/libobject.mli index a7151d3bf2..3b37db4a6f 100644 --- a/library/libobject.mli +++ b/library/libobject.mli @@ -103,6 +103,22 @@ val ident_subst_function : substitution * 'a -> 'a type obj +type algebraic_objects = + | Objs of objects + | Ref of Names.ModPath.t * Mod_subst.substitution + +and t = + | ModuleObject of substitutive_objects + | ModuleTypeObject of substitutive_objects + | IncludeObject of algebraic_objects + | KeepObject of objects + | ImportObject of { export : bool; mp : Names.ModPath.t } + | AtomicObject of obj + +and objects = (Names.Id.t * t) list + +and substitutive_objects = Names.MBId.t list * algebraic_objects + val declare_object_full : 'a object_declaration -> ('a -> obj) * (obj -> 'a) diff --git a/library/library.ml b/library/library.ml index 0d4148d7e4..0faef7bf84 100644 --- a/library/library.ml +++ b/library/library.ml @@ -173,7 +173,7 @@ let register_loaded_library m = let f = prefix ^ "cmo" in let f = Dynlink.adapt_filename f in if Coq_config.native_compiler then - Nativelib.link_library ~prefix ~dirname ~basename:f + Nativelib.link_library (Global.env()) ~prefix ~dirname ~basename:f in let rec aux = function | [] -> link (); [libname] @@ -488,7 +488,7 @@ let require_library_from_dirpath ~lib_resolver modrefl export = let safe_locate_module qid = try Nametab.locate_module qid with Not_found -> - user_err ?loc:qid.CAst.loc ~hdr:"import_library" + user_err ?loc:qid.CAst.loc ~hdr:"safe_locate_module" (pr_qualid qid ++ str " is not a module") let import_module export modl = @@ -513,7 +513,7 @@ let import_module export modl = flush acc; try Declaremods.import_module export mp; aux [] l with Not_found -> - user_err ?loc:qid.CAst.loc ~hdr:"import_library" + user_err ?loc:qid.CAst.loc ~hdr:"import_module" (pr_qualid qid ++ str " is not a module")) | [] -> flush acc in aux [] modl diff --git a/library/library.mllib b/library/library.mllib index ef53471377..35af5fa43b 100644 --- a/library/library.mllib +++ b/library/library.mllib @@ -1,16 +1,15 @@ +Decl_kinds Libnames Globnames Libobject Summary Nametab Global -Decl_kinds Lib Declaremods Library States Kindops Goptions -Decls Keys Coqlib diff --git a/library/nametab.ml b/library/nametab.ml index 71ee7a6d5a..aed7d08ac1 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -392,6 +392,7 @@ let push_xref visibility sp xref = | _ -> begin if ExtRefTab.exists sp !the_ccitab then + let open GlobRef in match ExtRefTab.find sp !the_ccitab with | TrueGlobal( ConstRef _) | TrueGlobal( IndRef _) | TrueGlobal( ConstructRef _) as xref -> @@ -483,6 +484,7 @@ let completion_canditates qualid = (* Derived functions *) let locate_constant qid = + let open GlobRef in match locate_extended qid with | TrueGlobal (ConstRef kn) -> kn | _ -> raise Not_found @@ -517,6 +519,7 @@ let exists_universe kn = UnivTab.exists kn !the_univtab (* Reverse locate functions ***********************************************) let path_of_global ref = + let open GlobRef in match ref with | VarRef id -> make_path DirPath.empty id | _ -> Globrevtab.find (TrueGlobal ref) !the_globrevtab @@ -542,6 +545,7 @@ let path_of_universe mp = (* Shortest qualid functions **********************************************) let shortest_qualid_of_global ?loc ctx ref = + let open GlobRef in match ref with | VarRef id -> make_qualid ?loc DirPath.empty id | _ -> @@ -570,6 +574,7 @@ let pr_global_env env ref = if !Flags.debug then Feedback.msg_debug (Pp.str "pr_global_env not found"); raise e let global_inductive qid = + let open GlobRef in match global qid with | IndRef ind -> ind | ref -> diff --git a/library/summary.ml b/library/summary.ml index b3ec4c2db2..d3ae42694a 100644 --- a/library/summary.ml +++ b/library/summary.ml @@ -153,7 +153,7 @@ let (!) r = CEphemeron.get (fst !r) let ref ?(freeze=fun x -> x) ~name init = - let r = Pervasives.ref (CEphemeron.create init, name) in + let r = pervasives_ref (CEphemeron.create init, name) in declare_summary name { freeze_function = (fun ~marshallable -> freeze !r); unfreeze_function = ((:=) r); diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index e34150f2b3..ead78f70a1 100644 --- a/plugins/derive/derive.ml +++ b/plugins/derive/derive.ml @@ -20,7 +20,7 @@ let start_deriving f suchthat name : Lemmas.t = let env = Global.env () in let sigma = Evd.from_env env in let poly = false in - let kind = Decl_kinds.(DefinitionBody Definition) in + let kind = Decls.(IsDefinition Definition) in (* create a sort variable for the type of [f] *) (* spiwack: I don't know what the rigidity flag does, picked the one diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml index 9abf212443..1c325a8d3a 100644 --- a/plugins/extraction/common.ml +++ b/plugins/extraction/common.ml @@ -15,7 +15,6 @@ open ModPath open Namegen open Nameops open Libnames -open Globnames open Table open Miniml open Mlutil @@ -125,7 +124,7 @@ module KOrd = struct type t = kind * string let compare (k1, s1) (k2, s2) = - let c = Pervasives.compare k1 k2 (* OK *) in + let c = pervasives_compare k1 k2 (* OK *) in if c = 0 then String.compare s1 s2 else c end @@ -629,21 +628,21 @@ let check_extract_ascii () = | Haskell -> "Prelude.Char" | _ -> raise Not_found in - String.equal (find_custom (IndRef (ind_ascii, 0))) (char_type) + String.equal (find_custom (GlobRef.IndRef (ind_ascii, 0))) (char_type) with Not_found -> false let is_list_cons l = - List.for_all (function MLcons (_,ConstructRef(_,_),[]) -> true | _ -> false) l + List.for_all (function MLcons (_,GlobRef.ConstructRef(_,_),[]) -> true | _ -> false) l let is_native_char = function - | MLcons(_,ConstructRef ((kn,0),1),l) -> + | MLcons(_,GlobRef.ConstructRef ((kn,0),1),l) -> MutInd.equal kn ind_ascii && check_extract_ascii () && is_list_cons l | _ -> false let get_native_char c = let rec cumul = function | [] -> 0 - | MLcons(_,ConstructRef(_,j),[])::l -> (2-j) + 2 * (cumul l) + | MLcons(_,GlobRef.ConstructRef(_,j),[])::l -> (2-j) + 2 * (cumul l) | _ -> assert false in let l = match c with MLcons(_,_,l) -> l | _ -> assert false in diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 7ee8d7f342..551dbdc6fb 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -14,7 +14,6 @@ open Declarations open Names open ModPath open Libnames -open Globnames open Pp open CErrors open Util @@ -29,24 +28,27 @@ open Common let toplevel_env () = let get_reference = function - | (_,kn), Lib.Leaf o -> - let mp,l = KerName.repr kn in - begin match Libobject.object_tag o with - | "CONSTANT" -> - let constant = Global.lookup_constant (Constant.make1 kn) in - Some (l, SFBconst constant) - | "INDUCTIVE" -> - let inductive = Global.lookup_mind (MutInd.make1 kn) in - Some (l, SFBmind inductive) - | "MODULE" -> - let modl = Global.lookup_module (MPdot (mp, l)) in - Some (l, SFBmodule modl) - | "MODULE TYPE" -> - let modtype = Global.lookup_modtype (MPdot (mp, l)) in - Some (l, SFBmodtype modtype) - | "INCLUDE" -> user_err Pp.(str "No extraction of toplevel Include yet.") - | _ -> None - end + | (_,kn), Lib.Leaf Libobject.AtomicObject o -> + let mp,l = KerName.repr kn in + begin match Libobject.object_tag o with + | "CONSTANT" -> + let constant = Global.lookup_constant (Constant.make1 kn) in + Some (l, SFBconst constant) + | "INDUCTIVE" -> + let inductive = Global.lookup_mind (MutInd.make1 kn) in + Some (l, SFBmind inductive) + | _ -> None + end + | (_,kn), Lib.Leaf Libobject.ModuleObject _ -> + let mp,l = KerName.repr kn in + let modl = Global.lookup_module (MPdot (mp, l)) in + Some (l, SFBmodule modl) + | (_,kn), Lib.Leaf Libobject.ModuleTypeObject _ -> + let mp,l = KerName.repr kn in + let modtype = Global.lookup_modtype (MPdot (mp, l)) in + Some (l, SFBmodtype modtype) + | (_,kn), Lib.Leaf Libobject.IncludeObject _ -> + user_err Pp.(str "No extraction of toplevel Include yet.") | _ -> None in List.rev (List.map_filter get_reference (Lib.contents ())) @@ -115,7 +117,7 @@ module Visit : VISIT = struct v.mp <- MPset.union (prefixes_mp mp) v.mp; v.mp_all <- MPset.add mp v.mp_all let add_kn kn = v.kn <- KNset.add kn v.kn; add_mp (KerName.modpath kn) - let add_ref = function + let add_ref = let open GlobRef in function | ConstRef c -> add_kn (Constant.user c) | IndRef (ind,_) | ConstructRef ((ind,_),_) -> add_kn (MutInd.user ind) | VarRef _ -> assert false @@ -758,7 +760,7 @@ let show_extraction ~pstate = let ast, ty = extract_constr env sigma t in let mp = Lib.current_mp () in let l = Label.of_id (Proof_global.get_proof_name pstate) in - let fake_ref = ConstRef (Constant.make2 mp l) in + let fake_ref = GlobRef.ConstRef (Constant.make2 mp l) in let decl = Dterm (fake_ref, ast, ty) in print_one_decl [] mp decl in diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index d0ad21a13e..78c6255c1e 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -24,7 +24,6 @@ open Termops open Inductiveops open Recordops open Namegen -open Globnames open Miniml open Table open Mlutil @@ -303,7 +302,7 @@ let rec extract_type env sg db j c args = else let n' = List.nth db (n-1) in if Int.equal n' 0 then Tunknown else Tvar n') | Const (kn,u) -> - let r = ConstRef kn in + let r = GlobRef.ConstRef kn in let typ = type_of env sg (EConstr.mkConstU (kn,u)) in (match flag_of_type env sg typ with | (Logic,_) -> assert false (* Cf. logical cases above *) @@ -311,7 +310,7 @@ let rec extract_type env sg db j c args = let mlt = extract_type_app env sg db (r, type_sign env sg typ) args in (match (lookup_constant kn env).const_body with | Undef _ | OpaqueDef _ | Primitive _ -> mlt - | Def _ when is_custom (ConstRef kn) -> mlt + | Def _ when is_custom (GlobRef.ConstRef kn) -> mlt | Def lbody -> let newc = applistc (get_body lbody) args in let mlt' = extract_type env sg db j newc [] in @@ -331,7 +330,7 @@ let rec extract_type env sg db j c args = extract_type env sg db j newc [])) | Ind ((kn,i),u) -> let s = (extract_ind env kn).ind_packets.(i).ip_sign in - extract_type_app env sg db (IndRef (kn,i),s) args + extract_type_app env sg db (GlobRef.IndRef (kn,i),s) args | Proj (p,t) -> (* Let's try to reduce, if it hasn't already been done. *) if Projection.unfolded p then Tunknown @@ -346,7 +345,7 @@ let rec extract_type env sg db j c args = | LocalDef (_,body,_) -> extract_type env sg db j (EConstr.applist (body,args)) [] | LocalAssum (_,ty) -> - let r = VarRef v in + let r = GlobRef.VarRef v in (match flag_of_type env sg ty with | (Logic,_) -> assert false (* Cf. logical cases above *) | (Info, TypeScheme) -> @@ -405,7 +404,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *) extract_really_ind env kn mib with SingletonInductiveBecomesProp id -> (* TODO : which inductive is concerned in the block ? *) - error_singleton_become_prop id (Some (IndRef (kn,0))) + error_singleton_become_prop id (Some (GlobRef.IndRef (kn,0))) (* Then the real function *) @@ -481,7 +480,7 @@ and extract_really_ind env kn mib = let ind_info = try let ip = (kn, 0) in - let r = IndRef ip in + let r = GlobRef.IndRef ip in if is_custom r then raise (I Standard); if mib.mind_finite == CoFinite then raise (I Coinductive); if not (Int.equal mib.mind_ntypes 1) then raise (I Standard); @@ -519,7 +518,7 @@ and extract_really_ind env kn mib = (* Is it safe to use [id] for projections [foo.id] ? *) if List.for_all ((==) Keep) (type2signature env typ) then projs := Cset.add knp !projs; - Some (ConstRef knp) :: (select_fields l typs) + Some (GlobRef.ConstRef knp) :: (select_fields l typs) | _ -> assert false in let field_glob = select_fields field_names typ @@ -565,7 +564,7 @@ and extract_type_cons env sg db dbmap c i = (*s Recording the ML type abbreviation of a Coq type scheme constant. *) -and mlt_env env r = match r with +and mlt_env env r = let open GlobRef in match r with | IndRef _ | ConstructRef _ | VarRef _ -> None | ConstRef kn -> let cb = Environ.lookup_constant kn env in @@ -688,7 +687,7 @@ let rec extract_term env sg mle mlt c args = | LocalDef (_,_,ty) -> ty in let vty = extract_type env sg [] 0 ty [] in - let extract_var mlt = put_magic (mlt,vty) (MLglob (VarRef v)) in + let extract_var mlt = put_magic (mlt,vty) (MLglob (GlobRef.VarRef v)) in extract_app env sg mle mlt extract_var args | Int i -> assert (args = []); MLuint i | Ind _ | Prod _ | Sort _ -> assert false @@ -746,10 +745,10 @@ and extract_cst_app env sg mle mlt kn args = (* Second, is the resulting type compatible with the expected type [mlt] ? *) let magic2 = needs_magic (a, mlt) in (* The internal head receives a magic if [magic1] *) - let head = put_magic_if magic1 (MLglob (ConstRef kn)) in + let head = put_magic_if magic1 (MLglob (GlobRef.ConstRef kn)) in (* Now, the extraction of the arguments. *) let s_full = type2signature env (snd schema) in - let s_full = sign_with_implicits (ConstRef kn) s_full 0 in + let s_full = sign_with_implicits (GlobRef.ConstRef kn) s_full 0 in let s = sign_no_final_keeps s_full in let ls = List.length s in let la = List.length args in @@ -762,7 +761,7 @@ and extract_cst_app env sg mle mlt kn args = (* for better optimisations later, we discard dependent args of projections and replace them by fake args that will be removed during final pretty-print. *) - let l,l' = List.chop (projection_arity (ConstRef kn)) mla in + let l,l' = List.chop (projection_arity (GlobRef.ConstRef kn)) mla in if not (List.is_empty l') then (List.map (fun _ -> MLexn "Proj Args") l) @ l' else mla with e when CErrors.noncritical e -> mla @@ -807,11 +806,11 @@ and extract_cons_app env sg mle mlt (((kn,i) as ip,j) as cp) args = let nb_tvars = List.length oi.ip_vars and types = List.map (expand env) oi.ip_types.(j-1) in let list_tvar = List.map (fun i -> Tvar i) (List.interval 1 nb_tvars) in - let type_cons = type_recomp (types, Tglob (IndRef ip, list_tvar)) in + let type_cons = type_recomp (types, Tglob (GlobRef.IndRef ip, list_tvar)) in let type_cons = instantiation (nb_tvars, type_cons) in (* Then, the usual variables [s], [ls], [la], ... *) let s = List.map (type2sign env) types in - let s = sign_with_implicits (ConstructRef cp) s params_nb in + let s = sign_with_implicits (GlobRef.ConstructRef cp) s params_nb in let ls = List.length s in let la = List.length args in assert (la <= ls + params_nb); @@ -831,8 +830,8 @@ and extract_cons_app env sg mle mlt (((kn,i) as ip,j) as cp) args = | Tglob (_,l) -> List.map type_simpl l | _ -> assert false in - let typ = Tglob(IndRef ip, typeargs) in - put_magic_if magic1 (MLcons (typ, ConstructRef cp, mla)) + let typ = Tglob(GlobRef.IndRef ip, typeargs) in + put_magic_if magic1 (MLcons (typ, GlobRef.ConstructRef cp, mla)) in (* Different situations depending of the number of arguments: *) if la < params_nb then @@ -880,11 +879,11 @@ and extract_case env sg mle ((kn,i) as ip,c,br) mlt = let oi = mi.ind_packets.(i) in let metas = Array.init (List.length oi.ip_vars) new_meta in (* The extraction of the head. *) - let type_head = Tglob (IndRef ip, Array.to_list metas) in + let type_head = Tglob (GlobRef.IndRef ip, Array.to_list metas) in let a = extract_term env sg mle type_head c [] in (* The extraction of each branch. *) let extract_branch i = - let r = ConstructRef (ip,i+1) in + let r = GlobRef.ConstructRef (ip,i+1) in (* The types of the arguments of the corresponding constructor. *) let f t = type_subst_vect metas (expand env t) in let l = List.map f oi.ip_types.(i) in @@ -909,7 +908,7 @@ and extract_case env sg mle ((kn,i) as ip,c,br) mlt = else (* Standard case: we apply [extract_branch]. *) let typs = List.map type_simpl (Array.to_list metas) in - let typ = Tglob (IndRef ip,typs) in + let typ = Tglob (GlobRef.IndRef ip,typs) in MLcase (typ, a, Array.init br_size extract_branch) (*s Extraction of a (co)-fixpoint. *) @@ -960,7 +959,7 @@ let extract_std_constant env sg kn body typ = let l,t' = type_decomp (expand env (var2var' t)) in let s = List.map (type2sign env) l in (* Check for user-declared implicit information *) - let s = sign_with_implicits (ConstRef kn) s 0 in + let s = sign_with_implicits (GlobRef.ConstRef kn) s 0 in (* Decomposing the top level lambdas of [body]. If there isn't enough, it's ok, as long as remaining args aren't to be pruned (and initial lambdas aren't to be all @@ -1015,7 +1014,7 @@ let extract_axiom env sg kn typ = let l,_ = type_decomp (expand env (var2var' t)) in let s = List.map (type2sign env) l in (* Check for user-declared implicit information *) - let s = sign_with_implicits (ConstRef kn) s 0 in + let s = sign_with_implicits (GlobRef.ConstRef kn) s 0 in type_expunge_from_sign env s t let extract_fixpoint env sg vkn (fi,ti,ci) = @@ -1034,10 +1033,10 @@ let extract_fixpoint env sg vkn (fi,ti,ci) = terms.(i) <- e; types.(i) <- t; with SingletonInductiveBecomesProp id -> - error_singleton_become_prop id (Some (ConstRef vkn.(i))) + error_singleton_become_prop id (Some (GlobRef.ConstRef vkn.(i))) done; current_fixpoints := []; - Dfix (Array.map (fun kn -> ConstRef kn) vkn, terms, types) + Dfix (Array.map (fun kn -> GlobRef.ConstRef kn) vkn, terms, types) (** Because of automatic unboxing the easy way [mk_def c] on the constant body of primitive projections doesn't work. We pretend @@ -1095,7 +1094,7 @@ let fake_match_projection env p = let extract_constant env kn cb = let sg = Evd.from_env env in - let r = ConstRef kn in + let r = GlobRef.ConstRef kn in let typ = EConstr.of_constr cb.const_type in let warn_info () = if not (is_custom r) then add_info_axiom r in let warn_log () = if not (constant_has_body cb) then add_log_axiom r @@ -1150,11 +1149,11 @@ let extract_constant env kn cb = if access_opaque () then mk_def (get_opaque env c) else mk_ax ()) with SingletonInductiveBecomesProp id -> - error_singleton_become_prop id (Some (ConstRef kn)) + error_singleton_become_prop id (Some (GlobRef.ConstRef kn)) let extract_constant_spec env kn cb = let sg = Evd.from_env env in - let r = ConstRef kn in + let r = GlobRef.ConstRef kn in let typ = EConstr.of_constr cb.const_type in try match flag_of_type env sg typ with @@ -1173,7 +1172,7 @@ let extract_constant_spec env kn cb = let t = snd (record_constant_type env sg kn (Some typ)) in Sval (r, type_expunge env t) with SingletonInductiveBecomesProp id -> - error_singleton_become_prop id (Some (ConstRef kn)) + error_singleton_become_prop id (Some (GlobRef.ConstRef kn)) let extract_with_type env sg c = try @@ -1205,7 +1204,7 @@ let extract_inductive env kn = let ind = extract_ind env kn in add_recursors env kn; let f i j l = - let implicits = implicits_of_global (ConstructRef ((kn,i),j+1)) in + let implicits = implicits_of_global (GlobRef.ConstructRef ((kn,i),j+1)) in let rec filter i = function | [] -> [] | t::l -> diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml index a62fb1a728..e4efbcff0c 100644 --- a/plugins/extraction/haskell.ml +++ b/plugins/extraction/haskell.ml @@ -14,7 +14,6 @@ open Pp open CErrors open Util open Names -open Globnames open Table open Miniml open Mlutil @@ -110,7 +109,7 @@ let rec pp_type par vl t = (try Id.print (List.nth vl (pred i)) with Failure _ -> (str "a" ++ int i)) | Tglob (r,[]) -> pp_global Type r - | Tglob (IndRef(kn,0),l) + | Tglob (GlobRef.IndRef(kn,0),l) when not (keep_singleton ()) && MutInd.equal kn (mk_ind "Coq.Init.Specif" "sig") -> pp_type true vl (List.hd l) | Tglob (r,l) -> @@ -271,7 +270,7 @@ let pp_logical_ind packet = prvect_with_sep spc Id.print packet.ip_consnames) let pp_singleton kn packet = - let name = pp_global Type (IndRef (kn,0)) in + let name = pp_global Type (GlobRef.IndRef (kn,0)) in let l = rename_tvars keywords packet.ip_vars in hov 2 (str "type " ++ name ++ spc () ++ prlist_with_sep spc Id.print l ++ @@ -291,14 +290,14 @@ let pp_one_ind ip pl cv = (fun () -> (str " ")) (pp_type true pl) l)) in str (if Array.is_empty cv then "type " else "data ") ++ - pp_global Type (IndRef ip) ++ + pp_global Type (GlobRef.IndRef ip) ++ prlist_strict (fun id -> str " " ++ pr_lower_id id) pl ++ str " =" ++ if Array.is_empty cv then str " () -- empty inductive" else (fnl () ++ str " " ++ v 0 (str " " ++ prvect_with_sep (fun () -> fnl () ++ str "| ") pp_constructor - (Array.mapi (fun i c -> ConstructRef (ip,i+1),c) cv))) + (Array.mapi (fun i c -> GlobRef.ConstructRef (ip,i+1),c) cv))) let rec pp_ind first kn i ind = if i >= Array.length ind.ind_packets then @@ -306,7 +305,7 @@ let rec pp_ind first kn i ind = else let ip = (kn,i) in let p = ind.ind_packets.(i) in - if is_custom (IndRef (kn,i)) then pp_ind first kn (i+1) ind + if is_custom (GlobRef.IndRef (kn,i)) then pp_ind first kn (i+1) ind else if p.ip_logical then pp_logical_ind p ++ pp_ind first kn (i+1) ind diff --git a/plugins/extraction/json.ml b/plugins/extraction/json.ml index f88d29e9ed..fba6b7c780 100644 --- a/plugins/extraction/json.ml +++ b/plugins/extraction/json.ml @@ -1,7 +1,6 @@ open Pp open Util open Names -open Globnames open Table open Miniml open Mlutil @@ -200,10 +199,10 @@ and json_function env t = let json_ind ip pl cv = json_dict [ ("what", json_str "decl:ind"); - ("name", json_global Type (IndRef ip)); + ("name", json_global Type (GlobRef.IndRef ip)); ("argnames", json_list (List.map json_id pl)); ("constructors", json_listarr (Array.mapi (fun idx c -> json_dict [ - ("name", json_global Cons (ConstructRef (ip, idx+1))); + ("name", json_global Cons (GlobRef.ConstructRef (ip, idx+1))); ("argtypes", json_list (List.map (json_type pl) c)) ]) cv)) ] diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index a8d766cd6e..2d5872718f 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -12,7 +12,6 @@ open Util open Names open Libnames -open Globnames open Table open Miniml (*i*) @@ -668,11 +667,11 @@ let is_regular_match br = | _ -> raise Impossible in let ind = match get_r br.(0) with - | ConstructRef (ind,_) -> ind + | GlobRef.ConstructRef (ind,_) -> ind | _ -> raise Impossible in let is_ref i tr = match get_r tr with - | ConstructRef (ind', j) -> eq_ind ind ind' && Int.equal j (i + 1) + | GlobRef.ConstructRef (ind', j) -> eq_ind ind ind' && Int.equal j (i + 1) | _ -> false in Array.for_all_i is_ref 0 br @@ -819,11 +818,11 @@ let rec tmp_head_lams = function *) let rec ast_glob_subst s t = match t with - | MLapp ((MLglob ((ConstRef kn) as refe)) as f, a) -> + | MLapp ((MLglob ((GlobRef.ConstRef kn) as refe)) as f, a) -> let a = List.map (fun e -> tmp_head_lams (ast_glob_subst s e)) a in (try linear_beta_red a (Refmap'.find refe s) with Not_found -> MLapp (f, a)) - | MLglob ((ConstRef kn) as refe) -> + | MLglob ((GlobRef.ConstRef kn) as refe) -> (try Refmap'.find refe s with Not_found -> t) | _ -> ast_map (ast_glob_subst s) t @@ -1504,7 +1503,7 @@ open Declareops let inline_test r t = if not (auto_inline ()) then false else - let c = match r with ConstRef c -> c | _ -> assert false in + let c = match r with GlobRef.ConstRef c -> c | _ -> assert false in let has_body = try constant_has_body (Global.lookup_constant c) with Not_found -> false @@ -1534,7 +1533,7 @@ let manual_inline_set = Cset_env.empty let manual_inline = function - | ConstRef c -> Cset_env.mem c manual_inline_set + | GlobRef.ConstRef c -> Cset_env.mem c manual_inline_set | _ -> false (* If the user doesn't say he wants to keep [t], we inline in two cases: diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml index bded698ea7..6b1eef7abb 100644 --- a/plugins/extraction/modutil.ml +++ b/plugins/extraction/modutil.ml @@ -10,7 +10,6 @@ open Names open ModPath -open Globnames open CErrors open Util open Miniml @@ -42,7 +41,7 @@ let se_iter do_decl do_spec do_mp = let mp_w = List.fold_left (fun mp l -> MPdot(mp,Label.of_id l)) mp_mt idl' in - let r = ConstRef (Constant.make2 mp_w (Label.of_id l')) in + let r = GlobRef.ConstRef (Constant.make2 mp_w (Label.of_id l')) in mt_iter mt; do_spec (Stype(r,l,Some t)) | MTwith (mt,ML_With_module(idl,mp))-> let mp_mt = msid_of_mt mt in @@ -113,12 +112,12 @@ let ast_iter_references do_term do_cons do_type a = let ind_iter_references do_term do_cons do_type kn ind = let type_iter = type_iter_references do_type in - let cons_iter cp l = do_cons (ConstructRef cp); List.iter type_iter l in + let cons_iter cp l = do_cons (GlobRef.ConstructRef cp); List.iter type_iter l in let packet_iter ip p = - do_type (IndRef ip); + do_type (GlobRef.IndRef ip); if lang () == Ocaml then (match ind.ind_equiv with - | Miniml.Equiv kne -> do_type (IndRef (MutInd.make1 kne, snd ip)); + | Miniml.Equiv kne -> do_type (GlobRef.IndRef (MutInd.make1 kne, snd ip)); | _ -> ()); Array.iteri (fun j -> cons_iter (ip,j+1)) p.ip_types in @@ -258,7 +257,7 @@ let dfix_to_mlfix rv av i = let s = make_subst (Array.length rv - 1) Refmap'.empty in let rec subst n t = match t with - | MLglob ((ConstRef kn) as refe) -> + | MLglob ((GlobRef.ConstRef kn) as refe) -> (try MLrel (n + (Refmap'.find refe s)) with Not_found -> t) | _ -> ast_map_lift subst n t in @@ -309,7 +308,7 @@ and optim_me to_appear s = function For non-library extraction, we recompute a minimal set of dependencies for first-level definitions (no module pruning yet). *) -let base_r = function +let base_r = let open GlobRef in function | ConstRef c as r -> r | IndRef (kn,_) -> IndRef (kn,0) | ConstructRef ((kn,_),_) -> IndRef (kn,0) @@ -327,7 +326,7 @@ let reset_needed, add_needed, add_needed_mp, found_needed, is_needed = Refset'.mem r !needed || MPset.mem (modpath_of_r r) !needed_mps)) let declared_refs = function - | Dind (kn,_) -> [IndRef (kn,0)] + | Dind (kn,_) -> [GlobRef.IndRef (kn,0)] | Dtype (r,_,_) -> [r] | Dterm (r,_,_) -> [r] | Dfix (rv,_,_) -> Array.to_list rv diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index 21a8b8e5fb..75fb35192b 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -15,7 +15,6 @@ open CErrors open Util open Names open ModPath -open Globnames open Table open Miniml open Mlutil @@ -142,7 +141,7 @@ let get_infix r = let s = find_custom r in String.sub s 1 (String.length s - 2) -let get_ind = function +let get_ind = let open GlobRef in function | IndRef _ as r -> r | ConstructRef (ind,_) -> IndRef ind | _ -> assert false @@ -166,7 +165,7 @@ let pp_type par vl t = | Tglob (r,[a1;a2]) when is_infix r -> pp_par par (pp_rec true a1 ++ str (get_infix r) ++ pp_rec true a2) | Tglob (r,[]) -> pp_global Type r - | Tglob (IndRef(kn,0),l) + | Tglob (GlobRef.IndRef(kn,0),l) when not (keep_singleton ()) && MutInd.equal kn (mk_ind "Coq.Init.Specif" "sig") -> pp_tuple_light pp_rec l | Tglob (r,l) -> @@ -467,7 +466,7 @@ let pp_Dfix (rv,c,t) = let pp_equiv param_list name = function | NoEquiv, _ -> mt () | Equiv kn, i -> - str " = " ++ pp_parameters param_list ++ pp_global Type (IndRef (MutInd.make1 kn,i)) + str " = " ++ pp_parameters param_list ++ pp_global Type (GlobRef.IndRef (MutInd.make1 kn,i)) | RenEquiv ren, _ -> str " = " ++ pp_parameters param_list ++ str (ren^".") ++ name @@ -494,7 +493,7 @@ let pp_logical_ind packet = fnl () let pp_singleton kn packet = - let name = pp_global Type (IndRef (kn,0)) in + let name = pp_global Type (GlobRef.IndRef (kn,0)) in let l = rename_tvars keywords packet.ip_vars in hov 2 (str "type " ++ pp_parameters l ++ name ++ str " =" ++ spc () ++ pp_type false l (List.hd packet.ip_types.(0)) ++ fnl () ++ @@ -502,7 +501,7 @@ let pp_singleton kn packet = Id.print packet.ip_consnames.(0))) let pp_record kn fields ip_equiv packet = - let ind = IndRef (kn,0) in + let ind = GlobRef.IndRef (kn,0) in let name = pp_global Type ind in let fieldnames = pp_fields ind fields in let l = List.combine fieldnames packet.ip_types.(0) in @@ -525,13 +524,13 @@ let pp_ind co kn ind = let nextkwd = fnl () ++ str "and " in let names = Array.mapi (fun i p -> if p.ip_logical then mt () else - pp_global Type (IndRef (kn,i))) + pp_global Type (GlobRef.IndRef (kn,i))) ind.ind_packets in let cnames = Array.mapi (fun i p -> if p.ip_logical then [||] else - Array.mapi (fun j _ -> pp_global Cons (ConstructRef ((kn,i),j+1))) + Array.mapi (fun j _ -> pp_global Cons (GlobRef.ConstructRef ((kn,i),j+1))) p.ip_types) ind.ind_packets in @@ -541,7 +540,7 @@ let pp_ind co kn ind = let ip = (kn,i) in let ip_equiv = ind.ind_equiv, i in let p = ind.ind_packets.(i) in - if is_custom (IndRef ip) then pp (i+1) kwd + if is_custom (GlobRef.IndRef ip) then pp (i+1) kwd else if p.ip_logical then pp_logical_ind p ++ pp (i+1) kwd else kwd ++ (if co then pp_coind p.ip_vars names.(i) else mt ()) ++ @@ -672,7 +671,7 @@ and pp_module_type params = function let mp_w = List.fold_left (fun mp l -> MPdot(mp,Label.of_id l)) mp_mt idl' in - let r = ConstRef (Constant.make2 mp_w (Label.of_id l)) in + let r = GlobRef.ConstRef (Constant.make2 mp_w (Label.of_id l)) in push_visible mp_mt []; let pp_w = str " with type " ++ ids ++ pp_global Type r in pop_visible(); diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index b09a81e1c8..96a3d00dc2 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -30,12 +30,12 @@ module Refset' = GlobRef.Set_env (*S Utilities about [module_path] and [kernel_names] and [global_reference] *) -let occur_kn_in_ref kn = function +let occur_kn_in_ref kn = let open GlobRef in function | IndRef (kn',_) | ConstructRef ((kn',_),_) -> MutInd.equal kn kn' | ConstRef _ | VarRef _ -> false -let repr_of_r = function +let repr_of_r = let open GlobRef in function | ConstRef kn -> Constant.repr2 kn | IndRef (kn,_) | ConstructRef ((kn,_),_) -> MutInd.repr2 kn @@ -151,7 +151,7 @@ let init_inductive_kinds () = inductive_kinds := Mindmap_env.empty let add_inductive_kind kn k = inductive_kinds := Mindmap_env.add kn k !inductive_kinds let is_coinductive r = - let kn = match r with + let kn = let open GlobRef in match r with | ConstructRef ((kn,_),_) -> kn | IndRef (kn,_) -> kn | _ -> assert false @@ -164,7 +164,7 @@ let is_coinductive_type = function | _ -> false let get_record_fields r = - let kn = match r with + let kn = let open GlobRef in match r with | ConstructRef ((kn,_),_) -> kn | IndRef (kn,_) -> kn | _ -> assert false @@ -201,7 +201,7 @@ let add_recursors env ind = mib.mind_packets let is_recursor = function - | ConstRef c -> KNset.mem (Constant.canonical c) !recursors + | GlobRef.ConstRef c -> KNset.mem (Constant.canonical c) !recursors | _ -> false (*s Record tables. *) @@ -210,7 +210,7 @@ let is_recursor = function let projs = ref (GlobRef.Map.empty : (inductive*int) GlobRef.Map.t) let init_projs () = projs := GlobRef.Map.empty -let add_projection n kn ip = projs := GlobRef.Map.add (ConstRef kn) (ip,n) !projs +let add_projection n kn ip = projs := GlobRef.Map.add (GlobRef.ConstRef kn) (ip,n) !projs let is_projection r = GlobRef.Map.mem r !projs let projection_arity r = snd (GlobRef.Map.find r !projs) let projection_info r = GlobRef.Map.find r !projs @@ -264,6 +264,7 @@ let safe_basename_of_global r = with Not_found -> anomaly (Pp.str "Inductive object unknown to extraction and not globally visible.") in + let open GlobRef in match r with | ConstRef kn -> Label.to_id (Constant.label kn) | IndRef (kn,0) -> Label.to_id (MutInd.label kn) @@ -286,7 +287,7 @@ let safe_pr_global r = str (string_of_global r) let safe_pr_long_global r = try Printer.pr_global r with Not_found -> match r with - | ConstRef kn -> + | GlobRef.ConstRef kn -> let mp,l = Constant.repr2 kn in str ((ModPath.to_string mp)^"."^(Label.to_string l)) | _ -> assert false @@ -658,7 +659,7 @@ let extraction_inline b l = let refs = List.map Smartlocate.global_with_alias l in List.iter (fun r -> match r with - | ConstRef _ -> () + | GlobRef.ConstRef _ -> () | _ -> error_constant r) refs; Lib.add_anonymous_leaf (inline_extraction (b,refs)) @@ -666,7 +667,7 @@ let extraction_inline b l = let print_extraction_inline () = let (i,n)= !inline_table in - let i'= Refset'.filter (function ConstRef _ -> true | _ -> false) i in + let i'= Refset'.filter (function GlobRef.ConstRef _ -> true | _ -> false) i in (str "Extraction Inline:" ++ fnl () ++ Refset'.fold (fun r p -> @@ -823,8 +824,8 @@ let indref_of_match pv = if Array.is_empty pv then raise Not_found; let (_,pat,_) = pv.(0) in match pat with - | Pusual (ConstructRef (ip,_)) -> IndRef ip - | Pcons (ConstructRef (ip,_),_) -> IndRef ip + | Pusual (GlobRef.ConstructRef (ip,_)) -> GlobRef.IndRef ip + | Pcons (GlobRef.ConstructRef (ip,_),_) -> GlobRef.IndRef ip | _ -> raise Not_found let is_custom_match pv = @@ -852,9 +853,9 @@ let extract_constant_inline inline r ids s = check_inside_section (); let g = Smartlocate.global_with_alias r in match g with - | ConstRef kn -> + | GlobRef.ConstRef kn -> let env = Global.env () in - let typ, _ = Typeops.type_of_global_in_context env (ConstRef kn) in + let typ, _ = Typeops.type_of_global_in_context env (GlobRef.ConstRef kn) in let typ = Reduction.whd_all env typ in if Reduction.is_arity env typ then begin @@ -871,7 +872,7 @@ let extract_inductive r s l optstr = let g = Smartlocate.global_with_alias r in Dumpglob.add_glob ?loc:r.CAst.loc g; match g with - | IndRef ((kn,i) as ip) -> + | GlobRef.IndRef ((kn,i) as ip) -> let mib = Global.lookup_mind kn in let n = Array.length mib.mind_packets.(i).mind_consnames in if not (Int.equal n (List.length l)) then error_nb_cons (); @@ -881,7 +882,7 @@ let extract_inductive r s l optstr = optstr; List.iteri (fun j s -> - let g = ConstructRef (ip,succ j) in + let g = GlobRef.ConstructRef (ip,succ j) in Lib.add_anonymous_leaf (inline_extraction (true,[g])); Lib.add_anonymous_leaf (in_customs (g,[],s))) l | _ -> error_inductive g diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml index 2d5ea9536c..fb363b9393 100644 --- a/plugins/firstorder/formula.ml +++ b/plugins/firstorder/formula.ml @@ -15,7 +15,6 @@ open EConstr open Vars open Util open Declarations -open Globnames module RelDecl = Context.Rel.Declaration @@ -124,7 +123,7 @@ type side = Hyp | Concl | Hint let no_atoms = (false,{positive=[];negative=[]}) -let dummy_id=VarRef (Id.of_string "_") (* "_" cannot be parsed *) +let dummy_id=GlobRef.VarRef (Id.of_string "_") (* "_" cannot be parsed *) let build_atoms env sigma metagen side cciterm = let trivial =ref false diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml index bdf339a488..e134562702 100644 --- a/plugins/firstorder/ground.ml +++ b/plugins/firstorder/ground.ml @@ -15,12 +15,11 @@ open Rules open Instances open Tacmach.New open Tacticals.New -open Globnames let update_flags ()= let open TransparentState in let f accu coe = match coe.Classops.coe_value with - | ConstRef kn -> { accu with tr_cst = Names.Cpred.remove kn accu.tr_cst } + | Names.GlobRef.ConstRef kn -> { accu with tr_cst = Names.Cpred.remove kn accu.tr_cst } | _ -> accu in let flags = List.fold_left f TransparentState.full (Classops.coercions ()) in diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index f3a16cd13e..79386f7ac9 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -20,7 +20,6 @@ open Proofview.Notations open Termops open Formula open Sequent -open Globnames module NamedDecl = Context.Named.Declaration @@ -48,7 +47,7 @@ let wrap n b continue seq = List.exists (occur_var_in_decl env sigma id) ctx then (aux (i-1) q (nd::ctx)) else - add_formula env sigma Hyp (VarRef id) (NamedDecl.get_type nd) (aux (i-1) q (nd::ctx)) in + add_formula env sigma Hyp (GlobRef.VarRef id) (NamedDecl.get_type nd) (aux (i-1) q (nd::ctx)) in let seq1=aux n nc [] in let seq2=if b then add_formula env sigma Concl dummy_id (pf_concl gls) seq1 else seq1 in @@ -56,7 +55,7 @@ let wrap n b continue seq = end let clear_global=function - VarRef id-> clear [id] + | GlobRef.VarRef id-> clear [id] | _->tclIDTAC (* connection rules *) diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index f773b2c39e..08298bf02c 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -14,7 +14,6 @@ open Tacticals open Tactics open Indfun_common open Libnames -open Globnames open Context.Rel.Declaration module RelDecl = Context.Rel.Declaration @@ -79,7 +78,7 @@ let do_observe_tac s tac g = with reraise -> let reraise = CErrors.push reraise in if not (Stack.is_empty debug_queue) - then print_debug_queue (Some (fst (ExplainErr.process_vernac_interp_error reraise))); + then print_debug_queue (Some (fst reraise)); iraise reraise let observe_tac_stream s tac g = @@ -992,7 +991,7 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num (* Pp.msgnl (str "lemma type (2) " ++ Printer.pr_lconstr_env (Global.env ()) evd lemma_type); *) let info = Lemmas.Info.make ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) - ~kind:(Decl_kinds.Proof Decl_kinds.Theorem) () in + ~kind:(Decls.(IsProof Theorem)) () in let lemma = Lemmas.start_lemma (*i The next call to mk_equation_id is valid since we are constructing the lemma @@ -1027,7 +1026,7 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a update_Function {finfos with equation_lemma = Some (match Nametab.locate (qualid_of_ident equation_lemma_id) with - ConstRef c -> c + GlobRef.ConstRef c -> c | _ -> CErrors.anomaly (Pp.str "Not a constant.") ) } diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 3bab750534..d34faa22fa 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -84,7 +84,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let env_with_params_and_predicates = List.fold_right Environ.push_named new_predicates env_with_params in let rel_as_kn = fst (match princ_type_info.indref with - | Some (Globnames.IndRef ind) -> ind + | Some (GlobRef.IndRef ind) -> ind | _ -> user_err Pp.(str "Not a valid predicate") ) in @@ -369,9 +369,9 @@ let generate_functional_principle (evd: Evd.evar_map ref) let ce = Declare.definition_entry ~univs value in ignore( Declare.declare_constant - name - (Declare.DefinitionEntry ce, - Decl_kinds.IsDefinition (Decl_kinds.Scheme)) + ~name + ~kind:Decls.(IsDefinition Scheme) + (Declare.DefinitionEntry ce) ); Declare.definition_message name; names := name :: !names @@ -387,7 +387,7 @@ let generate_functional_principle (evd: Evd.evar_map ref) Don't forget to close the goal if an error is raised !!!! *) let uctx = Evd.evar_universe_context sigma in - save new_princ_name entry ~hook uctx (DeclareDef.Global Declare.ImportDefaultBehavior) Decl_kinds.(Proof Theorem) + save new_princ_name entry ~hook uctx (DeclareDef.Global Declare.ImportDefaultBehavior) Decls.(IsProof Theorem) with e when CErrors.noncritical e -> raise (Defining_principle e) @@ -637,8 +637,9 @@ let build_scheme fas = (fun (princ_id,_,_) def_entry -> ignore (Declare.declare_constant - princ_id - (Declare.DefinitionEntry def_entry,Decl_kinds.IsProof Decl_kinds.Theorem)); + ~name:princ_id + ~kind:Decls.(IsProof Theorem) + (Declare.DefinitionEntry def_entry)); Declare.definition_message princ_id ) fas diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index e20d010c71..5f859b3e4b 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -227,7 +227,6 @@ END { let warning_error names e = - let (e, _) = ExplainErr.process_vernac_interp_error (e, Exninfo.null) in match e with | Building_graph e -> let names = pr_enum Libnames.pr_qualid names in diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index bb4e745fe9..6dc01a9f8f 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -6,7 +6,6 @@ open Context open Vars open Glob_term open Glob_ops -open Globnames open Indfun_common open CErrors open Util @@ -312,7 +311,7 @@ let build_constructors_of_type ind' argl = let npar = mib.Declarations.mind_nparams in Array.mapi (fun i _ -> let construct = ind',i+1 in - let constructref = ConstructRef(construct) in + let constructref = GlobRef.ConstructRef(construct) in let _implicit_positions_of_cst = Impargs.implicits_of_global constructref in @@ -328,7 +327,7 @@ let build_constructors_of_type ind' argl = List.make npar (mkGHole ()) @ argl in let pat_as_term = - mkGApp(mkGRef (ConstructRef(ind',i+1)),argl) + mkGApp(mkGRef (GlobRef.ConstructRef(ind',i+1)),argl) in cases_pattern_of_glob_constr (Global.env()) Anonymous pat_as_term ) @@ -438,7 +437,7 @@ let rec pattern_to_term_and_type env typ = DAst.with_val (function let patl_as_term = List.map2 (pattern_to_term_and_type env) (List.rev cs_args_types) patternl in - mkGApp(mkGRef(ConstructRef constr), + mkGApp(mkGRef(GlobRef.ConstructRef constr), implicit_args@patl_as_term ) ) @@ -992,7 +991,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = in mkGProd(n,t,new_b),id_to_exclude with Continue -> - let jmeq = Globnames.IndRef (fst (EConstr.destInd Evd.empty (jmeq ()))) in + let jmeq = GlobRef.IndRef (fst (EConstr.destInd Evd.empty (jmeq ()))) in let ty',ctx = Pretyping.understand env (Evd.from_env env) ty in let ind,args' = Inductiveops.find_inductive env Evd.(from_env env) ty' in let mib,_ = Global.lookup_inductive (fst ind) in @@ -1001,7 +1000,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = ((Util.List.chop nparam args')) in let rt_typ = DAst.make @@ - GApp(DAst.make @@ GRef (Globnames.IndRef (fst ind),None), + GApp(DAst.make @@ GRef (GlobRef.IndRef (fst ind),None), (List.map (fun p -> Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_env env) @@ -1506,7 +1505,7 @@ let do_build_inductive let _time2 = System.get_time () in try with_full_print - (Flags.silently (ComInductive.do_mutual_inductive ~template:(Some false) None rel_inds false ~poly:false false ~uniform:ComInductive.NonUniformParameters)) + (Flags.silently (ComInductive.do_mutual_inductive ~template:(Some false) None rel_inds ~cumulative:false ~poly:false ~private_ind:false ~uniform:ComInductive.NonUniformParameters)) Declarations.Finite with | UserError(s,msg) as e -> diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index 7b758da8e8..d36d86a65b 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -375,7 +375,7 @@ let rec pattern_to_term pt = DAst.with_val (function let patl_as_term = List.map pattern_to_term patternl in - mkGApp(mkGRef(Globnames.ConstructRef constr), + mkGApp(mkGRef(GlobRef.ConstructRef constr), implicit_args@patl_as_term ) ) pt diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index d305a58ccc..99efe3e5e2 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -8,7 +8,6 @@ open EConstr open Pp open Indfun_common open Libnames -open Globnames open Glob_term open Declarations open Tactypes @@ -59,7 +58,7 @@ let functional_induction with_clean c princl pat = let princ,g' = (* then we get the principle *) try let g',princ = - Tacmach.pf_eapply (Evd.fresh_global) g (Globnames.ConstRef (Option.get princ_option )) in + Tacmach.pf_eapply (Evd.fresh_global) g (GlobRef.ConstRef (Option.get princ_option )) in princ,g' with Option.IsNone -> (*i If there is not default lemma defined then, @@ -244,9 +243,6 @@ let prepare_body ((name,_,args,types,_),_) rt = let fun_args,rt' = chop_rlambda_n n rt in (fun_args,rt') -let process_vernac_interp_error e = - fst (ExplainErr.process_vernac_interp_error (e, Exninfo.null)) - let warn_funind_cannot_build_inversion = CWarnings.create ~name:"funind-cannot-build-inversion" ~category:"funind" (fun e' -> strbrk "Cannot build inversion information" ++ @@ -293,11 +289,9 @@ let derive_inversion fix_names = fix_names_as_constant lind; with e when CErrors.noncritical e -> - let e' = process_vernac_interp_error e in - warn_funind_cannot_build_inversion e' + warn_funind_cannot_build_inversion e with e when CErrors.noncritical e -> - let e' = process_vernac_interp_error e in - warn_funind_cannot_build_inversion e' + warn_funind_cannot_build_inversion e let warn_cannot_define_graph = CWarnings.create ~name:"funind-cannot-define-graph" ~category:"funind" @@ -310,17 +304,13 @@ let warn_cannot_define_principle = h 1 names ++ error) let warning_error names e = - let e = process_vernac_interp_error e in let e_explain e = match e with | ToShow e -> - let e = process_vernac_interp_error e in spc () ++ CErrors.print e | _ -> if do_observe () - then - let e = process_vernac_interp_error e in - (spc () ++ CErrors.print e) + then (spc () ++ CErrors.print e) else mt () in match e with @@ -333,7 +323,6 @@ let warning_error names e = | _ -> raise e let error_error names e = - let e = process_vernac_interp_error e in let e_explain e = match e with | ToShow e -> spc () ++ CErrors.print e @@ -419,7 +408,7 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp ~name:fname ~poly:false ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) - ~kind:Decl_kinds.Definition pl + ~kind:Decls.Definition pl bl None body (Some ret_type); let evd,rev_pconstants = List.fold_left @@ -846,7 +835,7 @@ let make_graph (f_ref : GlobRef.t) = let sigma = Evd.from_env env in let c,c_body = match f_ref with - | ConstRef c -> + | GlobRef.ConstRef c -> begin try c,Global.lookup_constant c with Not_found -> raise (UserError (None,str "Cannot find " ++ Printer.pr_leconstr_env env sigma (mkConst c)) ) diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 56ed406e2f..a119586f7b 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -2,7 +2,6 @@ open Names open Pp open Constr open Libnames -open Globnames open Refiner let mk_prefix pre id = Id.of_string (pre^(Id.to_string id)) @@ -31,12 +30,12 @@ let locate qid = Nametab.locate qid let locate_ind ref = match locate ref with - | IndRef x -> x + | GlobRef.IndRef x -> x | _ -> raise Not_found let locate_constant ref = match locate ref with - | ConstRef x -> x + | GlobRef.ConstRef x -> x | _ -> raise Not_found @@ -123,21 +122,19 @@ open DeclareDef let definition_message = Declare.definition_message -let save id const ?hook uctx scope kind = +let save name const ?hook uctx scope kind = let fix_exn = Future.fix_exn_of const.Proof_global.proof_entry_body in let r = match scope with | Discharge -> - let k = Kindops.logical_kind_of_goal_kind kind in - let c = SectionLocalDef const in - let _ = declare_variable id (Lib.cwd(), c, k) in - VarRef id + let c = SectionLocalDef const in + let () = declare_variable ~name ~kind c in + GlobRef.VarRef name | Global local -> - let k = Kindops.logical_kind_of_goal_kind kind in - let kn = declare_constant id ~local (Declare.DefinitionEntry const, k) in - ConstRef kn + let kn = declare_constant ~name ~kind ~local (DefinitionEntry const) in + GlobRef.ConstRef kn in DeclareDef.Hook.(call ?hook ~fix_exn { S.uctx; obls = []; scope; dref = r }); - definition_message id + definition_message name let with_full_print f a = let old_implicit_args = Impargs.is_implicit_args () @@ -277,7 +274,7 @@ let pr_info env sigma f_info = str "function_constant_type := " ++ (try Printer.pr_lconstr_env env sigma - (fst (Typeops.type_of_global_in_context env (ConstRef f_info.function_constant))) + (fst (Typeops.type_of_global_in_context env (GlobRef.ConstRef f_info.function_constant))) with e when CErrors.noncritical e -> mt ()) ++ fnl () ++ str "equation_lemma := " ++ pr_ocst env sigma f_info.equation_lemma ++ fnl () ++ str "completeness_lemma :=" ++ pr_ocst env sigma f_info.completeness_lemma ++ fnl () ++ @@ -301,7 +298,7 @@ let in_Function : function_info -> Libobject.obj = let find_or_none id = try Some - (match Nametab.locate (qualid_of_ident id) with ConstRef c -> c | _ -> CErrors.anomaly (Pp.str "Not a constant.") + (match Nametab.locate (qualid_of_ident id) with GlobRef.ConstRef c -> c | _ -> CErrors.anomaly (Pp.str "Not a constant.") ) with Not_found -> None @@ -330,7 +327,7 @@ let add_Function is_general f = and sprop_lemma = find_or_none (Nameops.add_suffix f_id "_sind") and graph_ind = match Nametab.locate (qualid_of_ident (mk_rel_id f_id)) - with | IndRef ind -> ind | _ -> CErrors.anomaly (Pp.str "Not an inductive.") + with | GlobRef.IndRef ind -> ind | _ -> CErrors.anomaly (Pp.str "Not an inductive.") in let finfos = { function_constant = f; @@ -435,8 +432,8 @@ let ltof_ref = function () -> (find_reference ["Coq";"Arith";"Wf_nat"] "ltof") let evaluable_of_global_reference r = (* Tacred.evaluable_of_global_reference (Global.env ()) *) match r with - ConstRef sp -> EvalConstRef sp - | VarRef id -> EvalVarRef id + GlobRef.ConstRef sp -> EvalConstRef sp + | GlobRef.VarRef id -> EvalVarRef id | _ -> assert false;; let list_rewrite (rev:bool) (eqs: (EConstr.constr*bool) list) = diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index 45d332031f..a95b1242ac 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -48,7 +48,7 @@ val save -> ?hook:DeclareDef.Hook.t -> UState.t -> DeclareDef.locality - -> Decl_kinds.goal_object_kind + -> Decls.logical_kind -> unit (* [with_full_print f a] applies [f] to [a] in full printing environment. diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 86defb2f2f..d4cc31c0af 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -19,7 +19,6 @@ open Context open EConstr open Vars open Pp -open Globnames open Tacticals open Tactics open Indfun_common @@ -54,9 +53,8 @@ let do_observe_tac s tac g = msgnl (goal ++ fnl () ++ s ++(str " ")++(str "finished")); v with reraise -> let reraise = CErrors.push reraise in - let e = ExplainErr.process_vernac_interp_error reraise in observe (hov 0 (str "observation "++ s++str " raised exception " ++ - CErrors.iprint e ++ str " on goal" ++ fnl() ++ goal )); + CErrors.iprint reraise ++ str " on goal" ++ fnl() ++ goal )); iraise reraise;; let observe_tac s tac g = @@ -94,7 +92,7 @@ let make_eq () = let generate_type evd g_to_f f graph i = (*i we deduce the number of arguments of the function and its returned type from the graph i*) let evd',graph = - Evd.fresh_global (Global.env ()) !evd (Globnames.IndRef (fst (destInd !evd graph))) + Evd.fresh_global (Global.env ()) !evd (GlobRef.IndRef (fst (destInd !evd graph))) in evd:=evd'; let sigma, graph_arity = Typing.type_of (Global.env ()) !evd graph in @@ -166,7 +164,7 @@ let find_induction_principle evd f = match infos.rect_lemma with | None -> raise Not_found | Some rect_lemma -> - let evd',rect_lemma = Evd.fresh_global (Global.env ()) !evd (Globnames.ConstRef rect_lemma) in + let evd',rect_lemma = Evd.fresh_global (Global.env ()) !evd (GlobRef.ConstRef rect_lemma) in let evd',typ = Typing.type_of ~refresh:true (Global.env ()) evd' rect_lemma in evd:=evd'; rect_lemma,typ @@ -805,7 +803,7 @@ let derive_correctness make_scheme (funs: pconstant list) (graphs:inductive list let (typ,_) = lemmas_types_infos.(i) in let info = Lemmas.Info.make ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) - ~kind:(Decl_kinds.Proof Decl_kinds.Theorem) () in + ~kind:(Decls.(IsProof Theorem)) () in let lemma = Lemmas.start_lemma ~name:lem_id ~poly:false @@ -871,7 +869,7 @@ let derive_correctness make_scheme (funs: pconstant list) (graphs:inductive list let lem_id = mk_complete_id f_id in let info = Lemmas.Info.make ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) - ~kind:Decl_kinds.(Proof Theorem) () in + ~kind:Decls.(IsProof Theorem) () in let lemma = Lemmas.start_lemma ~name:lem_id ~poly:false ~info sigma (fst lemmas_types_infos.(i)) in let lemma = fst (Lemmas.by @@ -979,7 +977,7 @@ let error msg = user_err Pp.(str msg) let invfun qhyp f = let f = match f with - | ConstRef f -> f + | GlobRef.ConstRef f -> f | _ -> raise (CErrors.UserError(None,str "Not a function")) in try diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index d38e28c0e7..937118bf57 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -30,7 +30,6 @@ open Tacmach open Tactics open Nametab open Declare -open Decl_kinds open Tacred open Goal open Glob_term @@ -66,9 +65,9 @@ let find_reference sl s = let dp = Names.DirPath.make (List.rev_map Id.of_string sl) in locate (make_qualid dp (Id.of_string s)) -let declare_fun f_id kind ?univs value = +let declare_fun name kind ?univs value = let ce = definition_entry ?univs value (*FIXME *) in - ConstRef(declare_constant f_id (DefinitionEntry ce, kind));; + GlobRef.ConstRef(declare_constant ~name ~kind (DefinitionEntry ce)) let defined lemma = Lemmas.save_lemma_proved ~lemma ~opaque:Proof_global.Transparent ~idopt:None @@ -96,7 +95,7 @@ let type_of_const sigma t = let constant sl s = UnivGen.constr_of_monomorphic_global (find_reference sl s) let const_of_ref = function - ConstRef kn -> kn + GlobRef.ConstRef kn -> kn | _ -> anomaly (Pp.str "ConstRef expected.") (* Generic values *) @@ -196,7 +195,7 @@ let (value_f: Constr.t list -> GlobRef.t -> Constr.t) = let body = EConstr.Unsafe.to_constr body in it_mkLambda_or_LetIn body context -let (declare_f : Id.t -> logical_kind -> Constr.t list -> GlobRef.t -> GlobRef.t) = +let (declare_f : Id.t -> Decls.logical_kind -> Constr.t list -> GlobRef.t -> GlobRef.t) = fun f_id kind input_type fterm_ref -> declare_fun f_id kind (value_f input_type fterm_ref);; @@ -211,7 +210,7 @@ let print_debug_queue b e = begin let lmsg,goal = Stack.pop debug_queue in if b then - Feedback.msg_debug (hov 1 (lmsg ++ (str " raised exception " ++ CErrors.print e) ++ str " on goal" ++ fnl() ++ goal)) + Feedback.msg_debug (hov 1 (lmsg ++ (str " raised exception " ++ CErrors.iprint e) ++ str " on goal" ++ fnl() ++ goal)) else begin Feedback.msg_debug (hov 1 (str " from " ++ lmsg ++ str " on goal"++fnl() ++ goal)); @@ -238,7 +237,7 @@ let do_observe_tac s tac g = with reraise -> let reraise = CErrors.push reraise in if not (Stack.is_empty debug_queue) - then print_debug_queue true (fst (ExplainErr.process_vernac_interp_error reraise)); + then print_debug_queue true reraise; iraise reraise let observe_tac s tac g = @@ -1313,7 +1312,7 @@ let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name (gls_type let na_ref = qualid_of_ident na in let na_global = Smartlocate.global_with_alias na_ref in match na_global with - ConstRef c -> is_opaque_constant c + GlobRef.ConstRef c -> is_opaque_constant c | _ -> anomaly ~label:"equation_lemma" (Pp.str "not a constant.") in let lemma = mkConst (Names.Constant.make1 (Lib.make_kn na)) in @@ -1368,7 +1367,7 @@ let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name (gls_type Lemmas.save_lemma_proved ~lemma ~opaque:opacity ~idopt:None in let info = Lemmas.Info.make ~hook:(DeclareDef.Hook.make hook) - ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) ~kind:(Decl_kinds.Proof Decl_kinds.Lemma) + ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) ~kind:(Decls.(IsProof Lemma)) () in let lemma = Lemmas.start_lemma ~name:na @@ -1411,10 +1410,9 @@ let com_terminate nb_args ctx hook = let start_proof env ctx (tac_start:tactic) (tac_end:tactic) = - let info = Lemmas.Info.make ~hook ~scope:(DeclareDef.Global ImportDefaultBehavior) ~kind:(Proof Lemma) () in + let info = Lemmas.Info.make ~hook ~scope:(DeclareDef.Global ImportDefaultBehavior) ~kind:Decls.(IsProof Lemma) () in let lemma = Lemmas.start_lemma ~name:thm_name ~poly:false (*FIXME*) - ~sign:(Environ.named_context_val env) ~info ctx (EConstr.of_constr (compute_terminate_type nb_args fonctional_ref)) in @@ -1452,17 +1450,17 @@ let start_equation (f:GlobRef.t) (term_f:GlobRef.t) Array.of_list (List.map mkVar x))))); observe_tac (fun _ _ -> str "prove_eq") (cont_tactic x)]) g;; -let com_eqn sign uctx nb_arg eq_name functional_ref f_ref terminate_ref equation_lemma_type = +let com_eqn uctx nb_arg eq_name functional_ref f_ref terminate_ref equation_lemma_type = let open CVars in let opacity = match terminate_ref with - | ConstRef c -> is_opaque_constant c + | GlobRef.ConstRef c -> is_opaque_constant c | _ -> anomaly ~label:"terminate_lemma" (Pp.str "not a constant.") in let evd = Evd.from_ctx uctx in let f_constr = constr_of_monomorphic_global f_ref in let equation_lemma_type = subst1 f_constr equation_lemma_type in - let lemma = Lemmas.start_lemma ~name:eq_name ~poly:false ~sign evd + let lemma = Lemmas.start_lemma ~name:eq_name ~poly:false evd (EConstr.of_constr equation_lemma_type) in let lemma = fst @@ Lemmas.by (Proofview.V82.tactic (start_equation f_ref terminate_ref @@ -1535,7 +1533,7 @@ let recursive_definition ~interactive_proof ~is_mes function_name rec_impls type let term_id = add_suffix function_name "_terminate" in let functional_ref = let univs = Evd.univ_entry ~poly:false evd in - declare_fun functional_id (IsDefinition Decl_kinds.Definition) ~univs res + declare_fun functional_id Decls.(IsDefinition Definition) ~univs res in (* Refresh the global universes, now including those of _F *) let evd = Evd.from_env (Global.env ()) in @@ -1549,14 +1547,13 @@ let recursive_definition ~interactive_proof ~is_mes function_name rec_impls type (* let _ = Pp.msgnl (fun _ _ -> str "relation := " ++ Printer.pr_lconstr_env env_with_pre_rec_args relation) in *) let hook { DeclareDef.Hook.S.uctx ; _ } = let term_ref = Nametab.locate (qualid_of_ident term_id) in - let f_ref = declare_f function_name (IsProof Lemma) arg_types term_ref in + let f_ref = declare_f function_name Decls.(IsProof Lemma) arg_types term_ref in let _ = Extraction_plugin.Table.extraction_inline true [qualid_of_ident term_id] in (* message "start second proof"; *) let stop = (* XXX: What is the correct way to get sign at hook time *) - let sign = Environ.named_context_val Global.(env ()) in try - com_eqn sign uctx (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type); + com_eqn uctx (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type); false with e when CErrors.noncritical e -> begin diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index db8d09b79e..0e38ce575b 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -194,7 +194,7 @@ let string_of_genarg_arg (ArgumentType arg) = let pr_evaluable_reference = function | EvalVarRef id -> pr_id id - | EvalConstRef sp -> pr_global (Globnames.ConstRef sp) + | EvalConstRef sp -> pr_global (GlobRef.ConstRef sp) let pr_quantified_hypothesis = function | AnonHyp n -> int n @@ -385,7 +385,7 @@ let string_of_genarg_arg (ArgumentType arg) = let pr_evaluable_reference_env env = function | EvalVarRef id -> pr_id id | EvalConstRef sp -> - Nametab.pr_global_env (Termops.vars_of_env env) (Globnames.ConstRef sp) + Nametab.pr_global_env (Termops.vars_of_env env) (GlobRef.ConstRef sp) let pr_as_disjunctive_ipat prc ipatl = keyword "as" ++ spc () ++ diff --git a/plugins/ltac/profile_ltac.ml b/plugins/ltac/profile_ltac.ml index 243e0e945c..9d46bbc74e 100644 --- a/plugins/ltac/profile_ltac.ml +++ b/plugins/ltac/profile_ltac.ml @@ -376,7 +376,7 @@ let get_local_profiling_results () = List.hd Local.(!stack) own. *) module DData = struct type t = Feedback.doc_id * Stateid.t - let compare x y = Pervasives.compare x y + let compare x y = compare x y end module SM = Map.Make(DData) diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 19866df8e3..726752a2bf 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -24,7 +24,6 @@ open Tactics open Pretype_errors open Typeclasses open Constrexpr -open Globnames open Evd open Tactypes open Locus @@ -1898,11 +1897,11 @@ let declare_projection n instance_id r = let univs = Evd.univ_entry ~poly sigma in let typ = EConstr.to_constr sigma typ in let term = EConstr.to_constr sigma term in - let cst = - Declare.definition_entry ~types:typ ~univs term - in - ignore(Declare.declare_constant n - (Declare.DefinitionEntry cst, Decl_kinds.IsDefinition Decl_kinds.Definition)) + let cst = Declare.definition_entry ~types:typ ~univs term in + let _ : Constant.t = + Declare.declare_constant ~name:n ~kind:Decls.(IsDefinition Definition) + (Declare.DefinitionEntry cst) + in () let build_morphism_signature env sigma m = let m,ctx = Constrintern.interp_constr env sigma m in @@ -1978,14 +1977,13 @@ let add_morphism_as_parameter atts m n : unit = let evd = Evd.from_env env in let uctx, instance = build_morphism_signature env evd m in let uctx = UState.univ_entry ~poly:atts.polymorphic uctx in - let cst = Declare.declare_constant instance_id - (Declare.ParameterEntry - (None,(instance,uctx),None), - Decl_kinds.IsAssumption Decl_kinds.Logical) + let cst = Declare.declare_constant ~name:instance_id + ~kind:Decls.(IsAssumption Logical) + (Declare.ParameterEntry (None,(instance,uctx),None)) in Classes.add_instance (Classes.mk_instance - (PropGlobal.proper_class env evd) Hints.empty_hint_info atts.global (ConstRef cst)); - declare_projection n instance_id (ConstRef cst) + (PropGlobal.proper_class env evd) Hints.empty_hint_info atts.global (GlobRef.ConstRef cst)); + declare_projection n instance_id (GlobRef.ConstRef cst) let add_morphism_interactive atts m n : Lemmas.t = warn_add_morphism_deprecated ?loc:m.CAst.loc (); @@ -1995,14 +1993,14 @@ let add_morphism_interactive atts m n : Lemmas.t = let evd = Evd.from_env env in let uctx, instance = build_morphism_signature env evd m in let poly = atts.polymorphic in - let kind = Decl_kinds.DefinitionBody Decl_kinds.Instance in + let kind = Decls.(IsDefinition Instance) in let tac = make_tactic "Coq.Classes.SetoidTactics.add_morphism_tactic" in let hook { DeclareDef.Hook.S.dref; _ } = dref |> function - | Globnames.ConstRef cst -> + | GlobRef.ConstRef cst -> Classes.add_instance (Classes.mk_instance (PropGlobal.proper_class env evd) Hints.empty_hint_info - atts.global (ConstRef cst)); - declare_projection n instance_id (ConstRef cst) + atts.global (GlobRef.ConstRef cst)); + declare_projection n instance_id (GlobRef.ConstRef cst) | _ -> assert false in let hook = DeclareDef.Hook.make hook in diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml index 4e79bab28e..e64129d204 100644 --- a/plugins/ltac/taccoerce.ml +++ b/plugins/ltac/taccoerce.ml @@ -203,11 +203,11 @@ let id_of_name = function end | Const (cst,_) -> Label.to_id (Constant.label cst) | Construct (cstr,_) -> - let ref = Globnames.ConstructRef cstr in + let ref = GlobRef.ConstructRef cstr in let basename = Nametab.basename_of_global ref in basename | Ind (ind,_) -> - let ref = Globnames.IndRef ind in + let ref = GlobRef.IndRef ind in let basename = Nametab.basename_of_global ref in basename | Sort s -> @@ -290,7 +290,7 @@ let coerce_to_evaluable_ref env sigma v = if Id.List.mem id (Termops.ids_of_context env) then EvalVarRef id else fail () else if has_type v (topwit wit_ref) then - let open Globnames in + let open GlobRef in let r = out_gen (topwit wit_ref) v in match r with | VarRef var -> EvalVarRef var diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index 3ed5b1aab2..63559cf488 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -18,7 +18,6 @@ open Tacred open Util open Names open Libnames -open Globnames open Smartlocate open Constrexpr open Termops @@ -304,7 +303,7 @@ let intern_evaluable_reference_or_by_notation ist = function | {v=ByNotation (ntn,sc);loc} -> evaluable_of_global_reference ist.genv (Notation.interp_notation_as_global_reference ?loc - (function ConstRef _ | VarRef _ -> true | _ -> false) ntn sc) + GlobRef.(function ConstRef _ | VarRef _ -> true | _ -> false) ntn sc) (* Globalize a reduction expression *) let intern_evaluable ist r = @@ -383,7 +382,7 @@ let intern_typed_pattern_or_ref_with_occurrences ist (l,p) = | GRef (r,None) -> Inl (ArgArg (evaluable_of_global_reference ist.genv r,None)) | GVar id -> - let r = evaluable_of_global_reference ist.genv (VarRef id) in + let r = evaluable_of_global_reference ist.genv (GlobRef.VarRef id) in Inl (ArgArg (r,None)) | _ -> let bound_names = Glob_ops.bound_glob_vars c in diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 8ddf17ca14..c252372f21 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -22,7 +22,6 @@ open Util open Names open Nameops open Libnames -open Globnames open Refiner open Tacmach.New open Tactic_debug @@ -369,14 +368,14 @@ let interp_reference ist env sigma = function try try_interp_ltac_var (coerce_to_reference sigma) ist (Some (env,sigma)) (make ?loc id) with Not_found -> try - VarRef (get_id (Environ.lookup_named id env)) + GlobRef.VarRef (get_id (Environ.lookup_named id env)) with Not_found -> Nametab.error_global_not_found (qualid_of_ident ?loc id) let try_interp_evaluable env (loc, id) = let v = Environ.lookup_named id env in match v with | LocalDef _ -> EvalVarRef id - | _ -> error_not_evaluable (VarRef id) + | _ -> error_not_evaluable (GlobRef.VarRef id) let interp_evaluable ist env sigma = function | ArgArg (r,Some {loc;v=id}) -> diff --git a/plugins/ltac/tactic_debug.ml b/plugins/ltac/tactic_debug.ml index 3014ba5115..539536911c 100644 --- a/plugins/ltac/tactic_debug.ml +++ b/plugins/ltac/tactic_debug.ml @@ -33,12 +33,8 @@ type debug_info = | DebugOff (* An exception handler *) -let explain_logic_error e = - CErrors.print (fst (ExplainErr.process_vernac_interp_error (e, Exninfo.null))) - -let explain_logic_error_no_anomaly e = - CErrors.print_no_report - (fst (ExplainErr.process_vernac_interp_error (e, Exninfo.null))) +let explain_logic_error e = CErrors.print e +let explain_logic_error_no_anomaly e = CErrors.print_no_report e let msg_tac_debug s = Proofview.NonLogical.print_debug (s++fnl()) let msg_tac_notice s = Proofview.NonLogical.print_notice (s++fnl()) @@ -160,7 +156,7 @@ let rec prompt level = begin let open Proofview.NonLogical in Proofview.NonLogical.print_notice (fnl () ++ str "TcDebug (" ++ int level ++ str ") > ") >> - if Pervasives.(!batch) then return (DebugOn (level+1)) else + if Util.(!batch) then return (DebugOn (level+1)) else let exit = (skip:=0) >> (skipped:=0) >> raise Sys.Break in Proofview.NonLogical.catch Proofview.NonLogical.read_line begin function (e, info) -> match e with @@ -370,8 +366,9 @@ let explain_ltac_call_trace last trace loc = strbrk " (with " ++ prlist_with_sep pr_comma (fun (id,c) -> - (* XXX: This hooks into the ExplainErr extension API - so it is tricky to provide the right env for now. *) + (* XXX: This hooks into the CErrors's additional error + info API so it is tricky to provide the right env for + now. *) let env = Global.env () in let sigma = Evd.from_env env in Id.print id ++ str ":=" ++ Printer.pr_lconstr_under_binders_env env sigma c) @@ -424,11 +421,11 @@ let extract_ltac_trace ?loc trace = aux loc trace in best_loc, None -let get_ltac_trace (_, info) = +let get_ltac_trace info = let ltac_trace = Exninfo.get info ltac_trace_info in let loc = Loc.get_loc info in match ltac_trace with | None -> None | Some trace -> Some (extract_ltac_trace ?loc trace) -let () = ExplainErr.register_additional_error_info get_ltac_trace +let () = CErrors.register_additional_error_info get_ltac_trace diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index 2e32b00c25..24039c93c6 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -93,7 +93,7 @@ let dev_form n_spec p = let rec fixpoint f x = let y' = f x in - if Pervasives.(=) y' x then y' + if (=) y' x then y' else fixpoint f y' let rec_simpl_cone n_spec e = diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index f0435126aa..5cc2c2e061 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -1585,7 +1585,7 @@ let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = let is_proof_compatible (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) = let hyps_idx = prover.hyps prf in let hyps = selecti hyps_idx old_cl in - is_sublist Pervasives.(=) hyps new_cl in + is_sublist (=) hyps new_cl in @@ -1953,7 +1953,7 @@ open Persistent_cache module Cache = PHashtable(struct type t = (provername * micromega_polys) - let equal = Pervasives.(=) + let equal = (=) let hash = Hashtbl.hash end) diff --git a/plugins/micromega/csdpcert.ml b/plugins/micromega/csdpcert.ml index d8f71cda0c..cf5f60fb55 100644 --- a/plugins/micromega/csdpcert.ml +++ b/plugins/micromega/csdpcert.ml @@ -136,7 +136,7 @@ let pure_sos l = I should nonetheless be able to try something - over Z > is equivalent to -1 >= *) try let l = List.combine l (CList.interval 0 (List.length l -1)) in - let (lt,i) = try (List.find (fun (x,_) -> Pervasives.(=) (snd x) Mc.Strict) l) + let (lt,i) = try (List.find (fun (x,_) -> (=) (snd x) Mc.Strict) l) with Not_found -> List.hd l in let plt = poly_neg (poly_of_term (expr_to_term (fst lt))) in let (n,polys) = sumofsquares plt in (* n * (ci * pi^2) *) diff --git a/plugins/micromega/mfourier.ml b/plugins/micromega/mfourier.ml index 34fb32c270..943bcb384b 100644 --- a/plugins/micromega/mfourier.ml +++ b/plugins/micromega/mfourier.ml @@ -15,7 +15,7 @@ open Vect let debug = false -let compare_float (p : float) q = Pervasives.compare p q +let compare_float (p : float) q = pervasives_compare p q (** Implementation of intervals *) open Itv @@ -587,7 +587,7 @@ struct let optimise vect l = (* We add a dummy (fresh) variable for vector *) let fresh = - List.fold_left (fun fr c -> Pervasives.max fr (Vect.fresh c.coeffs)) 0 l in + List.fold_left (fun fr c -> max fr (Vect.fresh c.coeffs)) 0 l in let cstr = { coeffs = Vect.set fresh (Int (-1)) vect ; op = Eq ; diff --git a/plugins/micromega/mutils.ml b/plugins/micromega/mutils.ml index 97cf23ac1f..537b6175b4 100644 --- a/plugins/micromega/mutils.ml +++ b/plugins/micromega/mutils.ml @@ -21,7 +21,7 @@ module Int = struct type t = int - let compare : int -> int -> int = Pervasives.compare + let compare : int -> int -> int = compare let equal : int -> int -> bool = (=) end @@ -354,7 +354,7 @@ struct let from i = i let next i = i + 1 - let max : int -> int -> int = Pervasives.max + let max : int -> int -> int = max let pp o i = output_string o (string_of_int i) let compare : int -> int -> int = Int.compare let to_int x = x diff --git a/plugins/micromega/polynomial.ml b/plugins/micromega/polynomial.ml index f909b4ecda..1a31a36732 100644 --- a/plugins/micromega/polynomial.ml +++ b/plugins/micromega/polynomial.ml @@ -278,7 +278,7 @@ and op = |Eq | Ge | Gt exception Strict -let is_strict c = Pervasives.(=) c.op Gt +let is_strict c = (=) c.op Gt let eval_op = function | Eq -> (=/) @@ -422,7 +422,7 @@ module LinPoly = struct let min_list (l:int list) = match l with | [] -> None - | e::l -> Some (List.fold_left Pervasives.min e l) + | e::l -> Some (List.fold_left min e l) let search_linear p l = min_list (search_all_linear p l) @@ -656,9 +656,9 @@ module ProofFormat = struct let rec compare p1 p2 = match p1, p2 with | Annot(s1,p1) , Annot(s2,p2) -> if s1 = s2 then compare p1 p2 - else Pervasives.compare s1 s2 - | Hyp i , Hyp j -> Pervasives.compare i j - | Def i , Def j -> Pervasives.compare i j + else Util.pervasives_compare s1 s2 + | Hyp i , Hyp j -> Util.pervasives_compare i j + | Def i , Def j -> Util.pervasives_compare i j | Cst n , Cst m -> Num.compare_num n m | Zero , Zero -> 0 | Square v1 , Square v2 -> Vect.compare v1 v2 @@ -667,7 +667,7 @@ module ProofFormat = struct | MulPrf(p1,q1) , MulPrf(p2,q2) -> cmp_pair compare compare (p1,q1) (p2,q2) | AddPrf(p1,q1) , MulPrf(p2,q2) -> cmp_pair compare compare (p1,q1) (p2,q2) | CutPrf p , CutPrf p' -> compare p p' - | _ , _ -> Pervasives.compare (id_of_constr p1) (id_of_constr p2) + | _ , _ -> Util.pervasives_compare (id_of_constr p1) (id_of_constr p2) end @@ -785,7 +785,7 @@ module ProofFormat = struct let rec xid_of_hyp i l' = match l' with | [] -> failwith (Printf.sprintf "id_of_hyp %i %s" hyp (string_of_int_list l)) - | hyp'::l' -> if Pervasives.(=) hyp hyp' then i else xid_of_hyp (i+1) l' in + | hyp'::l' -> if (=) hyp hyp' then i else xid_of_hyp (i+1) l' in xid_of_hyp 0 l end @@ -873,7 +873,7 @@ module ProofFormat = struct let (p,o) = eval_prf_rule (fun i -> IMap.find i env) prf in if is_unsat (p,o) then true else - if Pervasives.(=) rst Done + if (=) rst Done then begin Printf.fprintf stdout "Last inference %a %s\n" LinPoly.pp p (string_of_op o); diff --git a/plugins/micromega/simplex.ml b/plugins/micromega/simplex.ml index 15fb55c007..4c95e6da75 100644 --- a/plugins/micromega/simplex.ml +++ b/plugins/micromega/simplex.ml @@ -587,7 +587,7 @@ let cut env rmin sol vm (rst:Restricted.t) tbl (x,v) = Printf.printf "This is a cutting plane for %a:" LinPoly.pp_var x; Printf.printf " %a\n" WithProof.output (v,prf); end; - if Pervasives.(=) (snd v) Eq + if (=) (snd v) Eq then (* Unsat *) Some (x,(v,prf)) else let vl = (Vect.dotproduct (fst v) (Vect.set 0 (Int 1) sol)) in @@ -651,7 +651,7 @@ let integer_solver lp = match find_cut (!nb mod 2) env cr (*x*) sol vm rst tbl with | None -> None | Some(cr,((v,op),cut)) -> - if Pervasives.(=) op Eq + if (=) op Eq then (* This is a contradiction *) Some(Step(vr,CutPrf cut, Done)) else diff --git a/plugins/micromega/sos_lib.ml b/plugins/micromega/sos_lib.ml index e3a9f6f60f..58d5d7ecf1 100644 --- a/plugins/micromega/sos_lib.ml +++ b/plugins/micromega/sos_lib.ml @@ -13,7 +13,7 @@ open Num (* Comparisons that are reflexive on NaN and also short-circuiting. *) (* ------------------------------------------------------------------------- *) -let cmp = Pervasives.compare (** FIXME *) +let cmp = compare (** FIXME *) let (=?) = fun x y -> cmp x y = 0;; let (<?) = fun x y -> cmp x y < 0;; @@ -491,21 +491,21 @@ let temp_path = Filename.get_temp_dir_name ();; (* ------------------------------------------------------------------------- *) let strings_of_file filename = - let fd = try Pervasives.open_in filename + let fd = try open_in filename with Sys_error _ -> failwith("strings_of_file: can't open "^filename) in let rec suck_lines acc = - try let l = Pervasives.input_line fd in + try let l = input_line fd in suck_lines (l::acc) with End_of_file -> List.rev acc in let data = suck_lines [] in - (Pervasives.close_in fd; data);; + (close_in fd; data);; let string_of_file filename = String.concat "\n" (strings_of_file filename);; let file_of_string filename s = - let fd = Pervasives.open_out filename in + let fd = open_out filename in output_string fd s; close_out fd;; diff --git a/plugins/micromega/vect.ml b/plugins/micromega/vect.ml index 4b2bc66eb7..a5f3b83c48 100644 --- a/plugins/micromega/vect.ml +++ b/plugins/micromega/vect.ml @@ -148,7 +148,7 @@ let rec add (ve1:t) (ve2:t) = match ve1 , ve2 with | [] , v | v , [] -> v | (v1,c1)::l1 , (v2,c2)::l2 -> - let cmp = Pervasives.compare v1 v2 in + let cmp = Util.pervasives_compare v1 v2 in if cmp == 0 then let s = add_num c1 c2 in if eq_num (Int 0) s @@ -163,7 +163,7 @@ let rec xmul_add (n1:num) (ve1:t) (n2:num) (ve2:t) = | [] , _ -> mul n2 ve2 | _ , [] -> mul n1 ve1 | (v1,c1)::l1 , (v2,c2)::l2 -> - let cmp = Pervasives.compare v1 v2 in + let cmp = Util.pervasives_compare v1 v2 in if cmp == 0 then let s = ( n1 */ c1) +/ (n2 */ c2) in if eq_num (Int 0) s diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 6aec83318c..00ea9b6a66 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -27,7 +27,6 @@ open Tacmach.New open Tactics open Logic open Libnames -open Globnames open Nametab open Contradiction open Tactypes @@ -426,11 +425,11 @@ let destructurate_prop sigma t = | _, [_;_] when eq_constr c (Lazy.force coq_ge) -> Kapp (Ge,args) | _, [_;_] when eq_constr c (Lazy.force coq_gt) -> Kapp (Gt,args) | Const (sp,_), args -> - Kapp (Other (string_of_path (path_of_global (ConstRef sp))),args) + Kapp (Other (string_of_path (path_of_global (GlobRef.ConstRef sp))),args) | Construct (csp,_) , args -> - Kapp (Other (string_of_path (path_of_global (ConstructRef csp))), args) + Kapp (Other (string_of_path (path_of_global (GlobRef.ConstructRef csp))), args) | Ind (isp,_), args -> - Kapp (Other (string_of_path (path_of_global (IndRef isp))),args) + Kapp (Other (string_of_path (path_of_global (GlobRef.IndRef isp))),args) | Var id,[] -> Kvar id | Prod ({binder_name=Anonymous},typ,body), [] -> Kimp(typ,body) | Prod ({binder_name=Name _},_,_),[] -> CErrors.user_err Pp.(str "Omega: Not a quantifier-free goal") @@ -500,7 +499,7 @@ let context sigma operation path (t : constr) = | (p, Fix ((_,n as ln),(tys,lna,v))) -> let l = Array.length v in let v' = Array.copy v in - v'.(n)<- loop (Pervasives.(+) i l) p v.(n); (mkFix (ln,(tys,lna,v'))) + v'.(n)<- loop (Util.(+) i l) p v.(n); (mkFix (ln,(tys,lna,v'))) | ((P_TYPE :: p), Prod (n,t,c)) -> (mkProd (n,loop i p t,c)) | ((P_TYPE :: p), Lambda (n,t,c)) -> @@ -684,7 +683,7 @@ let simpl_coeffs path_init path_k = | _ -> assert false) | _ -> assert false in - let n = Pervasives.(-) (List.length path_k) (List.length path_init) in + let n = Util.(-) (List.length path_k) (List.length path_init) in let newc = context sigma (fun _ t -> loop n t) (List.rev path_init) (pf_concl gl) in convert_concl ~check:false newc DEFAULTcast @@ -1000,7 +999,7 @@ let shrink_pair p f1 f2 = | t1,t2 -> begin oprint t1; print_newline (); oprint t2; print_newline (); - flush Pervasives.stdout; CErrors.user_err Pp.(str "shrink.1") + flush stdout; CErrors.user_err Pp.(str "shrink.1") end let reduce_factor p = function diff --git a/plugins/omega/omega.ml b/plugins/omega/omega.ml index cec87221f0..05c31062fc 100644 --- a/plugins/omega/omega.ml +++ b/plugins/omega/omega.ml @@ -242,7 +242,7 @@ let add_event, history, clear_history = (fun () -> !accu), (fun () -> accu := []) -let nf_linear = List.sort (fun x y -> Pervasives.(-) y.v x.v) +let nf_linear = List.sort (fun x y -> Util.(-) y.v x.v) let nf ((b : bool),(e,(x : int))) = (b,(nf_linear e,x)) diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 33798c43c8..eb75fca0a1 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -29,7 +29,6 @@ open Tacinterp open Libobject open Printer open Declare -open Decl_kinds open Entries open Newring_ast open Proofview.Notations @@ -50,7 +49,7 @@ let global_head_of_constr sigma c = let global_of_constr_nofail c = try global_of_constr c - with Not_found -> VarRef (Id.of_string "dummy") + with Not_found -> GlobRef.VarRef (Id.of_string "dummy") let rec mk_clos_but f_map n t = let (f, args) = Constr.decompose_appvect t in @@ -156,9 +155,9 @@ let decl_constant na univs c = let () = Declare.declare_universe_context ~poly:false univs in let types = (Typeops.infer (Global.env ()) c).uj_type in let univs = Monomorphic_entry Univ.ContextSet.empty in - mkConst(declare_constant (Id.of_string na) - (DefinitionEntry (definition_entry ~opaque:true ~types ~univs c), - IsProof Lemma)) + mkConst(declare_constant ~name:(Id.of_string na) + ~kind:Decls.(IsProof Lemma) + (DefinitionEntry (definition_entry ~opaque:true ~types ~univs c))) (* Calling a global tactic *) let ltac_call tac (args:glob_tactic_arg list) = diff --git a/plugins/ssr/ssrbwd.ml b/plugins/ssr/ssrbwd.ml index f0ae90beca..ca92d70263 100644 --- a/plugins/ssr/ssrbwd.ml +++ b/plugins/ssr/ssrbwd.ml @@ -12,7 +12,6 @@ open Printer open Pretyping -open Globnames open Glob_term open Tacmach @@ -47,7 +46,7 @@ let interp_agen ist gl ((goclr, _), (k, gc as c)) (clr, rcs) = let loc = rc.CAst.loc in match DAst.get rc with | GVar id when not_section_id id -> SsrHyp (Loc.tag ?loc id) :: clr', rcs' - | GRef (VarRef id, _) when not_section_id id -> + | GRef (Names.GlobRef.VarRef id, _) when not_section_id id -> SsrHyp (Loc.tag ?loc id) :: clr', rcs' | _ -> clr', rcs' @@ -89,7 +88,7 @@ let pf_match = pf_apply (fun e s c t -> understand_tcc e s ~expected_type:t c) let apply_rconstr ?ist t gl = (* ppdebug(lazy(str"sigma@apply_rconstr=" ++ pr_evar_map None (project gl))); *) let n = match ist, DAst.get t with - | None, (GVar id | GRef (VarRef id,_)) -> pf_nbargs gl (EConstr.mkVar id) + | None, (GVar id | GRef (Names.GlobRef.VarRef id,_)) -> pf_nbargs gl (EConstr.mkVar id) | Some ist, _ -> interp_nbargs ist gl t | _ -> anomaly "apply_rconstr without ist and not RVar" in let mkRlemma i = mkRApp t (mkRHoles i) in diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index 4c95a92022..33e9f871fd 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -181,7 +181,6 @@ let option_assert_get o msg = (** Constructors for rawconstr *) open Glob_term -open Globnames open Decl_kinds let mkRHole = DAst.make @@ GHole (Evar_kinds.InternalHole, Namegen.IntroAnonymous, None) @@ -191,14 +190,14 @@ let rec isRHoles cl = match cl with | [] -> true | c :: l -> match DAst.get c with GHole _ -> isRHoles l | _ -> false let mkRApp f args = if args = [] then f else DAst.make @@ GApp (f, args) -let mkRVar id = DAst.make @@ GRef (VarRef id,None) +let mkRVar id = DAst.make @@ GRef (GlobRef.VarRef id,None) let mkRltacVar id = DAst.make @@ GVar (id) let mkRCast rc rt = DAst.make @@ GCast (rc, CastConv rt) let mkRType = DAst.make @@ GSort (UAnonymous {rigid=true}) let mkRProp = DAst.make @@ GSort (UNamed [GProp,0]) let mkRArrow rt1 rt2 = DAst.make @@ GProd (Anonymous, Explicit, rt1, rt2) -let mkRConstruct c = DAst.make @@ GRef (ConstructRef c,None) -let mkRInd mind = DAst.make @@ GRef (IndRef mind,None) +let mkRConstruct c = DAst.make @@ GRef (GlobRef.ConstructRef c,None) +let mkRInd mind = DAst.make @@ GRef (GlobRef.IndRef mind,None) let mkRLambda n s t = DAst.make @@ GLambda (n, Explicit, s, t) let rec mkRnat n = @@ -1543,9 +1542,9 @@ let get g = end let is_construct_ref sigma c r = - EConstr.isConstruct sigma c && GlobRef.equal (ConstructRef (fst(EConstr.destConstruct sigma c))) r -let is_ind_ref sigma c r = EConstr.isInd sigma c && GlobRef.equal (IndRef (fst(EConstr.destInd sigma c))) r + EConstr.isConstruct sigma c && GlobRef.equal (GlobRef.ConstructRef (fst(EConstr.destConstruct sigma c))) r +let is_ind_ref sigma c r = EConstr.isInd sigma c && GlobRef.equal (GlobRef.IndRef (fst(EConstr.destInd sigma c))) r let is_const_ref sigma c r = - EConstr.isConst sigma c && GlobRef.equal (ConstRef (fst(EConstr.destConst sigma c))) r + EConstr.isConst sigma c && GlobRef.equal (GlobRef.ConstRef (fst(EConstr.destConst sigma c))) r (* vim: set filetype=ocaml foldmethod=marker: *) diff --git a/plugins/ssr/ssrvernac.mlg b/plugins/ssr/ssrvernac.mlg index 279e7ce1a6..0adabb0673 100644 --- a/plugins/ssr/ssrvernac.mlg +++ b/plugins/ssr/ssrvernac.mlg @@ -412,11 +412,10 @@ let interp_search_arg arg = if is_ident_part s then Search.GlobSearchString s else interp_search_notation ~loc s key | RGlobSearchSubPattern p -> - try - let env = Global.env () in - let _, p = Constrintern.intern_constr_pattern env (Evd.from_env env) p in - Search.GlobSearchSubPattern p - with e -> let e = CErrors.push e in iraise (ExplainErr.process_vernac_interp_error e)) arg in + let env = Global.env () in + let _, p = Constrintern.intern_constr_pattern env (Evd.from_env env) p in + Search.GlobSearchSubPattern p) arg + in let hpat, a1 = match arg with | (_, Search.GlobSearchSubPattern (Pattern.PMeta _)) :: a' -> all_true, a' | (true, Search.GlobSearchSubPattern p) :: a' -> diff --git a/plugins/ssr/ssrview.ml b/plugins/ssr/ssrview.ml index 34f13b1096..f91b5e7aa2 100644 --- a/plugins/ssr/ssrview.ml +++ b/plugins/ssr/ssrview.ml @@ -26,7 +26,7 @@ module AdaptorDb = struct module AdaptorKind = struct type t = kind - let compare = Pervasives.compare + let compare = pervasives_compare end module AdaptorMap = Map.Make(AdaptorKind) diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index 7fc1a12b61..17db25660f 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -361,7 +361,7 @@ type tpattern = { let all_ok _ _ = true let proj_nparams c = - try 1 + Recordops.find_projection_nparams (ConstRef c) with _ -> 0 + try 1 + Recordops.find_projection_nparams (GlobRef.ConstRef c) with _ -> 0 let isRigid c = match kind c with | Prod _ | Sort _ | Lambda _ | Case _ | Fix _ | CoFix _ -> true @@ -454,7 +454,7 @@ let ungen_upat lhs (sigma, uc, t) u = let nb_cs_proj_args pc f u = let na k = - List.length (snd (lookup_canonical_conversion (ConstRef pc, k))).o_TCOMPS in + List.length (snd (lookup_canonical_conversion (GlobRef.ConstRef pc, k))).o_TCOMPS in let nargs_of_proj t = match kind t with | App(_,args) -> Array.length args | Proj _ -> 0 (* if splay_app calls expand_projection, this has to be @@ -928,7 +928,7 @@ let id_of_cpattern (_, (c1, c2), _) = Some (qualid_basename qid) | _, Some { v = CAppExpl ((_, qid, _), []) } when qualid_is_ident qid -> Some (qualid_basename qid) - | GRef (VarRef x, _), None -> Some x + | GRef (GlobRef.VarRef x, _), None -> Some x | _ -> None let id_of_Cterm t = match id_of_cpattern t with | Some x -> x @@ -1267,7 +1267,7 @@ let pf_fill_occ_term gl occ t = cl, t let cpattern_of_id id = - ' ', (DAst.make @@ GRef (VarRef id, None), None), Some Geninterp.({ lfun = Id.Map.empty; poly = false; extra = Tacinterp.TacStore.empty }) + ' ', (DAst.make @@ GRef (GlobRef.VarRef id, None), None), Some Geninterp.({ lfun = Id.Map.empty; poly = false; extra = Tacinterp.TacStore.empty }) let is_wildcard ((_, (l, r), _) : cpattern) : bool = match DAst.get l, r with | _, Some { CAst.v = CHole _ } | GHole _, None -> true diff --git a/plugins/syntax/numeral.ml b/plugins/syntax/numeral.ml index 0a1cc8745d..a148a3bc73 100644 --- a/plugins/syntax/numeral.ml +++ b/plugins/syntax/numeral.ml @@ -12,7 +12,6 @@ open Pp open Util open Names open Libnames -open Globnames open Constrexpr open Constrexpr_ops open Notation @@ -31,7 +30,7 @@ let get_constructors ind = let mib,oib = Global.lookup_inductive ind in let mc = oib.Declarations.mind_consnames in Array.to_list - (Array.mapi (fun j c -> ConstructRef (ind, j + 1)) mc) + (Array.mapi (fun j c -> GlobRef.ConstructRef (ind, j + 1)) mc) let qualid_of_ref n = n |> Coqlib.lib_ref |> Nametab.shortest_qualid_of_global Id.Set.empty @@ -40,7 +39,7 @@ let q_option () = qualid_of_ref "core.option.type" let unsafe_locate_ind q = match Nametab.locate q with - | IndRef i -> i + | GlobRef.IndRef i -> i | _ -> raise Not_found let locate_z () = @@ -166,7 +165,7 @@ let vernac_numeral_notation local ty f g scope opts = { pt_local = local; pt_scope = scope; pt_interp_info = NumeralNotation o; - pt_required = Nametab.path_of_global (IndRef tyc),[]; + pt_required = Nametab.path_of_global (GlobRef.IndRef tyc),[]; pt_refs = constructors; pt_in_match = true } in diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index 1cbc86b6fe..649b51cb0e 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -10,7 +10,6 @@ open Util open Names -open Globnames open Glob_term open Bigint open Constrexpr @@ -40,9 +39,9 @@ let positive_kn = MutInd.make2 positive_modpath (Label.make "positive") let path_of_xI = ((positive_kn,0),1) let path_of_xO = ((positive_kn,0),2) let path_of_xH = ((positive_kn,0),3) -let glob_xI = ConstructRef path_of_xI -let glob_xO = ConstructRef path_of_xO -let glob_xH = ConstructRef path_of_xH +let glob_xI = GlobRef.ConstructRef path_of_xI +let glob_xO = GlobRef.ConstructRef path_of_xO +let glob_xH = GlobRef.ConstructRef path_of_xH let pos_of_bignat ?loc x = let ref_xI = DAst.make @@ GRef (glob_xI, None) in @@ -74,9 +73,9 @@ let z_kn = MutInd.make2 positive_modpath (Label.make "Z") let path_of_ZERO = ((z_kn,0),1) let path_of_POS = ((z_kn,0),2) let path_of_NEG = ((z_kn,0),3) -let glob_ZERO = ConstructRef path_of_ZERO -let glob_POS = ConstructRef path_of_POS -let glob_NEG = ConstructRef path_of_NEG +let glob_ZERO = GlobRef.ConstructRef path_of_ZERO +let glob_POS = GlobRef.ConstructRef path_of_POS +let glob_NEG = GlobRef.ConstructRef path_of_NEG let z_of_int ?loc n = if not (Bigint.equal n zero) then @@ -104,14 +103,14 @@ let rdefinitions = ["Coq";"Reals";"Rdefinitions"] let r_modpath = MPfile (make_dir rdefinitions) let r_path = make_path rdefinitions "R" -let glob_IZR = ConstRef (Constant.make2 r_modpath @@ Label.make "IZR") -let glob_Rmult = ConstRef (Constant.make2 r_modpath @@ Label.make "Rmult") -let glob_Rdiv = ConstRef (Constant.make2 r_modpath @@ Label.make "Rdiv") +let glob_IZR = GlobRef.ConstRef (Constant.make2 r_modpath @@ Label.make "IZR") +let glob_Rmult = GlobRef.ConstRef (Constant.make2 r_modpath @@ Label.make "Rmult") +let glob_Rdiv = GlobRef.ConstRef (Constant.make2 r_modpath @@ Label.make "Rdiv") let binintdef = ["Coq";"ZArith";"BinIntDef"] let z_modpath = MPdot (MPfile (make_dir binintdef), Label.make "Z") -let glob_pow_pos = ConstRef (Constant.make2 z_modpath @@ Label.make "pow_pos") +let glob_pow_pos = GlobRef.ConstRef (Constant.make2 z_modpath @@ Label.make "pow_pos") let r_of_rawnum ?loc (sign,n) = let n, f, e = NumTok.(n.int, n.frac, n.exp) in diff --git a/plugins/syntax/string_notation.ml b/plugins/syntax/string_notation.ml index bc586acce7..8c0f9a3339 100644 --- a/plugins/syntax/string_notation.ml +++ b/plugins/syntax/string_notation.ml @@ -12,7 +12,6 @@ open Pp open Util open Names open Libnames -open Globnames open Constrexpr open Constrexpr_ops open Notation @@ -23,7 +22,7 @@ let get_constructors ind = let mib,oib = Global.lookup_inductive ind in let mc = oib.Declarations.mind_consnames in Array.to_list - (Array.mapi (fun j c -> ConstructRef (ind, j + 1)) mc) + (Array.mapi (fun j c -> GlobRef.ConstructRef (ind, j + 1)) mc) let qualid_of_ref n = n |> Coqlib.lib_ref |> Nametab.shortest_qualid_of_global Id.Set.empty @@ -92,7 +91,7 @@ let vernac_string_notation local ty f g scope = { pt_local = local; pt_scope = scope; pt_interp_info = StringNotation o; - pt_required = Nametab.path_of_global (IndRef tyc),[]; + pt_required = Nametab.path_of_global (GlobRef.IndRef tyc),[]; pt_refs = constructors; pt_in_match = true } in diff --git a/pretyping/arguments_renaming.ml b/pretyping/arguments_renaming.ml index 47916ffb79..534c0ca20b 100644 --- a/pretyping/arguments_renaming.ml +++ b/pretyping/arguments_renaming.ml @@ -91,23 +91,23 @@ let rename_type ty ref = let rename_type_of_constant env c = let ty = Typeops.type_of_constant_in env c in - rename_type ty (ConstRef (fst c)) + rename_type ty (GlobRef.ConstRef (fst c)) let rename_type_of_inductive env ind = let ty = Inductiveops.type_of_inductive env ind in - rename_type ty (IndRef (fst ind)) + rename_type ty (GlobRef.IndRef (fst ind)) let rename_type_of_constructor env cstruct = let ty = Inductiveops.type_of_constructor env cstruct in - rename_type ty (ConstructRef (fst cstruct)) + rename_type ty (GlobRef.ConstructRef (fst cstruct)) let rename_typing env c = let j = Typeops.infer env c in let j' = match kind c with - | Const (c,u) -> { j with uj_type = rename_type j.uj_type (ConstRef c) } - | Ind (i,u) -> { j with uj_type = rename_type j.uj_type (IndRef i) } - | Construct (k,u) -> { j with uj_type = rename_type j.uj_type (ConstructRef k) } + | Const (c,u) -> { j with uj_type = rename_type j.uj_type (GlobRef.ConstRef c) } + | Ind (i,u) -> { j with uj_type = rename_type j.uj_type (GlobRef.IndRef i) } + | Construct (k,u) -> { j with uj_type = rename_type j.uj_type (GlobRef.ConstructRef k) } | _ -> j in j' diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 20dec96ef4..a562204b54 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -367,7 +367,7 @@ let make_return_predicate_ltac_lvar env sigma na tm c = - if [c] is a variable [id'], then [x] should now become [id'] - otherwise, [x] should be hidden *) match na, DAst.get tm with - | Name id, (GVar id' | GRef (Globnames.VarRef id', _)) when Id.equal id id' -> + | Name id, (GVar id' | GRef (GlobRef.VarRef id', _)) when Id.equal id id' -> let expansion = match kind sigma c with | Var id' -> Name id' | _ -> Anonymous in diff --git a/pretyping/classops.ml b/pretyping/classops.ml index f5fffc4c1c..57dbfb2580 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -58,7 +58,7 @@ let cl_typ_ord t1 t2 = match t1, t2 with | CL_CONST c1, CL_CONST c2 -> Constant.CanOrd.compare c1 c2 | CL_PROJ c1, CL_PROJ c2 -> Projection.Repr.CanOrd.compare c1 c2 | CL_IND i1, CL_IND i2 -> ind_ord i1 i2 - | _ -> Pervasives.compare t1 t2 (** OK *) + | _ -> pervasives_compare t1 t2 (** OK *) module ClTyp = struct type t = cl_typ @@ -225,14 +225,14 @@ let string_of_class = function | CL_FUN -> "Funclass" | CL_SORT -> "Sortclass" | CL_CONST sp -> - string_of_qualid (Nametab.shortest_qualid_of_global Id.Set.empty (ConstRef sp)) + string_of_qualid (Nametab.shortest_qualid_of_global Id.Set.empty (GlobRef.ConstRef sp)) | CL_PROJ sp -> let sp = Projection.Repr.constant sp in - string_of_qualid (Nametab.shortest_qualid_of_global Id.Set.empty (ConstRef sp)) + string_of_qualid (Nametab.shortest_qualid_of_global Id.Set.empty (GlobRef.ConstRef sp)) | CL_IND sp -> - string_of_qualid (Nametab.shortest_qualid_of_global Id.Set.empty (IndRef sp)) + string_of_qualid (Nametab.shortest_qualid_of_global Id.Set.empty (GlobRef.IndRef sp)) | CL_SECVAR sp -> - string_of_qualid (Nametab.shortest_qualid_of_global Id.Set.empty (VarRef sp)) + string_of_qualid (Nametab.shortest_qualid_of_global Id.Set.empty (GlobRef.VarRef sp)) let pr_class x = str (string_of_class x) @@ -276,8 +276,8 @@ let lookup_path_to_fun_from env sigma s = let lookup_path_to_sort_from env sigma s = apply_on_class_of env sigma s lookup_path_to_sort_from_class -let mkNamed = function - | GlobRef.ConstRef c -> EConstr.mkConst c +let mkNamed = let open GlobRef in function + | ConstRef c -> EConstr.mkConst c | VarRef v -> EConstr.mkVar v | ConstructRef c -> EConstr.mkConstruct c | IndRef i -> EConstr.mkInd i @@ -313,7 +313,9 @@ let compare_path p q = !path_comparator p q let warn_ambiguous_path = CWarnings.create ~name:"ambiguous-paths" ~category:"typechecker" - (fun l -> strbrk"Ambiguous paths: " ++ prlist_with_sep fnl print_path l) + (fun l -> prlist_with_sep fnl (fun (c,p,q) -> + str"New coercion path " ++ print_path (c,p) ++ + str" is ambiguous with existing " ++ print_path (c, q) ++ str".") l) (* add_coercion_in_graph : coe_index * cl_index * cl_index -> unit coercion,source,target *) @@ -323,20 +325,20 @@ let different_class_params env i = if (snd ci).cl_param > 0 then true else match fst ci with - | CL_IND i -> Environ.is_polymorphic env (IndRef i) - | CL_CONST c -> Environ.is_polymorphic env (ConstRef c) + | CL_IND i -> Environ.is_polymorphic env (GlobRef.IndRef i) + | CL_CONST c -> Environ.is_polymorphic env (GlobRef.ConstRef c) | _ -> false let add_coercion_in_graph env sigma (ic,source,target) = let old_inheritance_graph = !inheritance_graph in let ambig_paths = - (ref [] : ((cl_index * cl_index) * inheritance_path) list ref) in + (ref [] : ((cl_index * cl_index) * inheritance_path * inheritance_path) list ref) in let try_add_new_path (i,j as ij) p = if not (Bijint.Index.equal i j) || different_class_params env i then match lookup_path_between_class ij with | q -> if not (compare_path env sigma p q) then - ambig_paths := (ij,p)::!ambig_paths; + ambig_paths := (ij,p,q)::!ambig_paths; false | exception Not_found -> (add_new_path ij p; true) else @@ -391,15 +393,15 @@ let reference_arity_length env sigma ref = List.length (fst (Reductionops.splay_arity env sigma (EConstr.of_constr t))) let projection_arity_length env sigma p = - let len = reference_arity_length env sigma (ConstRef (Projection.Repr.constant p)) in + let len = reference_arity_length env sigma (GlobRef.ConstRef (Projection.Repr.constant p)) in len - Projection.Repr.npars p let class_params env sigma = function | CL_FUN | CL_SORT -> 0 - | CL_CONST sp -> reference_arity_length env sigma (ConstRef sp) + | CL_CONST sp -> reference_arity_length env sigma (GlobRef.ConstRef sp) | CL_PROJ sp -> projection_arity_length env sigma sp - | CL_SECVAR sp -> reference_arity_length env sigma (VarRef sp) - | CL_IND sp -> reference_arity_length env sigma (IndRef sp) + | CL_SECVAR sp -> reference_arity_length env sigma (GlobRef.VarRef sp) + | CL_IND sp -> reference_arity_length env sigma (GlobRef.IndRef sp) (* add_class : cl_typ -> locality_flag option -> bool -> unit *) diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index 415b9ec6df..e85c888b2e 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -15,7 +15,6 @@ open Util open Names open Constr open Context -open Globnames open Termops open EConstr open Vars @@ -237,11 +236,12 @@ let merge_binding sigma allow_bound_rels ctx n cT subst = else raise PatternMatchingFailure in constrain sigma n c subst - + let matches_core env sigma allow_bound_rels (binding_vars,pat) c = let open EConstr in - let convref ref c = + let convref ref c = + let open GlobRef in match ref, EConstr.kind sigma c with | VarRef id, Var id' -> Names.Id.equal id id' | ConstRef c, Const (c',_) -> Constant.equal c c' @@ -270,7 +270,7 @@ let matches_core env sigma allow_bound_rels | PMeta None, m -> subst - | PRef (VarRef v1), Var v2 when Id.equal v1 v2 -> subst + | PRef (GlobRef.VarRef v1), Var v2 when Id.equal v1 v2 -> subst | PVar v1, Var v2 when Id.equal v1 v2 -> subst @@ -307,7 +307,7 @@ let matches_core env sigma allow_bound_rels | PApp (c1,arg1), App (c2,arg2) -> (match c1, EConstr.kind sigma c2 with - | PRef (ConstRef r), Proj (pr,c) when not (Constant.equal r (Projection.constant pr)) + | PRef (GlobRef.ConstRef r), Proj (pr,c) when not (Constant.equal r (Projection.constant pr)) || Projection.unfolded pr -> raise PatternMatchingFailure | PProj (pr1,c1), Proj (pr,c) -> @@ -323,7 +323,7 @@ let matches_core env sigma allow_bound_rels try Array.fold_left2 (sorec ctx env) (sorec ctx env subst c1 c2) arg1 arg2 with Invalid_argument _ -> raise PatternMatchingFailure) - | PApp (PRef (ConstRef c1), _), Proj (pr, c2) + | PApp (PRef (GlobRef.ConstRef c1), _), Proj (pr, c2) when Projection.unfolded pr || not (Constant.equal c1 (Projection.constant pr)) -> raise PatternMatchingFailure diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 0daf1ab531..2061b41292 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -185,7 +185,7 @@ module PrintingInductiveMake = module Set = Indset let encode = Test.encode let subst subst obj = subst_ind subst obj - let printer ind = Nametab.pr_global_env Id.Set.empty (IndRef ind) + let printer ind = Nametab.pr_global_env Id.Set.empty (GlobRef.IndRef ind) let key = ["Printing";Test.field] let title = Test.title let member_message x = Test.member_message (printer x) @@ -746,7 +746,7 @@ and detype_r d flags avoid env sigma t = GEvar (Id.of_string_soft ("M" ^ string_of_int n), []) | Var id -> (* Discriminate between section variable and non-section variable *) - (try let _ = Global.lookup_named id in GRef (VarRef id, None) + (try let _ = Global.lookup_named id in GRef (GlobRef.VarRef id, None) with Not_found -> GVar id) | Sort s -> GSort (detype_sort sigma (ESorts.kind sigma s)) | Cast (c1,REVERTcast,c2) when not !Flags.raw_print -> @@ -772,20 +772,20 @@ and detype_r d flags avoid env sigma t = in mkapp (detype d flags avoid env sigma f) (Array.map_to_list (detype d flags avoid env sigma) args) - | Const (sp,u) -> GRef (ConstRef sp, detype_instance sigma u) + | Const (sp,u) -> GRef (GlobRef.ConstRef sp, detype_instance sigma u) | Proj (p,c) -> let noparams () = let pars = Projection.npars p in let hole = DAst.make @@ GHole(Evar_kinds.InternalHole,Namegen.IntroAnonymous,None) in let args = List.make pars hole in - GApp (DAst.make @@ GRef (ConstRef (Projection.constant p), None), + GApp (DAst.make @@ GRef (GlobRef.ConstRef (Projection.constant p), None), (args @ [detype d flags avoid env sigma c])) in if flags.flg_lax || !Flags.in_debugger || !Flags.in_toplevel then try noparams () with _ -> (* lax mode, used by debug printers only *) - GApp (DAst.make @@ GRef (ConstRef (Projection.constant p), None), + GApp (DAst.make @@ GRef (GlobRef.ConstRef (Projection.constant p), None), [detype d flags avoid env sigma c]) else if print_primproj_params () then @@ -821,9 +821,9 @@ and detype_r d flags avoid env sigma t = GEvar (id, List.map (on_snd (detype d flags avoid env sigma)) l) | Ind (ind_sp,u) -> - GRef (IndRef ind_sp, detype_instance sigma u) + GRef (GlobRef.IndRef ind_sp, detype_instance sigma u) | Construct (cstr_sp,u) -> - GRef (ConstructRef cstr_sp, detype_instance sigma u) + GRef (GlobRef.ConstructRef cstr_sp, detype_instance sigma u) | Case (ci,p,c,bl) -> let comp = computable sigma p (List.length (ci.ci_pp_info.ind_tags)) in detype_case comp (detype d flags avoid env sigma) diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index edc948eb65..a82eff9cf0 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -263,7 +263,7 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) = lookup_canonical_conversion (proji, Sort_cs (Sorts.family s)),[] | Proj (p, c) -> - let c2 = Globnames.ConstRef (Projection.constant p) in + let c2 = GlobRef.ConstRef (Projection.constant p) in let c = Retyping.expand_projection env sigma p c [] in let _, args = destApp sigma c in let sk2 = Stack.append_app args sk2 in diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index ea94305dd8..6bde3dfd81 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -12,7 +12,6 @@ open Util open CAst open Names open Nameops -open Globnames open Glob_term open Evar_kinds @@ -443,7 +442,7 @@ let rec rename_glob_vars l c = force @@ DAst.map_with_loc (fun ?loc -> function | GVar id as r -> let id' = rename_var l id in if id == id' then r else GVar id' - | GRef (VarRef id,_) as r -> + | GRef (GlobRef.VarRef id,_) as r -> if List.exists (fun (_,id') -> Id.equal id id') l then raise UnsoundRenaming else r | GProd (na,bk,t,c) -> @@ -502,10 +501,10 @@ let rec cases_pattern_of_glob_constr env na c = | Anonymous -> PatVar (Name id) end | GHole (_,_,_) -> PatVar na - | GRef (ConstructRef cstr,_) -> PatCstr (cstr,[],na) + | GRef (GlobRef.ConstructRef cstr,_) -> PatCstr (cstr,[],na) | GApp (c, l) -> begin match DAst.get c with - | GRef (ConstructRef cstr,_) -> + | GRef (GlobRef.ConstructRef cstr,_) -> let nparams = Inductiveops.inductive_nparams env (fst cstr) in let _,l = List.chop nparams l in PatCstr (cstr,List.map (cases_pattern_of_glob_constr env Anonymous) l,na) @@ -554,9 +553,9 @@ let add_alias ?loc na c = (* Turn a closed cases pattern into a glob_constr *) let rec glob_constr_of_cases_pattern_aux env isclosed x = DAst.map_with_loc (fun ?loc -> function - | PatCstr (cstr,[],na) -> add_alias ?loc na (GRef (ConstructRef cstr,None)) + | PatCstr (cstr,[],na) -> add_alias ?loc na (GRef (GlobRef.ConstructRef cstr,None)) | PatCstr (cstr,l,na) -> - let ref = DAst.make ?loc @@ GRef (ConstructRef cstr,None) in + let ref = DAst.make ?loc @@ GRef (GlobRef.ConstructRef cstr,None) in let l = add_patterns_for_params_remove_local_defs env cstr l in add_alias ?loc na (GApp (ref, List.map (glob_constr_of_cases_pattern_aux env isclosed) l)) | PatVar (Name id) when not isclosed -> diff --git a/pretyping/heads.ml b/pretyping/heads.ml index d65faecd19..870df62500 100644 --- a/pretyping/heads.ml +++ b/pretyping/heads.ml @@ -41,8 +41,7 @@ let rec compute_head env = function | Some c -> kind_of_head env c) | EvalVarRef id -> (match lookup_named id env with - | LocalDef (_,c,_) when not (Decls.variable_opacity id) -> - kind_of_head env c + | LocalDef (_,c,_) -> kind_of_head env c | _ -> RigidHead RigidOther) and kind_of_head env t = diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index e25ebad380..a43549f6c3 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -17,7 +17,6 @@ open CErrors open Util open Names open Libnames -open Globnames open Nameops open Term open Constr @@ -624,7 +623,7 @@ let lookup_eliminator env ind_sp s = try let cst = Constant.make knu knc in let _ = lookup_constant cst env in - ConstRef cst + GlobRef.ConstRef cst with Not_found -> (* Then try to get a user-defined eliminator in some other places *) (* using short name (e.g. for "eq_rec") *) @@ -633,6 +632,6 @@ let lookup_eliminator env ind_sp s = user_err ~hdr:"default_elim" (strbrk "Cannot find the elimination combinator " ++ Id.print id ++ strbrk ", the elimination of the inductive definition " ++ - Nametab.pr_global_env Id.Set.empty (IndRef ind_sp) ++ + Nametab.pr_global_env Id.Set.empty (GlobRef.IndRef ind_sp) ++ strbrk " on sort " ++ Sorts.pr_sort_family s ++ strbrk " is probably not allowed.") diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index 0c639b4328..e5aed300a2 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -499,7 +499,7 @@ let native_norm env sigma c ty = if !Flags.debug then Feedback.msg_debug (Pp.str "Running norm ..."); let profiler_pid = if profile then start_profiler () else None in let t0 = Sys.time () in - Nativelib.call_linker ~fatal:true prefix fn (Some upd); + Nativelib.call_linker ~fatal:true env ~prefix fn (Some upd); let t1 = Sys.time () in if profile then stop_profiler profiler_pid; let time_info = Format.sprintf "Evaluation done in %.5f@." (t1 -. t0) in diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index 3600f1761b..99e3c5025e 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -132,7 +132,7 @@ let rec head_pattern_bound t = | PIf (c,_,_) -> head_pattern_bound c | PCase (_,p,c,br) -> head_pattern_bound c | PRef r -> r - | PVar id -> VarRef id + | PVar id -> GlobRef.VarRef id | PEvar _ | PRel _ | PMeta _ | PSoApp _ | PSort _ | PFix _ | PProj _ -> raise BoundPattern (* Perhaps they were arguments, but we don't beta-reduce *) @@ -140,10 +140,10 @@ let rec head_pattern_bound t = | PCoFix _ | PInt _ -> anomaly ~label:"head_pattern_bound" (Pp.str "not a type.") let head_of_constr_reference sigma c = match EConstr.kind sigma c with - | Const (sp,_) -> ConstRef sp - | Construct (sp,_) -> ConstructRef sp - | Ind (sp,_) -> IndRef sp - | Var id -> VarRef id + | Const (sp,_) -> GlobRef.ConstRef sp + | Construct (sp,_) -> GlobRef.ConstructRef sp + | Ind (sp,_) -> GlobRef.IndRef sp + | Var id -> GlobRef.VarRef id | _ -> anomaly (Pp.str "Not a rigid reference.") let pattern_of_constr env sigma t = @@ -175,9 +175,9 @@ let pattern_of_constr env sigma t = with | Some n -> PSoApp (n,Array.to_list (Array.map (pattern_of_constr env) a)) | None -> PApp (pattern_of_constr env f,Array.map (pattern_of_constr env) a)) - | Const (sp,u) -> PRef (ConstRef (Constant.make1 (Constant.canonical sp))) - | Ind (sp,u) -> PRef (canonical_gr (IndRef sp)) - | Construct (sp,u) -> PRef (canonical_gr (ConstructRef sp)) + | Const (sp,u) -> PRef (GlobRef.ConstRef (Constant.make1 (Constant.canonical sp))) + | Ind (sp,u) -> PRef (canonical_gr (GlobRef.IndRef sp)) + | Construct (sp,u) -> PRef (canonical_gr (GlobRef.ConstructRef sp)) | Proj (p, c) -> pattern_of_constr env (EConstr.Unsafe.to_constr (Retyping.expand_projection env sigma p (EConstr.of_constr c) [])) | Evar (evk,ctxt as ev) -> diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 280b6f9dae..c28c3ab730 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -37,7 +37,6 @@ open Vars open Reductionops open Type_errors open Typing -open Globnames open Evarutil open Evardefine open Pretype_errors @@ -435,7 +434,7 @@ let pretype_global ?loc rigid env evd gr us = let pretype_ref ?loc sigma env ref us = match ref with - | VarRef id -> + | GlobRef.VarRef id -> (* Section variable *) (try sigma, make_judge (mkVar id) (NamedDecl.get_type (lookup_named id !!env)) with Not_found -> diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 1b70119f20..48838a44c4 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -89,11 +89,11 @@ let lookup_structure indsp = Indmap.find indsp !structure_table let lookup_projections indsp = (lookup_structure indsp).s_PROJ let find_projection_nparams = function - | ConstRef cst -> (Cmap.find cst !projection_table).s_EXPECTEDPARAM + | GlobRef.ConstRef cst -> (Cmap.find cst !projection_table).s_EXPECTEDPARAM | _ -> raise Not_found let find_projection = function - | ConstRef cst -> Cmap.find cst !projection_table + | GlobRef.ConstRef cst -> Cmap.find cst !projection_table | _ -> raise Not_found let is_projection cst = Cmap.mem cst !projection_table @@ -185,7 +185,7 @@ let rec cs_pattern_of_constr env t = | Proj (p, c) -> let { Environ.uj_type = ty } = Typeops.infer env c in let _, params = Inductive.find_rectype env ty in - Const_cs (ConstRef (Projection.constant p)), None, params @ [c] + Const_cs (GlobRef.ConstRef (Projection.constant p)), None, params @ [c] | Sort s -> Sort_cs (Sorts.family s), None, [] | _ -> Const_cs (global_of_constr t) , None, [] @@ -193,8 +193,8 @@ let warn_projection_no_head_constant = CWarnings.create ~name:"projection-no-head-constant" ~category:"typechecker" (fun (sign,env,t,con,proji_sp) -> let env = Termops.push_rels_assum sign env in - let con_pp = Nametab.pr_global_env Id.Set.empty (ConstRef con) in - let proji_sp_pp = Nametab.pr_global_env Id.Set.empty (ConstRef proji_sp) in + let con_pp = Nametab.pr_global_env Id.Set.empty (GlobRef.ConstRef con) in + let proji_sp_pp = Nametab.pr_global_env Id.Set.empty (GlobRef.ConstRef proji_sp) in let term_pp = Termops.Internal.print_constr_env env (Evd.from_env env) (EConstr.of_constr t) in strbrk "Projection value has no head constant: " ++ term_pp ++ strbrk " in canonical instance " @@ -223,7 +223,7 @@ let compute_canonical_projections env ~warn (con,ind) = Option.cata (fun proji_sp -> match cs_pattern_of_constr nenv t with | patt, o_INJ, o_TCOMPS -> - ((ConstRef proji_sp, (patt, t)), + ((GlobRef.ConstRef proji_sp, (patt, t)), { o_DEF ; o_CTX ; o_INJ ; o_TABS ; o_TPARAMS ; o_NPARAMS ; o_TCOMPS }) :: acc | exception Not_found -> @@ -281,7 +281,7 @@ let error_not_structure ref description = let check_and_decompose_canonical_structure env sigma ref = let sp = match ref with - ConstRef sp -> sp + GlobRef.ConstRef sp -> sp | _ -> error_not_structure ref (str "Expected an instance of a record or structure.") in let u = Univ.make_abstract_instance (Environ.constant_context env sp) in @@ -313,13 +313,13 @@ let lookup_canonical_conversion (proj,pat) = let decompose_projection sigma c args = match EConstr.kind sigma c with | Const (c, u) -> - let n = find_projection_nparams (ConstRef c) in + let n = find_projection_nparams (GlobRef.ConstRef c) in (* Check if there is some canonical projection attached to this structure *) - let _ = GlobRef.Map.find (ConstRef c) !object_table in + let _ = GlobRef.Map.find (GlobRef.ConstRef c) !object_table in let arg = Stack.nth args n in arg | Proj (p, c) -> - let _ = GlobRef.Map.find (ConstRef (Projection.constant p)) !object_table in + let _ = GlobRef.Map.find (GlobRef.ConstRef (Projection.constant p)) !object_table in c | _ -> raise Not_found diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index d8f01c6bb5..7362955eb7 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -130,7 +130,7 @@ module ReductionBehaviour = struct | _ -> None let rebuild = function - | req, (ConstRef c, _ as x) -> req, x + | req, (GlobRef.ConstRef c, _ as x) -> req, x | _ -> assert false let inRedBehaviour = declare_object { @@ -958,7 +958,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = then whrec (if refold then Cst_stack.add_cst (mkConstU const) cst_l else cst_l) (body, stack) else (* Looks for ReductionBehaviour *) - match ReductionBehaviour.get (Globnames.ConstRef c) with + match ReductionBehaviour.get (GlobRef.ConstRef c) with | None -> whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, stack) | Some behavior -> begin match behavior with @@ -1009,7 +1009,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = if not tactic_mode then let stack' = (c, Stack.Proj (p, Cst_stack.empty (*cst_l*)) :: stack) in whrec Cst_stack.empty stack' - else match ReductionBehaviour.get (Globnames.ConstRef (Projection.constant p)) with + else match ReductionBehaviour.get (GlobRef.ConstRef (Projection.constant p)) with | None -> let stack' = (c, Stack.Proj (p, cst_l) :: stack) in let stack'', csts = whrec Cst_stack.empty stack' in diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 6646dfb80c..6fdceb929a 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -67,13 +67,13 @@ let value_of_evaluable_ref env evref u = | EvalVarRef id -> env |> lookup_named id |> NamedDecl.get_value |> Option.get let evaluable_of_global_reference env = function - | ConstRef cst when is_evaluable_const env cst -> EvalConstRef cst - | VarRef id when is_evaluable_var env id -> EvalVarRef id + | GlobRef.ConstRef cst when is_evaluable_const env cst -> EvalConstRef cst + | GlobRef.VarRef id when is_evaluable_var env id -> EvalVarRef id | r -> error_not_evaluable r let global_of_evaluable_reference = function - | EvalConstRef cst -> ConstRef cst - | EvalVarRef id -> VarRef id + | EvalConstRef cst -> GlobRef.ConstRef cst + | EvalVarRef id -> GlobRef.VarRef id type evaluable_reference = | EvalConst of Constant.t @@ -597,7 +597,7 @@ let special_red_case env sigma whfun (ci, p, c, lf) = let recargs = function | EvalVar _ | EvalRel _ | EvalEvar _ -> None - | EvalConst c -> ReductionBehaviour.get (ConstRef c) + | EvalConst c -> ReductionBehaviour.get (GlobRef.ConstRef c) let reduce_projection env sigma p ~npars (recarg'hd,stack') stack = (match EConstr.kind sigma recarg'hd with @@ -786,7 +786,7 @@ and whd_simpl_stack env sigma = let unf = Projection.unfolded p in if unf || is_evaluable env (EvalConstRef (Projection.constant p)) then let npars = Projection.npars p in - (match unf, get (ConstRef (Projection.constant p)) with + (match unf, get (GlobRef.ConstRef (Projection.constant p)) with | false, Some NeverUnfold -> s' | false, Some (UnfoldWhen { recargs } | UnfoldWhenNoMatch { recargs }) when not (List.is_empty recargs) -> @@ -1101,7 +1101,7 @@ let string_of_evaluable_ref env = function | EvalVarRef id -> Id.to_string id | EvalConstRef kn -> string_of_qualid - (Nametab.shortest_qualid_of_global (vars_of_env env) (ConstRef kn)) + (Nametab.shortest_qualid_of_global (vars_of_env env) (GlobRef.ConstRef kn)) let unfold env sigma name c = if is_evaluable env name then @@ -1285,7 +1285,7 @@ let reduce_to_ref_gen allow_product env sigma ref t = if isIndRef ref then let ((mind,u),t) = reduce_to_ind_gen allow_product env sigma t in begin match ref with - | IndRef mind' when eq_ind mind mind' -> t + | GlobRef.IndRef mind' when eq_ind mind mind' -> t | _ -> error_cannot_recognize ref end else diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index 1d3e77452f..544fd3d17d 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -205,7 +205,7 @@ let build_subclasses ~check env sigma glob { hint_priority = pri } = | Some p, None -> Some (p + 1) | _, _ -> None in - Some (ConstRef proj, { info with hint_priority = newpri }, body)) tc.cl_projs + Some (GlobRef.ConstRef proj, { info with hint_priority = newpri }, body)) tc.cl_projs in let declare_proj hints (cref, info, body) = let path' = cref :: path in @@ -243,11 +243,11 @@ let instance_constructor (cl,u) args = let open EConstr in let pars = fst (List.chop lenpars args) in match cl.cl_impl with - | IndRef ind -> + | GlobRef.IndRef ind -> let ind = ind, u in (Some (applist (mkConstructUi (ind, 1), args)), applist (mkIndU ind, pars)) - | ConstRef cst -> + | GlobRef.ConstRef cst -> let cst = cst, u in let term = match args with | [] -> None diff --git a/printing/prettyp.ml b/printing/prettyp.ml index a2bdb30773..f82b9cef68 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -68,7 +68,7 @@ let int_or_no n = if Int.equal n 0 then str "no" else int n (*******************) (** Basic printing *) -let print_basename sp = pr_global (ConstRef sp) +let print_basename sp = pr_global (GlobRef.ConstRef sp) let print_ref reduce ref udecl = let env = Global.env () in @@ -82,7 +82,7 @@ let print_ref reduce ref udecl = let ctx,ccl = Reductionops.splay_prod_assum env sigma typ in EConstr.it_mkProd_or_LetIn ccl ctx else typ in - let variance = match ref with + let variance = let open GlobRef in match ref with | VarRef _ | ConstRef _ -> None | IndRef (ind,_) | ConstructRef ((ind,_),_) -> let mind = Environ.lookup_mind ind env in @@ -114,7 +114,7 @@ let print_impargs_by_name max = function let print_one_impargs_list l = let imps = List.filter is_status_implicit l in let maximps = List.filter Impargs.maximal_insertion_of imps in - let nonmaximps = List.subtract Pervasives.(=) imps maximps in (* FIXME *) + let nonmaximps = List.subtract (=) imps maximps in (* FIXME *) print_impargs_by_name false nonmaximps @ print_impargs_by_name true maximps @@ -184,10 +184,10 @@ type opacity = let opacity env = function - | VarRef v when NamedDecl.is_local_def (Environ.lookup_named v env) -> + | GlobRef.VarRef v when NamedDecl.is_local_def (Environ.lookup_named v env) -> Some(TransparentMaybeOpacified (Conv_oracle.get_strategy (Environ.oracle env) (VarKey v))) - | ConstRef cst -> + | GlobRef.ConstRef cst -> let cb = Environ.lookup_constant cst env in (match cb.const_body with | Undef _ | Primitive _ -> None @@ -247,7 +247,7 @@ let print_primitive_record recflag mipv = function let print_primitive ref = match ref with - | IndRef ind -> + | GlobRef.IndRef ind -> let mib,_ = Global.lookup_inductive ind in print_primitive_record mib.mind_finite mib.mind_packets mib.mind_record | _ -> [] @@ -281,10 +281,10 @@ let print_id_args_data test pr id l = let print_args_data_of_inductive_ids get test pr sp mipv = List.flatten (Array.to_list (Array.mapi (fun i mip -> - print_id_args_data test pr mip.mind_typename (get (IndRef (sp,i))) @ + print_id_args_data test pr mip.mind_typename (get (GlobRef.IndRef (sp,i))) @ List.flatten (Array.to_list (Array.mapi (fun j idc -> - print_id_args_data test pr idc (get (ConstructRef ((sp,i),j+1)))) + print_id_args_data test pr idc (get (GlobRef.ConstructRef ((sp,i),j+1)))) mip.mind_consnames))) mipv)) @@ -358,7 +358,7 @@ let locate_any_name qid = let pr_located_qualid = function | Term ref -> - let ref_str = match ref with + let ref_str = let open GlobRef in match ref with ConstRef _ -> "Constant" | IndRef _ -> "Inductive" | ConstructRef _ -> "Constructor" @@ -382,7 +382,7 @@ let pr_located_qualid = function | Undefined qid -> pr_qualid qid ++ spc () ++ str "not a defined object." -let canonize_ref = function +let canonize_ref = let open GlobRef in function | ConstRef c -> let kn = Constant.canonical c in if KerName.equal (Constant.user c) kn then None @@ -537,7 +537,7 @@ let print_named_decl env sigma id = let gallina_print_section_variable env sigma id = print_named_decl env sigma id ++ - with_line_skip (print_name_infos (VarRef id)) + with_line_skip (print_name_infos (GlobRef.VarRef id)) let print_body env evd = function | Some c -> pr_lconstr_env env evd c @@ -595,7 +595,7 @@ let print_constant with_values sep sp udecl = let gallina_print_constant_with_infos sp udecl = print_constant true " = " sp udecl ++ - with_line_skip (print_name_infos (ConstRef sp)) + with_line_skip (print_name_infos (GlobRef.ConstRef sp)) let gallina_print_syntactic_def env kn = let qid = Nametab.shortest_qualid_of_syndef Id.Set.empty kn @@ -611,9 +611,11 @@ let gallina_print_syntactic_def env kn = [Notation.SynDefRule kn] (pr_glob_constr_env env) c) let gallina_print_leaf_entry env sigma with_values ((sp,kn as oname),lobj) = - let sep = if with_values then " = " else " : " - and tag = object_tag lobj in - match (oname,tag) with + let sep = if with_values then " = " else " : " in + match lobj with + | AtomicObject o -> + let tag = object_tag o in + begin match (oname,tag) with | (_,"VARIABLE") -> (* Outside sections, VARIABLES still exist but only with universes constraints *) @@ -622,16 +624,18 @@ let gallina_print_leaf_entry env sigma with_values ((sp,kn as oname),lobj) = Some (print_constant with_values sep (Constant.make1 kn) None) | (_,"INDUCTIVE") -> Some (gallina_print_inductive (MutInd.make1 kn) None) - | (_,"MODULE") -> - let (mp,l) = KerName.repr kn in - Some (print_module with_values (MPdot (mp,l))) - | (_,"MODULE TYPE") -> - let (mp,l) = KerName.repr kn in - Some (print_modtype (MPdot (mp,l))) | (_,("AUTOHINT"|"GRAMMAR"|"SYNTAXCONSTANT"|"PPSYNTAX"|"TOKEN"|"CLASS"| "COERCION"|"REQUIRE"|"END-SECTION"|"STRUCTURE")) -> None (* To deal with forgotten cases... *) | (_,s) -> None + end + | ModuleObject _ -> + let (mp,l) = KerName.repr kn in + Some (print_module with_values (MPdot (mp,l))) + | ModuleTypeObject _ -> + let (mp,l) = KerName.repr kn in + Some (print_modtype (MPdot (mp,l))) + | _ -> None let gallina_print_library_entry env sigma with_values ent = let pr_name (sp,_) = Id.print (basename sp) in @@ -713,7 +717,7 @@ let print_full_context_typ env sigma = print_context env sigma false None (Lib.c let print_full_pure_context env sigma = let rec prec = function - | ((_,kn),Lib.Leaf lobj)::rest -> + | ((_,kn),Lib.Leaf AtomicObject lobj)::rest -> let pp = match object_tag lobj with | "CONSTANT" -> let con = Global.constant_of_delta_kn kn in @@ -741,17 +745,16 @@ let print_full_pure_context env sigma = let mib = Global.lookup_mind mind in pr_mutual_inductive_body (Global.env()) mind mib None ++ str "." ++ fnl () ++ fnl () - | "MODULE" -> - (* TODO: make it reparsable *) - let (mp,l) = KerName.repr kn in - print_module true (MPdot (mp,l)) ++ str "." ++ fnl () ++ fnl () - | "MODULE TYPE" -> - (* TODO: make it reparsable *) - (* TODO: make it reparsable *) - let (mp,l) = KerName.repr kn in - print_modtype (MPdot (mp,l)) ++ str "." ++ fnl () ++ fnl () | _ -> mt () in prec rest ++ pp + | ((_,kn),Lib.Leaf ModuleObject _)::rest -> + (* TODO: make it reparsable *) + let (mp,l) = KerName.repr kn in + prec rest ++ print_module true (MPdot (mp,l)) ++ str "." ++ fnl () ++ fnl () + | ((_,kn),Lib.Leaf ModuleTypeObject _)::rest -> + (* TODO: make it reparsable *) + let (mp,l) = KerName.repr kn in + prec rest ++ print_modtype (MPdot (mp,l)) ++ str "." ++ fnl () ++ fnl () | _::rest -> prec rest | _ -> mt () in prec (Lib.contents ()) @@ -783,6 +786,7 @@ let print_sec_context_typ env sigma sec = print_context env sigma false None (read_sec_context sec) let maybe_error_reject_univ_decl na udecl = + let open GlobRef in match na, udecl with | _, None | Term (ConstRef _ | IndRef _ | ConstructRef _), Some _ -> () | (Term (VarRef _) | Syntactic _ | Dir _ | ModuleType _ | Other _ | Undefined _), Some udecl -> @@ -791,6 +795,7 @@ let maybe_error_reject_univ_decl na udecl = let print_any_name env sigma na udecl = maybe_error_reject_univ_decl na udecl; + let open GlobRef in match na with | Term (ConstRef sp) -> print_constant_with_infos sp udecl | Term (IndRef (sp,_)) -> print_inductive sp udecl @@ -822,6 +827,7 @@ let print_name env sigma na udecl = print_any_name env sigma (locate_any_name ref) udecl let print_opaque_name env sigma qid = + let open GlobRef in match Nametab.global qid with | ConstRef cst -> let cb = Global.lookup_constant cst in diff --git a/printing/printer.ml b/printing/printer.ml index 1f68018678..97b3233d12 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -15,7 +15,6 @@ open Names open Constr open Context open Environ -open Globnames open Evd open Refiner open Constrextern @@ -155,7 +154,7 @@ let pr_in_comment x = str "(* " ++ x ++ str " *)" the [mutual_inductive_body] for the inductives and constructors (needs an environment for this). *) -let id_of_global env = function +let id_of_global env = let open GlobRef in function | ConstRef kn -> Label.to_id (Constant.label kn) | IndRef (kn,0) -> Label.to_id (MutInd.label kn) | IndRef (kn,i) -> @@ -170,7 +169,7 @@ let rec dirpath_of_mp = function | MPdot (mp,l) -> Libnames.add_dirpath_suffix (dirpath_of_mp mp) (Label.to_id l) -let dirpath_of_global = function +let dirpath_of_global = let open GlobRef in function | ConstRef kn -> dirpath_of_mp (Constant.modpath kn) | IndRef (kn,_) | ConstructRef ((kn,_),_) -> dirpath_of_mp (MutInd.modpath kn) @@ -251,7 +250,7 @@ let pr_puniverses f env sigma (c,u) = then f env c ++ pr_universe_instance sigma u else f env c -let pr_constant env cst = pr_global_env (Termops.vars_of_env env) (ConstRef cst) +let pr_constant env cst = pr_global_env (Termops.vars_of_env env) (GlobRef.ConstRef cst) let pr_existential_key = Termops.pr_existential_key let pr_existential env sigma ev = pr_lconstr_env env sigma (mkEvar ev) let pr_inductive env ind = pr_lconstr_env env (Evd.from_env env) (mkInd ind) diff --git a/printing/printmod.ml b/printing/printmod.ml index 74d4f69c9c..43992ec9d3 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -15,7 +15,6 @@ open Pp open Names open Environ open Declarations -open Globnames open Libnames open Goptions @@ -231,13 +230,13 @@ let nametab_register_body mp dir (l,body) = | SFBmodule _ -> () (* TODO *) | SFBmodtype _ -> () (* TODO *) | SFBconst _ -> - push (Label.to_id l) (ConstRef (Constant.make2 mp l)) + push (Label.to_id l) (GlobRef.ConstRef (Constant.make2 mp l)) | SFBmind mib -> let mind = MutInd.make2 mp l in Array.iteri (fun i mip -> - push mip.mind_typename (IndRef (mind,i)); - Array.iteri (fun j id -> push id (ConstructRef ((mind,i),j+1))) + push mip.mind_typename (GlobRef.IndRef (mind,i)); + Array.iteri (fun j id -> push id (GlobRef.ConstructRef ((mind,i),j+1))) mip.mind_consnames) mib.mind_packets diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index 044ac29e92..909804d0c9 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -115,7 +115,7 @@ module Make(T : Task) () = struct type process = Worker.process type extra = (T.task * cancel_switch) TQueue.t - let spawn id = + let spawn id priority = let name = Printf.sprintf "%s:%d" !T.name id in let proc, ic, oc = (* Filter arguments for slaves. *) @@ -123,9 +123,9 @@ module Make(T : Task) () = struct | [] -> !async_proofs_flags_for_workers @ ["-worker-id"; name; "-async-proofs-worker-priority"; - CoqworkmgrApi.(string_of_priority !async_proofs_worker_priority)] + CoqworkmgrApi.(string_of_priority priority)] (* Options to discard: 0 arguments *) - | ("-emacs"|"-batch")::tl -> + | "-emacs"::tl -> set_slave_opt tl (* Options to discard: 1 argument *) | ( "-async-proofs" | "-vio2vo" | "-o" @@ -155,8 +155,8 @@ module Make(T : Task) () = struct let args = Array.of_list (set_slave_opt (List.tl (Array.to_list Sys.argv))) in let env = Array.append (T.extra_env ()) (Unix.environment ()) in - let worker_name = System.get_toplevel_path ("coq" ^ !T.name) in - Worker.spawn ~env worker_name args in + let worker_name = System.get_toplevel_path ("coq" ^ !T.name) in + Worker.spawn ~env worker_name args in name, proc, CThread.prepare_in_channel_for_thread_friendly_io ic, oc let manager cpanel (id, proc, ic, oc) = @@ -262,7 +262,7 @@ module Make(T : Task) () = struct cleaner : Thread.t option; } - let create size = + let create size priority = let cleaner queue = while true do try ignore(TQueue.pop ~picky:(fun (_,cancelled) -> !cancelled) queue) @@ -270,7 +270,7 @@ module Make(T : Task) () = struct done in let queue = TQueue.create () in { - active = Pool.create queue ~size; + active = Pool.create queue ~size priority; queue; cleaner = if size > 0 then Some (CThread.create cleaner queue) else None; } @@ -369,8 +369,8 @@ module Make(T : Task) () = struct (TQueue.wait_until_n_are_waiting_then_snapshot (Pool.n_workers active) queue) - let with_n_workers n f = - let q = create n in + let with_n_workers n priority f = + let q = create n priority in try let rc = f q in destroy q; rc with e -> let e = CErrors.push e in destroy q; iraise e diff --git a/stm/asyncTaskQueue.mli b/stm/asyncTaskQueue.mli index a9a215acc8..e6cf6343c8 100644 --- a/stm/asyncTaskQueue.mli +++ b/stm/asyncTaskQueue.mli @@ -68,10 +68,10 @@ module type Task = sig type request type response - (** UID of the task kind, for -toploop *) + (** UID of the task kind *) val name : string ref - (** Extra arguments of the task kind, for -toploop *) + (** Extra arguments of the task kind *) val extra_env : unit -> string array (** {5 Master API, it is run by the master, on a thread} *) @@ -144,10 +144,10 @@ module MakeQueue(T : Task) () : sig (** [queue] is the abstract queue type. *) type queue - (** [create n] will initialize the queue with [n] workers. If [n] is - 0, the queue won't spawn any process, working in a lazy local - manner. [not imposed by the this API] *) - val create : int -> queue + (** [create n pri] will initialize the queue with [n] workers having + priority [pri]. If [n] is 0, the queue won't spawn any process, + working in a lazy local manner. [not imposed by the this API] *) + val create : int -> CoqworkmgrApi.priority -> queue (** [destroy q] Deallocates [q], cancelling all pending tasks. *) val destroy : queue -> unit @@ -203,9 +203,9 @@ module MakeQueue(T : Task) () : sig (** [clear q] Clears [q], only if the worker prool is empty *) val clear : queue -> unit - (** [with_n_workers n f] create a queue, run the function, destroy + (** [with_n_workers n pri f] creates a queue, runs the function, destroys the queue. The user should call join *) - val with_n_workers : int -> (queue -> 'a) -> 'a + val with_n_workers : int -> CoqworkmgrApi.priority -> (queue -> 'a) -> 'a end diff --git a/stm/coqworkmgrApi.ml b/stm/coqworkmgrApi.ml index c21f057742..92dc77172f 100644 --- a/stm/coqworkmgrApi.ml +++ b/stm/coqworkmgrApi.ml @@ -13,7 +13,8 @@ let debug = false type priority = Low | High (* Default priority *) -let async_proofs_worker_priority = ref Low + +let default_async_proofs_worker_priority = Low let string_of_priority = function Low -> "low" | High -> "high" let priority_of_string = function diff --git a/stm/coqworkmgrApi.mli b/stm/coqworkmgrApi.mli index d53af84071..29eba5bc91 100644 --- a/stm/coqworkmgrApi.mli +++ b/stm/coqworkmgrApi.mli @@ -15,7 +15,7 @@ val string_of_priority : priority -> string val priority_of_string : string -> priority (* Default priority *) -val async_proofs_worker_priority : priority ref +val default_async_proofs_worker_priority : priority (* Connects to a work manager if any. If no worker manager, then -async-proofs-j and -async-proofs-tac-j are used *) diff --git a/stm/stm.ml b/stm/stm.ml index e04277b052..9bbff476f8 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -51,6 +51,8 @@ module AsyncOpts = struct async_proofs_tac_error_resilience : tac_error_filter; async_proofs_cmd_error_resilience : bool; async_proofs_delegation_threshold : float; + + async_proofs_worker_priority : CoqworkmgrApi.priority; } let default_opts = { @@ -67,6 +69,8 @@ module AsyncOpts = struct async_proofs_tac_error_resilience = `Only [ "curly" ]; async_proofs_cmd_error_resilience = true; async_proofs_delegation_threshold = 0.03; + + async_proofs_worker_priority = CoqworkmgrApi.Low; } let cur_opt = ref default_opts @@ -116,13 +120,12 @@ let call = get let call_process_error_once = let processed : unit Exninfo.t = Exninfo.make () in - fun (_, info as ei) -> + fun (e, info) -> match Exninfo.get info processed with - | Some _ -> ei + | Some _ -> e, info | None -> - let e, info = ExplainErr.process_vernac_interp_error ei in - let info = Exninfo.add info processed () in - e, info + let info = Exninfo.add info processed () in + e, info end @@ -1636,7 +1639,7 @@ and Slaves : sig val wait_all_done : unit -> unit (* initialize the whole machinery (optional) *) - val init : unit -> unit + val init : CoqworkmgrApi.priority -> unit type 'a tasks = (('a,VCS.vcs) Stateid.request * bool) list val dump_snapshot : unit -> Future.UUID.t tasks @@ -1658,11 +1661,11 @@ end = struct (* {{{ *) module TaskQueue = AsyncTaskQueue.MakeQueue(ProofTask) () let queue = ref None - let init () = + let init priority = if async_proofs_is_master !cur_opt then - queue := Some (TaskQueue.create !cur_opt.async_proofs_n_workers) + queue := Some (TaskQueue.create !cur_opt.async_proofs_n_workers priority) else - queue := Some (TaskQueue.create 0) + queue := Some (TaskQueue.create 0 priority) let check_task_aux extra name l i = let { Stateid.stop; document; loc; name = r_name }, drop = List.nth l i in @@ -1978,7 +1981,7 @@ and Partac : sig val vernac_interp : solve:bool -> abstract:bool -> cancel_switch:AsyncTaskQueue.cancel_switch -> - int -> Stateid.t -> Stateid.t -> aast -> unit + int -> CoqworkmgrApi.priority -> Stateid.t -> Stateid.t -> aast -> unit end = struct (* {{{ *) @@ -1990,7 +1993,7 @@ end = struct (* {{{ *) else f () - let vernac_interp ~solve ~abstract ~cancel_switch nworkers safe_id id + let vernac_interp ~solve ~abstract ~cancel_switch nworkers priority safe_id id { indentation; verbose; expr = e; strlen } : unit = let e, time, batch, fail = @@ -2003,7 +2006,7 @@ end = struct (* {{{ *) let st = Vernacstate.freeze_interp_state ~marshallable:false in stm_fail ~st fail (fun () -> (if time then System.with_time ~batch ~header:(Pp.mt ()) else (fun x -> x)) (fun () -> - TaskQueue.with_n_workers nworkers (fun queue -> + TaskQueue.with_n_workers nworkers priority (fun queue -> PG_compat.map_proof (fun p -> let Proof.{goals} = Proof.data p in let open TacTask in @@ -2118,7 +2121,7 @@ end (* }}} *) and Query : sig - val init : unit -> unit + val init : CoqworkmgrApi.priority -> unit val vernac_interp : cancel_switch:AsyncTaskQueue.cancel_switch -> Stateid.t -> Stateid.t -> aast -> unit end = struct (* {{{ *) @@ -2132,7 +2135,7 @@ end = struct (* {{{ *) TaskQueue.enqueue_task (Option.get !queue) QueryTask.({ t_where = prev; t_for = id; t_what = q }) ~cancel_switch - let init () = queue := Some (TaskQueue.create 0) + let init priority = queue := Some (TaskQueue.create 0 priority) end (* }}} *) @@ -2410,7 +2413,8 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = resilient_tactic id cblock (fun () -> reach ~cache:true view.next; Partac.vernac_interp ~solve ~abstract ~cancel_switch - !cur_opt.async_proofs_n_tacworkers view.next id x) + !cur_opt.async_proofs_n_tacworkers + !cur_opt.async_proofs_worker_priority view.next id x) ), cache, true | `Cmd { cast = x; cqueue = `QueryQueue cancel_switch } when async_proofs_is_master !cur_opt -> (fun () -> @@ -2423,8 +2427,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = (* State resulting from reach *) let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp id st x) - ); - if eff then update_global_env () + ) ), eff || cache, true | `Cmd { cast = x; ceff = eff } -> (fun () -> (match !cur_opt.async_proofs_mode with @@ -2432,8 +2435,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = resilient_command reach view.next | APoff -> reach view.next); let st = Vernacstate.freeze_interp_state ~marshallable:false in - ignore(stm_vernac_interp id st x); - if eff then update_global_env () + ignore(stm_vernac_interp id st x) ), eff || cache, true | `Fork ((x,_,_,_), None) -> (fun () -> resilient_command reach view.next; @@ -2562,8 +2564,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = | `Sideff (ReplayCommand x,_) -> (fun () -> reach view.next; let st = Vernacstate.freeze_interp_state ~marshallable:false in - ignore(stm_vernac_interp id st x); - update_global_env () + ignore(stm_vernac_interp id st x) ), cache, true | `Sideff (CherryPickEnv, origin) -> (fun () -> reach view.next; @@ -2682,10 +2683,10 @@ let new_doc { doc_type ; iload_path; require_libs; stm_options } = (* We record the state at this point! *) State.define ~doc ~cache:true ~redefine:true (fun () -> ()) Stateid.initial; Backtrack.record (); - Slaves.init (); + Slaves.init stm_options.async_proofs_worker_priority; if async_proofs_is_master !cur_opt then begin stm_prerr_endline (fun () -> "Initializing workers"); - Query.init (); + Query.init stm_options.async_proofs_worker_priority; let opts = match !cur_opt.async_proofs_private_flags with | None -> [] | Some s -> Str.split_delim (Str.regexp ",") s in diff --git a/stm/stm.mli b/stm/stm.mli index 92a782d965..29e4b02e3f 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -34,6 +34,8 @@ module AsyncOpts : sig async_proofs_tac_error_resilience : tac_error_filter; async_proofs_cmd_error_resilience : bool; async_proofs_delegation_threshold : float; + + async_proofs_worker_priority : CoqworkmgrApi.priority; } val default_opts : stm_opt diff --git a/stm/workerPool.ml b/stm/workerPool.ml index 15c6510f7c..f77ced2f3a 100644 --- a/stm/workerPool.ml +++ b/stm/workerPool.ml @@ -19,7 +19,7 @@ type 'a cpanel = { module type PoolModel = sig (* this shall come from a Spawn.* model *) type process - val spawn : int -> worker_id * process * CThread.thread_ic * out_channel + val spawn : int -> CoqworkmgrApi.priority -> worker_id * process * CThread.thread_ic * out_channel (* this defines the main loop of the manager *) type extra @@ -79,20 +79,20 @@ let locking { lock; pool = p } f = x with e -> Mutex.unlock lock; raise e -let rec create_worker extra pool id = +let rec create_worker extra pool priority id = let cancel = ref false in - let name, process, ic, oc as worker = Model.spawn id in + let name, process, ic, oc as worker = Model.spawn id priority in master_handshake name ic oc; - let exit () = cancel := true; cleanup pool; Thread.exit () in + let exit () = cancel := true; cleanup pool priority; Thread.exit () in let cancelled () = !cancel in let cpanel = { exit; cancelled; extra } in let manager = CThread.create (Model.manager cpanel) worker in { name; cancel; manager; process } -and cleanup x = locking x begin fun { workers; count; extra_arg } -> +and cleanup x priority = locking x begin fun { workers; count; extra_arg } -> workers := List.map (function | { cancel } as w when !cancel = false -> w - | _ -> let n = !count in incr count; create_worker extra_arg x n) + | _ -> let n = !count in incr count; create_worker extra_arg x priority n) !workers end @@ -102,7 +102,7 @@ end let is_empty x = locking x begin fun { workers } -> !workers = [] end -let create extra_arg ~size = let x = { +let create extra_arg ~size priority = let x = { lock = Mutex.create (); pool = { extra_arg; @@ -110,7 +110,7 @@ let create extra_arg ~size = let x = { count = ref size; }} in locking x begin fun { workers } -> - workers := CList.init size (create_worker extra_arg x) + workers := CList.init size (create_worker extra_arg x priority) end; x diff --git a/stm/workerPool.mli b/stm/workerPool.mli index 5a6c968993..5468a24959 100644 --- a/stm/workerPool.mli +++ b/stm/workerPool.mli @@ -19,7 +19,8 @@ type 'a cpanel = { module type PoolModel = sig (* this shall come from a Spawn.* model *) type process - val spawn : int -> worker_id * process * CThread.thread_ic * out_channel + val spawn : int -> CoqworkmgrApi.priority -> + worker_id * process * CThread.thread_ic * out_channel (* this defines the main loop of the manager *) type extra @@ -31,7 +32,7 @@ module Make(Model : PoolModel) : sig type pool - val create : Model.extra -> size:int -> pool + val create : Model.extra -> size:int -> CoqworkmgrApi.priority -> pool val is_empty : pool -> bool val n_workers : pool -> int diff --git a/tactics/abstract.ml b/tactics/abstract.ml index 662a2fc22c..09d7e0278a 100644 --- a/tactics/abstract.ml +++ b/tactics/abstract.ml @@ -13,7 +13,6 @@ module CVars = Vars open Util open Termops open EConstr -open Decl_kinds open Evarutil module RelDecl = Context.Rel.Declaration @@ -153,12 +152,12 @@ let cache_term_by_tactic_then ~opaque ~name_op ?(goal_type=None) tac tacK = let const, args = shrink_entry sign const in let args = List.map EConstr.of_constr args in let cd = Declare.DefinitionEntry { const with Proof_global.proof_entry_opaque = opaque } in - let decl = (cd, if opaque then IsProof Lemma else IsDefinition Definition) in + let kind = if opaque then Decls.(IsProof Lemma) else Decls.(IsDefinition Definition) in let cst () = (* do not compute the implicit arguments, it may be costly *) let () = Impargs.make_implicit_args false in (* ppedrot: seems legit to have abstracted subproofs as local*) - Declare.declare_private_constant ~local:Declare.ImportNeedQualified name decl + Declare.declare_private_constant ~local:Declare.ImportNeedQualified ~name ~kind cd in let cst, eff = Impargs.with_implicit_protection cst () in let inst = match const.Proof_global.proof_entry_universes with diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml index a476381b17..d0816b266f 100644 --- a/tactics/btermdn.ml +++ b/tactics/btermdn.ml @@ -13,7 +13,6 @@ open Constr open EConstr open Names open Pattern -open Globnames (* Discrimination nets with bounded depth. See the module dn.ml for further explanations. @@ -29,14 +28,14 @@ type term_label = let compare_term_label t1 t2 = match t1, t2 with | GRLabel gr1, GRLabel gr2 -> GlobRef.Ordered.compare gr1 gr2 -| _ -> Pervasives.compare t1 t2 (** OK *) +| _ -> pervasives_compare t1 t2 (** OK *) type 'res lookup_res = 'res Dn.lookup_res = Label of 'res | Nothing | Everything let decomp_pat = let rec decrec acc = function | PApp (f,args) -> decrec (Array.to_list args @ acc) f - | PProj (p, c) -> (PRef (ConstRef (Projection.constant p)), c :: acc) + | PProj (p, c) -> (PRef (GlobRef.ConstRef (Projection.constant p)), c :: acc) | c -> (c,acc) in decrec [] @@ -51,6 +50,7 @@ let decomp sigma t = decrec [] t let constr_val_discr sigma t = + let open GlobRef in let c, l = decomp sigma t in match EConstr.kind sigma c with | Ind (ind_sp,u) -> Label(GRLabel (IndRef ind_sp),l) @@ -63,6 +63,7 @@ let constr_pat_discr t = if not (Patternops.occur_meta_pattern t) then None else + let open GlobRef in match decomp_pat t with | PRef ((IndRef _) as ref), args | PRef ((ConstructRef _ ) as ref), args -> Some (GRLabel ref,args) @@ -71,6 +72,7 @@ let constr_pat_discr t = let constr_val_discr_st sigma ts t = let c, l = decomp sigma t in + let open GlobRef in match EConstr.kind sigma c with | Const (c,u) -> if TransparentState.is_transparent_constant ts c then Everything else Label(GRLabel (ConstRef c),l) | Ind (ind_sp,u) -> Label(GRLabel (IndRef ind_sp),l) @@ -86,6 +88,7 @@ let constr_val_discr_st sigma ts t = | _ -> Nothing let constr_pat_discr_st ts t = + let open GlobRef in match decomp_pat t with | PRef ((IndRef _) as ref), args | PRef ((ConstructRef _ ) as ref), args -> Some (GRLabel ref,args) diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 303ddacb67..05f40d0570 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -25,7 +25,6 @@ open Tacmach open Tactics open Clenv open Typeclasses -open Globnames open Evd open Locus open Proofview.Notations @@ -257,7 +256,7 @@ let clenv_of_prods poly nprods (c, clenv) gl = let sigma = Tacmach.New.project gl in let ty = Retyping.get_type_of (Proofview.Goal.env gl) sigma c in let diff = nb_prod sigma ty - nprods in - if Pervasives.(>=) diff 0 then + if (>=) diff 0 then (* Was Some clenv... *) Some (Some diff, mk_clenv_from_n gl (Some diff) (c,ty)) @@ -517,8 +516,8 @@ let make_resolve_hyp env sigma st flags only_classes pri decl = let rec iscl env ty = let ctx, ar = decompose_prod_assum sigma ty in match EConstr.kind sigma (fst (decompose_app sigma ar)) with - | Const (c,_) -> is_class (ConstRef c) - | Ind (i,_) -> is_class (IndRef i) + | Const (c,_) -> is_class (GlobRef.ConstRef c) + | Ind (i,_) -> is_class (GlobRef.IndRef i) | _ -> let env' = push_rel_context ctx env in let ty' = Reductionops.whd_all env' sigma ar in @@ -529,10 +528,10 @@ let make_resolve_hyp env sigma st flags only_classes pri decl = let keep = not only_classes || is_class in if keep then let c = mkVar id in - let name = PathHints [VarRef id] in + let name = PathHints [GlobRef.VarRef id] in let hints = if is_class then - let hints = build_subclasses ~check:false env sigma (VarRef id) empty_hint_info in + let hints = build_subclasses ~check:false env sigma (GlobRef.VarRef id) empty_hint_info in (List.map_append (fun (path,info,c) -> make_resolves env sigma ~name:(PathHints path) diff --git a/tactics/declare.ml b/tactics/declare.ml index aa94ab5a25..b8ba62a5e5 100644 --- a/tactics/declare.ml +++ b/tactics/declare.ml @@ -11,32 +11,47 @@ (** This module is about the low-level declaration of logical objects *) open Pp -open CErrors open Util open Names -open Libnames -open Globnames -open Constr open Declarations open Entries +open Safe_typing open Libobject open Lib -open Impargs -open Safe_typing -open Cooking -open Decls -open Decl_kinds + +(* object_kind , id *) +exception AlreadyDeclared of (string option * Id.t) + +let _ = CErrors.register_handler (function + | AlreadyDeclared (kind, id) -> + seq [ Pp.pr_opt_no_spc (fun s -> str s ++ spc ()) kind + ; Id.print id; str " already exists."] + | _ -> + raise CErrors.Unhandled) module NamedDecl = Context.Named.Declaration type import_status = ImportDefaultBehavior | ImportNeedQualified +(** Monomorphic universes need to survive sections. *) + +let input_universe_context : Univ.ContextSet.t -> Libobject.obj = + declare_object @@ local_object "Monomorphic section universes" + ~cache:(fun (na, uctx) -> Global.push_context_set false uctx) + ~discharge:(fun (_, x) -> Some x) + +let declare_universe_context ~poly ctx = + if poly then + (Global.push_context_set true ctx; Lib.add_section_context ctx) + else + Lib.add_anonymous_leaf (input_universe_context ctx) + (** Declaration of constants and parameters *) type constant_obj = { cst_decl : Cooking.recipe option; (** Non-empty only when rebuilding a constant after a section *) - cst_kind : logical_kind; + cst_kind : Decls.logical_kind; cst_locl : import_status; } @@ -45,16 +60,14 @@ type 'a constant_entry = | ParameterEntry of parameter_entry | PrimitiveEntry of primitive_entry -type constant_declaration = Evd.side_effects constant_entry * logical_kind - (* At load-time, the segment starting from the module name to the discharge *) (* section (if Remark or Fact) is needed to access a construction *) let load_constant i ((sp,kn), obj) = if Nametab.exists_cci sp then - alreadydeclared (Id.print (basename sp) ++ str " already exists"); + raise (AlreadyDeclared (None, Libnames.basename sp)); let con = Global.constant_of_delta_kn kn in - Nametab.push (Nametab.Until i) sp (ConstRef con); - add_constant_kind con obj.cst_kind + Nametab.push (Nametab.Until i) sp (GlobRef.ConstRef con); + Dumpglob.add_constant_kind con obj.cst_kind let cooking_info segment = let modlist = replacement_context () in @@ -70,32 +83,33 @@ let open_constant i ((sp,kn), obj) = | ImportNeedQualified -> () | ImportDefaultBehavior -> let con = Global.constant_of_delta_kn kn in - Nametab.push (Nametab.Exactly i) sp (ConstRef con) + Nametab.push (Nametab.Exactly i) sp (GlobRef.ConstRef con) let exists_name id = - variable_exists id || Global.exists_objlabel (Label.of_id id) + Decls.variable_exists id || Global.exists_objlabel (Label.of_id id) let check_exists id = - if exists_name id then alreadydeclared (Id.print id ++ str " already exists") + if exists_name id then + raise (AlreadyDeclared (None, id)) let cache_constant ((sp,kn), obj) = (* Invariant: the constant must exist in the logical environment, except when redefining it when exiting a section. See [discharge_constant]. *) - let id = basename sp in + let id = Libnames.basename sp in let kn' = match obj.cst_decl with | None -> - if Global.exists_objlabel (Label.of_id (basename sp)) + if Global.exists_objlabel (Label.of_id (Libnames.basename sp)) then Constant.make1 kn - else CErrors.anomaly Pp.(str"Missing constant " ++ Id.print(basename sp) ++ str".") + else CErrors.anomaly Pp.(str"Missing constant " ++ Id.print(Libnames.basename sp) ++ str".") | Some r -> Global.add_recipe ~in_section:(Lib.sections_are_opened ()) id r in assert (Constant.equal kn' (Constant.make1 kn)); - Nametab.push (Nametab.Until 1) sp (ConstRef (Constant.make1 kn)); + Nametab.push (Nametab.Until 1) sp (GlobRef.ConstRef (Constant.make1 kn)); let cst = Global.lookup_constant kn' in add_section_constant ~poly:(Declareops.constant_is_polymorphic cst) kn' cst.const_hyps; - add_constant_kind (Constant.make1 kn) obj.cst_kind + Dumpglob.add_constant_kind (Constant.make1 kn) obj.cst_kind let discharge_constant ((sp, kn), obj) = let con = Constant.make1 kn in @@ -103,7 +117,7 @@ let discharge_constant ((sp, kn), obj) = let info = cooking_info (section_segment_of_constant con) in (* This is a hack: when leaving a section, we lose the constant definition, so we have to store it in the libobject to be able to retrieve it after. *) - Some { obj with cst_decl = Some { from; info } } + Some { obj with cst_decl = Some { Cooking.from; info } } (* Hack to reduce the size of .vo: we keep only what load/open needs *) let dummy_constant cst = { @@ -127,8 +141,8 @@ let declare_scheme = ref (fun _ _ -> assert false) let set_declare_scheme f = declare_scheme := f let update_tables c = - declare_constant_implicits c; - Notation.declare_ref_arguments_scope Evd.empty (ConstRef c) + Impargs.declare_constant_implicits c; + Notation.declare_ref_arguments_scope Evd.empty (GlobRef.ConstRef c) let register_constant kn kind local = let o = inConstant { @@ -141,7 +155,7 @@ let register_constant kn kind local = update_tables kn let register_side_effect (c, role) = - let () = register_constant c (IsProof Theorem) ImportDefaultBehavior in + let () = register_constant c Decls.(IsProof Theorem) ImportDefaultBehavior in match role with | None -> () | Some (Evd.Schema (ind, kind)) -> !declare_scheme kind [|ind,c|] @@ -180,7 +194,7 @@ let cast_proof_entry e = (* This can actually happen, try compiling EqdepFacts for instance *) Monomorphic_entry (Univ.ContextSet.union ctx' ctx) | Polymorphic_entry _ -> - anomaly Pp.(str "Local universes in non-opaque polymorphic definition."); + CErrors.anomaly Pp.(str "Local universes in non-opaque polymorphic definition."); in { const_entry_body = body; @@ -191,7 +205,7 @@ let cast_proof_entry e = const_entry_inline_code = e.proof_entry_inline_code; } -let cast_opaque_proof_entry (type a) (pure : a Safe_typing.effect_entry) (e : a Proof_global.proof_entry) = +let cast_opaque_proof_entry e = let open Proof_global in let typ = match e.proof_entry_type with | None -> assert false @@ -206,14 +220,8 @@ let cast_opaque_proof_entry (type a) (pure : a Safe_typing.effect_entry) (e : a Id.Set.empty, Id.Set.empty else let ids_typ = global_vars_set env typ in - let pf, env = match pure with - | PureEntry -> - let (pf, _), () = Future.force e.proof_entry_body in - pf, env - | EffectEntry -> - let (pf, _), eff = Future.force e.proof_entry_body in - pf, Safe_typing.push_private_constants env eff - in + let (pf, _), eff = Future.force e.proof_entry_body in + let env = Safe_typing.push_private_constants env eff in let vars = global_vars_set env pf in ids_typ, vars in @@ -236,92 +244,76 @@ let get_roles export eff = in List.map map export -let define_constant ~side_effect id cd = +let define_constant ~side_effect ~name cd = let open Proof_global in (* Logically define the constant and its subproofs, no libobject tampering *) - let is_poly de = match de.proof_entry_universes with - | Monomorphic_entry _ -> false - | Polymorphic_entry _ -> true - in let in_section = Lib.sections_are_opened () in - let export, decl = (* We deal with side effects *) - match cd with - | DefinitionEntry de when - not de.proof_entry_opaque || - is_poly de -> + let export, decl = match cd with + | DefinitionEntry de -> + (* We deal with side effects *) + if not de.proof_entry_opaque then (* This globally defines the side-effects in the environment. *) let body, eff = Future.force de.proof_entry_body in let body, export = Global.export_private_constants ~in_section (body, eff.Evd.seff_private) in let export = get_roles export eff in let de = { de with proof_entry_body = Future.from_val (body, ()) } in - let cd = match de.proof_entry_opaque with - | true -> Entries.OpaqueEntry (cast_opaque_proof_entry PureEntry de) - | false -> Entries.DefinitionEntry (cast_proof_entry de) - in + let cd = Entries.DefinitionEntry (cast_proof_entry de) in export, ConstantEntry (PureEntry, cd) - | DefinitionEntry de -> - let () = assert (de.proof_entry_opaque) in + else let map (body, eff) = body, eff.Evd.seff_private in let body = Future.chain de.proof_entry_body map in let de = { de with proof_entry_body = body } in - let de = cast_opaque_proof_entry EffectEntry de in + let de = cast_opaque_proof_entry de in [], ConstantEntry (EffectEntry, Entries.OpaqueEntry de) - | ParameterEntry e -> - [], ConstantEntry (PureEntry, Entries.ParameterEntry e) - | PrimitiveEntry e -> - [], ConstantEntry (PureEntry, Entries.PrimitiveEntry e) + | ParameterEntry e -> + [], ConstantEntry (PureEntry, Entries.ParameterEntry e) + | PrimitiveEntry e -> + [], ConstantEntry (PureEntry, Entries.PrimitiveEntry e) in - let kn, eff = Global.add_constant ~side_effect ~in_section id decl in + let kn, eff = Global.add_constant ~side_effect ~in_section name decl in kn, eff, export -let declare_constant ?(local = ImportDefaultBehavior) id (cd, kind) = - let () = check_exists id in - let kn, (), export = define_constant ~side_effect:PureEntry id cd in +let declare_constant ?(local = ImportDefaultBehavior) ~name ~kind cd = + let () = check_exists name in + let kn, (), export = define_constant ~side_effect:PureEntry ~name cd in (* Register the libobjects attached to the constants and its subproofs *) let () = List.iter register_side_effect export in let () = register_constant kn kind local in kn -let declare_private_constant ?role ?(local = ImportDefaultBehavior) id (cd, kind) = - let kn, eff, export = define_constant ~side_effect:EffectEntry id cd in - let () = assert (List.is_empty export) in +let declare_private_constant ?role ?(local = ImportDefaultBehavior) ~name ~kind cd = + let kn, eff, export = define_constant ~side_effect:EffectEntry ~name cd in + let () = assert (CList.is_empty export) in let () = register_constant kn kind local in let seff_roles = match role with | None -> Cmap.empty | Some r -> Cmap.singleton kn r in - let eff = { Evd.seff_private = eff; Evd.seff_roles; } in + let eff = { Evd.seff_private = eff.Entries.seff_wrap; Evd.seff_roles; } in kn, eff -let declare_definition - ?(opaque=false) ?(kind=Decl_kinds.Definition) ?(local = ImportDefaultBehavior) - id ?types (body,univs) = - let cb = - definition_entry ?types ~univs ~opaque body - in - declare_constant ~local id - (DefinitionEntry cb, Decl_kinds.IsDefinition kind) - (** Declaration of section variables and local definitions *) -type section_variable_entry = +type variable_declaration = | SectionLocalDef of Evd.side_effects Proof_global.proof_entry - | SectionLocalAssum of { typ:types; univs:Univ.ContextSet.t; poly:bool; impl:bool } + | SectionLocalAssum of { typ:Constr.types; univs:Univ.ContextSet.t; poly:bool; impl:bool } -type variable_declaration = DirPath.t * section_variable_entry * logical_kind +(* This object is only for things which iterate over objects to find + variables (only Prettyp.print_context AFAICT) *) +let inVariable : unit -> obj = + declare_object { (default_object "VARIABLE") with + classify_function = (fun () -> Dispose)} -let cache_variable ((sp,_),o) = - match o with - | Inl ctx -> Global.push_context_set false ctx - | Inr (id,(path,d,kind)) -> +let declare_variable ~name ~kind d = (* Constr raisonne sur les noms courts *) - if variable_exists id then - alreadydeclared (Id.print id ++ str " already exists"); + if Decls.variable_exists name then + raise (AlreadyDeclared (None, name)); let impl,opaque,poly,univs = match d with (* Fails if not well-typed *) | SectionLocalAssum {typ;univs;poly;impl} -> - let () = Global.push_named_assum ((id,typ,poly),univs) in - let impl = if impl then Implicit else Explicit in - impl, true, poly, univs + let () = declare_universe_context ~poly univs in + let () = Global.push_named_assum (name,typ) in + let impl = if impl then Decl_kinds.Implicit else Decl_kinds.Explicit in + impl, true, poly, univs | SectionLocalDef (de) -> (* The body should already have been forced upstream because it is a section-local definition, but it's not enforced by typing *) @@ -331,58 +323,40 @@ let cache_variable ((sp,_),o) = let eff = get_roles export eff in let () = List.iter register_side_effect eff in let poly, univs = match de.proof_entry_universes with - | Monomorphic_entry uctx -> false, uctx - | Polymorphic_entry (_, uctx) -> true, Univ.ContextSet.of_context uctx + | Monomorphic_entry uctx -> false, uctx + | Polymorphic_entry (_, uctx) -> true, Univ.ContextSet.of_context uctx in let univs = Univ.ContextSet.union uctx univs in (* We must declare the universe constraints before type-checking the term. *) - let () = Global.push_context_set (not poly) univs in + let () = declare_universe_context ~poly univs in let se = { secdef_body = body; secdef_secctx = de.proof_entry_secctx; secdef_feedback = de.proof_entry_feedback; secdef_type = de.proof_entry_type; } in - let () = Global.push_named_def (id, se) in - Explicit, de.proof_entry_opaque, - poly, univs in - Nametab.push (Nametab.Until 1) (restrict_path 0 sp) (VarRef id); - add_section_variable ~name:id ~kind:impl ~poly univs; - add_variable_data id {path;opaque;univs;poly;kind} - -let discharge_variable (_,o) = match o with - | Inr (id,_) -> - if variable_polymorphic id then None - else Some (Inl (variable_context id)) - | Inl _ -> Some o - -type variable_obj = - (Univ.ContextSet.t, Id.t * variable_declaration) union - -let inVariable : variable_obj -> obj = - declare_object { (default_object "VARIABLE") with - cache_function = cache_variable; - discharge_function = discharge_variable; - classify_function = (fun _ -> Dispose) } - -(* for initial declaration *) -let declare_variable id obj = - let oname = add_leaf id (inVariable (Inr (id,obj))) in - declare_var_implicits id; - Notation.declare_ref_arguments_scope Evd.empty (VarRef id); - oname + let () = Global.push_named_def (name, se) in + Decl_kinds.Explicit, de.proof_entry_opaque, + poly, univs + in + Nametab.push (Nametab.Until 1) (Libnames.make_path DirPath.empty name) (GlobRef.VarRef name); + add_section_variable ~name ~kind:impl ~poly univs; + Decls.(add_variable_data name {opaque;kind}); + add_anonymous_leaf (inVariable ()); + Impargs.declare_var_implicits name; + Notation.declare_ref_arguments_scope Evd.empty (GlobRef.VarRef name) (** Declaration of inductive blocks *) let declare_inductive_argument_scopes kn mie = List.iteri (fun i {mind_entry_consnames=lc} -> - Notation.declare_ref_arguments_scope Evd.empty (IndRef (kn,i)); + Notation.declare_ref_arguments_scope Evd.empty (GlobRef.IndRef (kn,i)); for j=1 to List.length lc do - Notation.declare_ref_arguments_scope Evd.empty (ConstructRef ((kn,i),j)); + Notation.declare_ref_arguments_scope Evd.empty (GlobRef.ConstructRef ((kn,i),j)); done) mie.mind_entry_inds let inductive_names sp kn mie = - let (dp,_) = repr_path sp in + let (dp,_) = Libnames.repr_path sp in let kn = Global.mind_of_delta_kn kn in let names, _ = List.fold_left @@ -394,11 +368,11 @@ let inductive_names sp kn mie = let sp = Libnames.make_path dp l in - ((sp, ConstructRef (ind_p,p)) :: names, p+1)) + ((sp, GlobRef.ConstructRef (ind_p,p)) :: names, p+1)) (names, 1) ind.mind_entry_consnames in let sp = Libnames.make_path dp ind.mind_entry_typename in - ((sp, IndRef ind_p) :: names, n+1)) + ((sp, GlobRef.IndRef ind_p) :: names, n+1)) ([], 0) mie.mind_entry_inds in names @@ -412,8 +386,8 @@ let open_inductive i ((sp,kn),mie) = let cache_inductive ((sp,kn),mie) = let names = inductive_names sp kn mie in - List.iter check_exists (List.map (fun p -> basename (fst p)) names); - let id = basename sp in + List.iter check_exists (List.map (fun p -> Libnames.basename (fst p)) names); + let id = Libnames.basename sp in let kn' = Global.add_mind id mie in assert (MutInd.equal kn' (MutInd.make1 kn)); let mind = Global.lookup_mind kn' in @@ -428,7 +402,7 @@ let discharge_inductive ((sp,kn),mie) = let dummy_one_inductive_entry mie = { mind_entry_typename = mie.mind_entry_typename; - mind_entry_arity = mkProp; + mind_entry_arity = Constr.mkProp; mind_entry_template = false; mind_entry_consnames = mie.mind_entry_consnames; mind_entry_lc = [] @@ -480,7 +454,7 @@ let inPrim : (Projection.Repr.t * Constant.t) -> obj = let declare_primitive_projection p c = Lib.add_anonymous_leaf (inPrim (p,c)) let declare_one_projection univs (mind,_ as ind) ~proj_npars proj_arg label (term,types) = - let id = Label.to_id label in + let name = Label.to_id label in let univs, u = match univs with | Monomorphic_entry _ -> (* Global constraints already defined through the inductive *) @@ -491,11 +465,10 @@ let declare_one_projection univs (mind,_ as ind) ~proj_npars proj_arg label (ter let term = Vars.subst_instance_constr u term in let types = Vars.subst_instance_constr u types in let entry = definition_entry ~types ~univs term in - let cst = declare_constant id (DefinitionEntry entry, IsDefinition StructureComponent) in + let cst = declare_constant ~name ~kind:Decls.(IsDefinition StructureComponent) (DefinitionEntry entry) in let p = Projection.Repr.make ind ~proj_npars ~proj_arg label in declare_primitive_projection p cst - let declare_projections univs mind = let env = Global.env () in let mib = Environ.lookup_mind mind env in @@ -515,11 +488,11 @@ let declare_projections univs mind = let declare_mind mie = let id = match mie.mind_entry_inds with | ind::_ -> ind.mind_entry_typename - | [] -> anomaly (Pp.str "cannot declare an empty list of inductives.") in + | [] -> CErrors.anomaly (Pp.str "cannot declare an empty list of inductives.") in let (sp,kn as oname) = add_leaf id (inInductive mie) in let mind = Global.mind_of_delta_kn kn in let isprim = declare_projections mie.mind_entry_universes mind in - declare_mib_implicits mind; + Impargs.declare_mib_implicits mind; declare_inductive_argument_scopes mind mie; oname, isprim @@ -529,7 +502,7 @@ let pr_rank i = pr_nth (i+1) let fixpoint_message indexes l = Flags.if_verbose Feedback.msg_info (match l with - | [] -> anomaly (Pp.str "no recursive definition.") + | [] -> CErrors.anomaly (Pp.str "no recursive definition.") | [id] -> Id.print id ++ str " is recursively defined" ++ (match indexes with | Some [|i|] -> str " (decreasing on "++pr_rank i++str " argument)" @@ -544,7 +517,7 @@ let fixpoint_message indexes l = let cofixpoint_message l = Flags.if_verbose Feedback.msg_info (match l with - | [] -> anomaly (Pp.str "No corecursive definition.") + | [] -> CErrors.anomaly (Pp.str "No corecursive definition.") | [id] -> Id.print id ++ str " is corecursively defined" | l -> hov 0 (prlist_with_sep pr_comma Id.print l ++ spc () ++ str "are corecursively defined")) @@ -561,19 +534,6 @@ let assumption_message id = discussion on coqdev: "Chapter 4 of the Reference Manual", 8/10/2015) *) Flags.if_verbose Feedback.msg_info (Id.print id ++ str " is declared") -(** Monomorphic universes need to survive sections. *) - -let input_universe_context : Univ.ContextSet.t -> Libobject.obj = - declare_object @@ local_object "Monomorphic section universes" - ~cache:(fun (na, uctx) -> Global.push_context_set false uctx) - ~discharge:(fun (_, x) -> Some x) - -let declare_universe_context ~poly ctx = - if poly then - (Global.push_context_set true ctx; Lib.add_section_context ctx) - else - Lib.add_anonymous_leaf (input_universe_context ctx) - (** Global universes are not substitutive objects but global objects bound at the *library* or *module* level. The polymorphic flag is used to distinguish universes declared in polymorphic sections, which @@ -586,9 +546,9 @@ type universe_source = type universe_name_decl = universe_source * (Id.t * Univ.Level.UGlobal.t) list -let check_exists sp = +let check_exists_universe sp = if Nametab.exists_universe sp then - alreadydeclared (str "Universe " ++ Id.print (basename sp) ++ str " already exists") + raise (AlreadyDeclared (Some "Universe", Libnames.basename sp)) else () let qualify_univ i dp src id = @@ -601,19 +561,19 @@ let qualify_univ i dp src id = let do_univ_name ~check i dp src (id,univ) = let i, sp = qualify_univ i dp src id in - if check then check_exists sp; + if check then check_exists_universe sp; Nametab.push_universe i sp univ let cache_univ_names ((sp, _), (src, univs)) = let depth = sections_depth () in - let dp = pop_dirpath_n depth (dirpath sp) in + let dp = Libnames.pop_dirpath_n depth (Libnames.dirpath sp) in List.iter (do_univ_name ~check:true (Nametab.Until 1) dp src) univs let load_univ_names i ((sp, _), (src, univs)) = - List.iter (do_univ_name ~check:false (Nametab.Until i) (dirpath sp) src) univs + List.iter (do_univ_name ~check:false (Nametab.Until i) (Libnames.dirpath sp) src) univs let open_univ_names i ((sp, _), (src, univs)) = - List.iter (do_univ_name ~check:false (Nametab.Exactly i) (dirpath sp) src) univs + List.iter (do_univ_name ~check:false (Nametab.Exactly i) (Libnames.dirpath sp) src) univs let discharge_univ_names = function | _, (BoundUniv, _) -> None @@ -633,12 +593,13 @@ let declare_univ_binders gr pl = if Global.is_polymorphic gr then () else - let l = match gr with + let l = let open GlobRef in match gr with | ConstRef c -> Label.to_id @@ Constant.label c | IndRef (c, _) -> Label.to_id @@ MutInd.label c - | VarRef id -> anomaly ~label:"declare_univ_binders" Pp.(str "declare_univ_binders on variable " ++ Id.print id ++ str".") + | VarRef id -> + CErrors.anomaly ~label:"declare_univ_binders" Pp.(str "declare_univ_binders on variable " ++ Id.print id ++ str".") | ConstructRef _ -> - anomaly ~label:"declare_univ_binders" + CErrors.anomaly ~label:"declare_univ_binders" Pp.(str "declare_univ_binders on an constructor reference") in let univs = Id.Map.fold (fun id univ univs -> @@ -652,7 +613,7 @@ let do_universe ~poly l = let in_section = Lib.sections_are_opened () in let () = if poly && not in_section then - user_err ~hdr:"Constraint" + CErrors.user_err ~hdr:"Constraint" (str"Cannot declare polymorphic universes outside sections") in let l = List.map (fun {CAst.v=id} -> (id, UnivGen.new_univ_global ())) l in @@ -672,13 +633,13 @@ let do_constraint ~poly l = let in_section = Lib.sections_are_opened () in let () = if poly && not in_section then - user_err ~hdr:"Constraint" + CErrors.user_err ~hdr:"Constraint" (str"Cannot declare polymorphic constraints outside sections") in let check_poly p p' = if poly then () else if p || p' then - user_err ~hdr:"Constraint" + CErrors.user_err ~hdr:"Constraint" (str "Cannot declare a global constraint on " ++ str "a polymorphic universe, use " ++ str "Polymorphic Constraint instead") diff --git a/tactics/declare.mli b/tactics/declare.mli index 1f72fff30e..89b41076f7 100644 --- a/tactics/declare.mli +++ b/tactics/declare.mli @@ -11,7 +11,6 @@ open Names open Constr open Entries -open Decl_kinds (** This module provides the official functions to declare new variables, parameters, constants and inductive types. Using the following functions @@ -22,7 +21,7 @@ open Decl_kinds (** Declaration of local constructions (Variable/Hypothesis/Local) *) -type section_variable_entry = +type variable_declaration = | SectionLocalDef of Evd.side_effects Proof_global.proof_entry | SectionLocalAssum of { typ:types; univs:Univ.ContextSet.t; poly:bool; impl:bool } @@ -31,15 +30,15 @@ type 'a constant_entry = | ParameterEntry of parameter_entry | PrimitiveEntry of primitive_entry -type variable_declaration = DirPath.t * section_variable_entry * logical_kind - -val declare_variable : variable -> variable_declaration -> Libobject.object_name +val declare_variable + : name:variable + -> kind:Decls.logical_kind + -> variable_declaration + -> unit (** Declaration of global constructions i.e. Definition/Theorem/Axiom/Parameter/... *) -type constant_declaration = Evd.side_effects constant_entry * logical_kind - (* Default definition entries, transparent with no secctx or proj information *) val definition_entry : ?fix_exn:Future.fix_exn -> ?opaque:bool -> ?inline:bool -> ?types:types -> @@ -54,16 +53,20 @@ type import_status = ImportDefaultBehavior | ImportNeedQualified internal specify if the constant has been created by the kernel or by the user, and in the former case, if its errors should be silent *) -val declare_constant : - ?local:import_status -> Id.t -> constant_declaration -> Constant.t - -val declare_private_constant : - ?role:Evd.side_effect_role -> ?local:import_status -> Id.t -> constant_declaration -> Constant.t * Evd.side_effects - -val declare_definition : - ?opaque:bool -> ?kind:definition_object_kind -> - ?local:import_status -> Id.t -> ?types:constr -> - constr Entries.in_universes_entry -> Constant.t +val declare_constant + : ?local:import_status + -> name:Id.t + -> kind:Decls.logical_kind + -> Evd.side_effects constant_entry + -> Constant.t + +val declare_private_constant + : ?role:Evd.side_effect_role + -> ?local:import_status + -> name:Id.t + -> kind:Decls.logical_kind + -> Evd.side_effects constant_entry + -> Constant.t * Evd.side_effects (** Since transparent constants' side effects are globally declared, we * need that *) @@ -93,3 +96,6 @@ val declare_universe_context : poly:bool -> Univ.ContextSet.t -> unit val do_universe : poly:bool -> lident list -> unit val do_constraint : poly:bool -> Glob_term.glob_constraint list -> unit + +(* Used outside this module only in indschemes *) +exception AlreadyDeclared of (string option * Id.t) diff --git a/tactics/equality.ml b/tactics/equality.ml index 98db6cbb97..7c90c59f61 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -380,7 +380,7 @@ let find_elim hdcncl lft2rgt dep cls ot = Logic.eq or Jmeq just before *) assert false in - pf_constr_of_global (ConstRef c) + pf_constr_of_global (GlobRef.ConstRef c) else let scheme_name = match dep, lft2rgt, inccl with (* Non dependent case *) @@ -399,7 +399,7 @@ let find_elim hdcncl lft2rgt dep cls ot = let c, eff = find_scheme scheme_name ind in Proofview.tclEFFECTS eff <*> - pf_constr_of_global (ConstRef c) + pf_constr_of_global (GlobRef.ConstRef c) | _ -> assert false end @@ -989,7 +989,7 @@ let ind_scheme_of_eq lbeq to_kind = (* use ind rather than case by compatibility *) let kind = Elimschemes.nondep_elim_scheme from_kind to_kind in let c, eff = find_scheme kind (destIndRef lbeq.eq) in - ConstRef c, eff + GlobRef.ConstRef c, eff let discrimination_pf e (t,t1,t2) discriminator lbeq to_kind = diff --git a/tactics/hints.ml b/tactics/hints.ml index 3a3a6b94dc..131832be89 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -48,6 +48,7 @@ let head_constr_bound sigma t = let t = strip_outer_cast sigma t in let _,ccl = decompose_prod_assum sigma t in let hd,args = decompose_app sigma ccl in + let open GlobRef in match EConstr.kind sigma hd with | Const (c, _) -> ConstRef c | Ind (i, _) -> IndRef i @@ -65,6 +66,7 @@ let decompose_app_bound sigma t = let t = strip_outer_cast sigma t in let _,ccl = decompose_prod_assum sigma t in let hd,args = decompose_app_vect sigma ccl in + let open GlobRef in match EConstr.kind sigma hd with | Const (c,u) -> ConstRef c, args | Ind (i,u) -> IndRef i, args @@ -295,7 +297,7 @@ let lookup_tacs sigma concl st se = let sl' = List.stable_sort pri_order_int l' in List.merge pri_order_int se.sentry_nopat sl' -let is_transparent_gr ts = function +let is_transparent_gr ts = let open GlobRef in function | VarRef id -> TransparentState.is_transparent_variable ts id | ConstRef cst -> TransparentState.is_transparent_constant ts cst | IndRef _ | ConstructRef _ -> false @@ -919,7 +921,7 @@ let make_resolve_hyp env sigma decl = let c = mkVar hname in try [make_apply_entry env sigma (true, true, false) empty_hint_info ~poly:false - ~name:(PathHints [VarRef hname]) + ~name:(PathHints [GlobRef.VarRef hname]) (c, NamedDecl.get_type decl, Univ.ContextSet.empty)] with | Failure _ -> [] @@ -1315,14 +1317,18 @@ let project_hint ~poly pri l2r r = let c = Reductionops.whd_beta sigma (mkApp (c, Context.Rel.to_extended_vect mkRel 0 sign)) in let c = it_mkLambda_or_LetIn (mkApp (p,[|mkArrow a Sorts.Relevant (lift 1 b);mkArrow b Sorts.Relevant (lift 1 a);c|])) sign in - let id = + let name = Nameops.add_suffix (Nametab.basename_of_global gr) ("_proj_" ^ (if l2r then "l2r" else "r2l")) in let ctx = Evd.univ_entry ~poly sigma in let c = EConstr.to_constr sigma c in - let c = Declare.declare_definition id (c,ctx) in + let cb = Declare.(DefinitionEntry (definition_entry ~univs:ctx ~opaque:false c)) in + let c = Declare.declare_constant + ~local:Declare.ImportDefaultBehavior + ~name ~kind:Decls.(IsDefinition Definition) cb + in let info = {Typeclasses.hint_priority = pri; hint_pattern = None} in - (info,false,true,PathAny, IsGlobRef (Globnames.ConstRef c)) + (info,false,true,PathAny, IsGlobRef (GlobRef.ConstRef c)) let interp_hints ~poly = fun h -> @@ -1372,7 +1378,7 @@ let interp_hints ~poly = Dumpglob.dump_reference ?loc:qid.CAst.loc "<>" (string_of_qualid qid) "ind"; List.init (nconstructors env ind) (fun i -> let c = (ind,i+1) in - let gr = ConstructRef c in + let gr = GlobRef.ConstructRef c in empty_hint_info, (Declareops.inductive_is_polymorphic mib), true, PathHints [gr], IsGlobRef gr) diff --git a/tactics/ind_tables.ml b/tactics/ind_tables.ml index e01f3ab961..e2ef05461b 100644 --- a/tactics/ind_tables.ml +++ b/tactics/ind_tables.ml @@ -22,7 +22,6 @@ open Declarations open Constr open CErrors open Util -open Decl_kinds open Pp (**********************************************************************) @@ -136,7 +135,7 @@ let define internal role id c poly univs = proof_entry_inline_code = false; proof_entry_feedback = None; } in - let kn, eff = Declare.declare_private_constant ~role id (Declare.DefinitionEntry entry, Decl_kinds.IsDefinition Scheme) in + let kn, eff = Declare.declare_private_constant ~role ~kind:Decls.(IsDefinition Scheme) ~name:id (Declare.DefinitionEntry entry) in let () = match internal with | InternalTacticRequest -> () | _-> Declare.definition_message id diff --git a/tactics/leminv.ml b/tactics/leminv.ml index e242b10d33..2af3947dd1 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -27,7 +27,6 @@ open Tacmach.New open Clenv open Tacticals.New open Tactics -open Decl_kinds open Context.Named.Declaration module NamedDecl = Context.Named.Declaration @@ -236,7 +235,7 @@ let add_inversion_lemma ~poly name env sigma t sort dep inv_op = let invProof, sigma = inversion_scheme ~name ~poly env sigma t sort dep inv_op in let univs = Evd.univ_entry ~poly sigma in let entry = Declare.definition_entry ~univs invProof in - let _ = Declare.declare_constant name (Declare.DefinitionEntry entry, IsProof Lemma) in + let _ : Names.Constant.t = Declare.declare_constant ~name ~kind:Decls.(IsProof Lemma) (Declare.DefinitionEntry entry) in () (* inv_op = Inv (derives de complete inv. lemma) diff --git a/tactics/redops.ml b/tactics/redops.ml index e0473cbefd..86ed8f8899 100644 --- a/tactics/redops.ml +++ b/tactics/redops.ml @@ -10,7 +10,7 @@ open Genredexpr -let union_consts l1 l2 = Util.List.union Pervasives.(=) l1 l2 (* FIXME *) +let union_consts l1 l2 = Util.List.union (=) l1 l2 (* FIXME *) let make_red_flag l = let rec add_flag red = function diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 9dabe56816..6fd18b83d1 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -24,7 +24,6 @@ open Namegen open Declarations open Inductiveops open Reductionops -open Globnames open Evd open Tacred open Genredexpr @@ -921,14 +920,14 @@ let is_local_flag env flags = else let check = function | EvalVarRef _ -> false - | EvalConstRef c -> Id.Set.is_empty (Environ.vars_of_global env (ConstRef c)) + | EvalConstRef c -> Id.Set.is_empty (Environ.vars_of_global env (GlobRef.ConstRef c)) in List.for_all check flags.rConst let is_local_unfold env flags = let check (_, c) = match c with | EvalVarRef _ -> false - | EvalConstRef c -> Id.Set.is_empty (Environ.vars_of_global env (ConstRef c)) + | EvalConstRef c -> Id.Set.is_empty (Environ.vars_of_global env (GlobRef.ConstRef c)) in List.for_all check flags @@ -975,8 +974,8 @@ let reduce redexp cl = (* Unfolding occurrences of a constant *) let unfold_constr = function - | ConstRef sp -> unfold_in_concl [AllOccurrences,EvalConstRef sp] - | VarRef id -> unfold_in_concl [AllOccurrences,EvalVarRef id] + | GlobRef.ConstRef sp -> unfold_in_concl [AllOccurrences,EvalConstRef sp] + | GlobRef.VarRef id -> unfold_in_concl [AllOccurrences,EvalVarRef id] | _ -> user_err ~hdr:"unfold_constr" (str "Cannot unfold a non-constant.") (*******************************************) diff --git a/tactics/term_dnet.ml b/tactics/term_dnet.ml index c3132ed6f0..ccd7a818b9 100644 --- a/tactics/term_dnet.ml +++ b/tactics/term_dnet.ml @@ -289,6 +289,7 @@ struct open TDnet let pat_of_constr c : term_pattern = + let open GlobRef in (* To each evar we associate a unique identifier. *) let metas = ref Evar.Map.empty in let rec pat_of_constr c = match Constr.kind c with diff --git a/test-suite/misc/poly-capture-global-univs/src/evilImpl.ml b/test-suite/misc/poly-capture-global-univs/src/evilImpl.ml index 8447cf10db..8c4808a755 100644 --- a/test-suite/misc/poly-capture-global-univs/src/evilImpl.ml +++ b/test-suite/misc/poly-capture-global-univs/src/evilImpl.ml @@ -1,17 +1,16 @@ open Names -let evil t f = +let evil name name_f = let open Univ in let open Entries in - let open Decl_kinds in let open Constr in - let k = IsDefinition Definition in + let kind = Decls.(IsDefinition Definition) in let u = Level.var 0 in let tu = mkType (Universe.make u) in let te = Declare.definition_entry ~univs:(Monomorphic_entry (ContextSet.singleton u)) tu in - let tc = Declare.declare_constant t (Declare.DefinitionEntry te, k) in + let tc = Declare.declare_constant ~name ~kind (Declare.DefinitionEntry te) in let tc = mkConst tc in let fe = Declare.definition_entry @@ -19,4 +18,5 @@ let evil t f = ~types:(Term.mkArrowR tc tu) (mkLambda (Context.nameR (Id.of_string "x"), tc, mkRel 1)) in - ignore (Declare.declare_constant f (Declare.DefinitionEntry fe, k)) + let _ : Constant.t = Declare.declare_constant ~name:name_f ~kind (Declare.DefinitionEntry fe) in + () diff --git a/test-suite/output/relaxed_ambiguous_paths.out b/test-suite/output/relaxed_ambiguous_paths.out index 2a7ce806d7..dc793598a9 100644 --- a/test-suite/output/relaxed_ambiguous_paths.out +++ b/test-suite/output/relaxed_ambiguous_paths.out @@ -1,5 +1,7 @@ File "stdin", line 10, characters 0-28: -Warning: Ambiguous paths: [ac; cd] : A >-> D [ambiguous-paths,typechecker] +Warning: +New coercion path [ac; cd] : A >-> D is ambiguous with existing +[ab; bd] : A >-> D. [ambiguous-paths,typechecker] [ab] : A >-> B [ab; bd] : A >-> D [ac] : A >-> C @@ -20,8 +22,9 @@ Warning: Ambiguous paths: [ac; cd] : A >-> D [ambiguous-paths,typechecker] [D_B] : D >-> B [D_C] : D >-> C File "stdin", line 103, characters 0-86: -Warning: Ambiguous paths: [D_C; C_A'] : D >-> A' -[ambiguous-paths,typechecker] +Warning: +New coercion path [D_C; C_A'] : D >-> A' is ambiguous with existing +[D_B; B_A'] : D >-> A'. [ambiguous-paths,typechecker] [A'_A] : A' >-> A [B_A'] : B >-> A' [B_A'; A'_A] : B >-> A diff --git a/tools/coqdep.ml b/tools/coqdep.ml index 7a07e815ce..6f81be475b 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -297,7 +297,7 @@ module DAG = DAG(struct type t = string let compare = compare end) (** TODO: we should share this code with Coqdep_common *) module VData = struct type t = string list option * string list - let compare = Pervasives.compare + let compare = Util.pervasives_compare end module VCache = Set.Make(VData) diff --git a/tools/coqdep_common.ml b/tools/coqdep_common.ml index d98242ef17..8beb314046 100644 --- a/tools/coqdep_common.ml +++ b/tools/coqdep_common.ml @@ -357,7 +357,7 @@ let canonize f = module VData = struct type t = string list option * string list - let compare = Pervasives.compare + let compare = compare end module VCache = Set.Make(VData) diff --git a/tools/coqdoc/main.ml b/tools/coqdoc/main.ml index 1c22efa513..3442ebb731 100644 --- a/tools/coqdoc/main.ml +++ b/tools/coqdoc/main.ml @@ -396,7 +396,7 @@ let copy src dst = try let cout = open_out dst in try - while true do Pervasives.output_char cout (input_char cin) done + while true do output_char cout (input_char cin) done with End_of_file -> close_out cout; close_in cin diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml index 9b7da862a8..02f0290802 100644 --- a/tools/coqdoc/output.ml +++ b/tools/coqdoc/output.ml @@ -13,9 +13,9 @@ open Index (*s Low level output *) -let output_char c = Pervasives.output_char !out_channel c +let output_char c = output_char !out_channel c -let output_string s = Pervasives.output_string !out_channel s +let output_string s = output_string !out_channel s let printf s = Printf.fprintf !out_channel s @@ -527,13 +527,13 @@ module Html = struct let header () = if !header_trailer then if !header_file_spec then - let cin = Pervasives.open_in !header_file in + let cin = open_in !header_file in try while true do - let s = Pervasives.input_line cin in + let s = input_line cin in printf "%s\n" s done - with End_of_file -> Pervasives.close_in cin + with End_of_file -> close_in cin else begin printf "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"\n"; @@ -548,13 +548,13 @@ module Html = struct let trailer () = if !header_trailer && !footer_file_spec then - let cin = Pervasives.open_in !footer_file in + let cin = open_in !footer_file in try while true do - let s = Pervasives.input_line cin in + let s = input_line cin in printf "%s\n" s done - with End_of_file -> Pervasives.close_in cin + with End_of_file -> close_in cin else begin if !index && (get_module false) <> "Index" then diff --git a/tools/make-both-single-timing-files.py b/tools/make-both-single-timing-files.py index 32c52c7a17..fddf75f39f 100755 --- a/tools/make-both-single-timing-files.py +++ b/tools/make-both-single-timing-files.py @@ -1,4 +1,4 @@ -#!/usr/bin/env python +#!/usr/bin/env python3 import sys from TimeFileMaker import * diff --git a/tools/make-both-time-files.py b/tools/make-both-time-files.py index f730a8d6bd..8937d63c2f 100755 --- a/tools/make-both-time-files.py +++ b/tools/make-both-time-files.py @@ -1,4 +1,4 @@ -#!/usr/bin/env python +#!/usr/bin/env python3 import sys from TimeFileMaker import * diff --git a/tools/make-one-time-file.py b/tools/make-one-time-file.py index e66136df9d..ad0a04ab07 100755 --- a/tools/make-one-time-file.py +++ b/tools/make-one-time-file.py @@ -1,4 +1,4 @@ -#!/usr/bin/env python +#!/usr/bin/env python3 import sys from TimeFileMaker import * diff --git a/tools/ocamllibdep.mll b/tools/ocamllibdep.mll index bd19d30409..41a4e2a86a 100644 --- a/tools/ocamllibdep.mll +++ b/tools/ocamllibdep.mll @@ -35,7 +35,6 @@ rule mllib_list = parse { open Printf -open Unix (* Makefile's escaping rules are awful: $ is escaped by doubling and other special characters are escaped by backslash prefixing while @@ -99,6 +98,7 @@ let file_name s = function type dir = string option let add_directory add_file phys_dir = + let open Unix in Array.iter (fun f -> (* we avoid all files starting by '.' *) if f.[0] <> '.' then @@ -152,7 +152,7 @@ let add_caml_known phys_dir f = | _ -> () let add_caml_dir phys_dir = - handle_unix_error (add_directory add_caml_known) phys_dir + Unix.handle_unix_error (add_directory add_caml_known) phys_dir let traite_fichier_modules md ext = try @@ -192,7 +192,7 @@ let mllib_dependencies () = efullname efullname; printf "%s.cmxa:$(addsuffix .cmx,$(%s_MLLIB_DEPENDENCIES))\n" efullname efullname; - flush Pervasives.stdout) + flush stdout) (List.rev !mllibAccu) let mlpack_dependencies () = @@ -209,7 +209,7 @@ let mlpack_dependencies () = efullname efullname; printf "%s.cmx:$(addsuffix .cmx,$(%s_MLPACK_DEPENDENCIES))\n" efullname efullname; - flush Pervasives.stdout) + flush stdout) (List.rev !mlpackAccu) let rec parse = function diff --git a/topbin/coqproofworker_bin.ml b/topbin/coqproofworker_bin.ml index baf76582ac..2715406b13 100644 --- a/topbin/coqproofworker_bin.ml +++ b/topbin/coqproofworker_bin.ml @@ -11,4 +11,4 @@ module W = AsyncTaskQueue.MakeWorker(Stm.ProofTask) () let () = - WorkerLoop.start ~init:W.init_stdout ~loop:W.main_loop + WorkerLoop.start ~init:W.init_stdout ~loop:W.main_loop "coqproofworker" diff --git a/topbin/coqqueryworker_bin.ml b/topbin/coqqueryworker_bin.ml index 0f7005e422..225158e064 100644 --- a/topbin/coqqueryworker_bin.ml +++ b/topbin/coqqueryworker_bin.ml @@ -10,4 +10,4 @@ module W = AsyncTaskQueue.MakeWorker(Stm.QueryTask) () -let () = WorkerLoop.start ~init:W.init_stdout ~loop:W.main_loop +let () = WorkerLoop.start ~init:W.init_stdout ~loop:W.main_loop "coqqueryworker" diff --git a/topbin/coqtacticworker_bin.ml b/topbin/coqtacticworker_bin.ml index 19a8cde88a..962028e0e7 100644 --- a/topbin/coqtacticworker_bin.ml +++ b/topbin/coqtacticworker_bin.ml @@ -10,4 +10,4 @@ module W = AsyncTaskQueue.MakeWorker(Stm.TacTask) () -let () = WorkerLoop.start ~init:W.init_stdout ~loop:W.main_loop +let () = WorkerLoop.start ~init:W.init_stdout ~loop:W.main_loop "coqtacticworker" diff --git a/toplevel/ccompile.ml b/toplevel/ccompile.ml index e6255a947e..d8a3dbb4bb 100644 --- a/toplevel/ccompile.ml +++ b/toplevel/ccompile.ml @@ -20,6 +20,16 @@ let fatal_error msg = (******************************************************************************) (* Interactive Load File Simulation *) (******************************************************************************) + +let load_init_file opts ~state = + if opts.pre.load_rcfile then + Topfmt.(in_phase ~phase:LoadingRcFile) (fun () -> + Coqinit.load_rcfile ~rcfile:opts.config.rcfile ~state) () + else begin + Flags.if_verbose Feedback.msg_info (str"Skipping rcfile loading."); + state + end + let load_vernacular opts ~state = List.fold_left (fun state (f_in, echo) -> @@ -29,19 +39,12 @@ let load_vernacular opts ~state = if !Flags.beautify then Flags.with_option Flags.beautify_file load_vernac f_in else load_vernac s - ) state (List.rev opts.load_vernacular_list) + ) state (List.rev opts.pre.load_vernacular_list) let load_init_vernaculars opts ~state = - let state = - if opts.load_rcfile then - Topfmt.(in_phase ~phase:LoadingRcFile) (fun () -> - Coqinit.load_rcfile ~rcfile:opts.rcfile ~state) () - else begin - Flags.if_verbose Feedback.msg_info (str"Skipping rcfile loading."); - state - end in - - load_vernacular opts ~state + let state = load_init_file opts ~state in + let state = load_vernacular opts ~state in + state (******************************************************************************) (* File Compilation *) @@ -99,8 +102,8 @@ let compile opts copts ~echo ~f_in ~f_out = in let iload_path = build_load_path opts in let require_libs = require_libs opts in - let stm_options = opts.stm_flags in - let output_native_objects = match opts.native_compiler with + let stm_options = opts.config.stm_flags in + let output_native_objects = match opts.config.native_compiler with | NativeOff -> false | NativeOn {ondemand} -> not ondemand in match copts.compilation_mode with @@ -115,7 +118,7 @@ let compile opts copts ~echo ~f_in ~f_out = Stm.{ doc_type = VoDoc long_f_dot_vo; iload_path; require_libs; stm_options; } in - let state = { doc; sid; proof = None; time = opts.time } in + let state = { doc; sid; proof = None; time = opts.config.time } in let state = load_init_vernaculars opts ~state in let ldir = Stm.get_ldir ~doc:state.doc in Aux_file.(start_aux_file @@ -161,7 +164,7 @@ let compile opts copts ~echo ~f_in ~f_out = iload_path; require_libs; stm_options; } in - let state = { doc; sid; proof = None; time = opts.time } in + let state = { doc; sid; proof = None; time = opts.config.time } in let state = load_init_vernaculars opts ~state in let ldir = Stm.get_ldir ~doc:state.doc in let state = Vernac.load_vernac ~echo ~check:false ~interactive:false ~state long_f_dot_v in diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index 7e3759f177..eb0331d95e 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -40,52 +40,63 @@ type native_compiler = NativeOff | NativeOn of { ondemand : bool } type option_command = OptionSet of string option | OptionUnset -type t = { +type coqargs_logic_config = { + impredicative_set : Declarations.set_predicativity; + indices_matter : bool; + toplevel_name : Stm.interactive_top; + allow_sprop : bool; + cumulative_sprop : bool; +} +type coqargs_config = { + logic : coqargs_logic_config; + rcfile : string option; + coqlib : string option; + color : color; + enable_VM : bool; + native_compiler : native_compiler; + stm_flags : Stm.AsyncOpts.stm_opt; + debug : bool; + diffs_set : bool; + time : bool; + glob_opt : bool; + print_emacs : bool; + set_options : (Goptions.option_name * option_command) list; +} + +type coqargs_pre = { load_init : bool; load_rcfile : bool; - rcfile : string option; ml_includes : Loadpath.coq_path list; vo_includes : Loadpath.coq_path list; vo_requires : (string * string option * bool option) list; (* None = No Import; Some false = Import; Some true = Export *) - toplevel_name : Stm.interactive_top; - load_vernacular_list : (string * bool) list; - batch : bool; - - color : color; - - impredicative_set : Declarations.set_predicativity; - indices_matter : bool; - enable_VM : bool; - native_compiler : native_compiler; - allow_sprop : bool; - cumulative_sprop : bool; - - set_options : (Goptions.option_name * option_command) list; - stm_flags : Stm.AsyncOpts.stm_opt; - debug : bool; - diffs_set : bool; - time : bool; + inputstate : string option; +} - filter_opts : bool; +type coqargs_query = + | PrintTags | PrintWhere | PrintConfig + | PrintVersion | PrintMachineReadableVersion + | PrintHelp of Usage.specific_usage - glob_opt : bool; +type coqargs_main = + | Queries of coqargs_query list + | Run +type coqargs_post = { memory_stat : bool; - print_tags : bool; - print_where : bool; - print_config: bool; output_context : bool; +} - print_emacs : bool; - - inputstate : string option; - +type t = { + config : coqargs_config; + pre : coqargs_pre; + main : coqargs_main; + post : coqargs_post; } let default_toplevel = Names.(DirPath.make [Id.of_string "Top"]) @@ -95,69 +106,71 @@ let default_native = then NativeOn {ondemand=true} else NativeOff -let default = { - - load_init = true; - load_rcfile = true; - rcfile = None; - - ml_includes = []; - vo_includes = []; - vo_requires = []; - - toplevel_name = Stm.TopLogical default_toplevel; - - load_vernacular_list = []; - batch = false; - - color = `AUTO; - +let default_logic_config = { impredicative_set = Declarations.PredicativeSet; indices_matter = false; - enable_VM = true; - native_compiler = default_native; + toplevel_name = Stm.TopLogical default_toplevel; allow_sprop = false; cumulative_sprop = false; +} - set_options = []; - +let default_config = { + logic = default_logic_config; + rcfile = None; + coqlib = None; + color = `AUTO; + enable_VM = true; + native_compiler = default_native; stm_flags = Stm.AsyncOpts.default_opts; debug = false; diffs_set = false; time = false; + glob_opt = false; + print_emacs = false; + set_options = []; - filter_opts = false; + (* Quiet / verbosity options should be here *) +} - glob_opt = false; +let default_pre = { + load_init = true; + load_rcfile = true; + ml_includes = []; + vo_includes = []; + vo_requires = []; + load_vernacular_list = []; + inputstate = None; +} + +let default_queries = [] +let default_post = { memory_stat = false; - print_tags = false; - print_where = false; - print_config = false; output_context = false; +} - print_emacs = false; - - (* Quiet / verbosity options should be here *) - - inputstate = None; +let default = { + config = default_config; + pre = default_pre; + main = Run; + post = default_post; } (******************************************************************************) (* Functional arguments *) (******************************************************************************) let add_ml_include opts s = - Loadpath.{ opts with ml_includes = {recursive = false; path_spec = MlPath s} :: opts.ml_includes } + Loadpath.{ opts with pre = { opts.pre with ml_includes = {recursive = false; path_spec = MlPath s} :: opts.pre.ml_includes }} let add_vo_include opts unix_path coq_path implicit = let open Loadpath in let coq_path = Libnames.dirpath_of_string coq_path in - { opts with vo_includes = { + { opts with pre = { opts.pre with vo_includes = { recursive = true; - path_spec = VoPath { unix_path; coq_path; has_ml = AddNoML; implicit } } :: opts.vo_includes } + path_spec = VoPath { unix_path; coq_path; has_ml = AddNoML; implicit } } :: opts.pre.vo_includes }} let add_vo_require opts d p export = - { opts with vo_requires = (d, p, export) :: opts.vo_requires } + { opts with pre = { opts.pre with vo_requires = (d, p, export) :: opts.pre.vo_requires }} let add_compat_require opts v = match v with @@ -166,19 +179,28 @@ let add_compat_require opts v = | Flags.Current -> add_vo_require opts "Coq.Compat.Coq810" None (Some false) let add_load_vernacular opts verb s = - { opts with load_vernacular_list = (CUnix.make_suffix s ".v",verb) :: opts.load_vernacular_list } + { opts with pre = { opts.pre with load_vernacular_list = (CUnix.make_suffix s ".v",verb) :: opts.pre.load_vernacular_list }} (** Options for proof general *) let set_emacs opts = Printer.enable_goal_tags_printing := true; - { opts with color = `EMACS; print_emacs = true } + { opts with config = { opts.config with color = `OFF; print_emacs = true }} + +let set_logic f oval = + { oval with config = { oval.config with logic = f oval.config.logic }} let set_color opts = function -| "yes" | "on" -> { opts with color = `ON } -| "no" | "off" -> { opts with color = `OFF } -| "auto" -> { opts with color = `AUTO } -| _ -> - error_wrong_arg ("Error: on/off/auto expected after option color") + | "yes" | "on" -> { opts with config = { opts.config with color = `ON }} + | "no" | "off" -> { opts with config = { opts.config with color = `OFF }} + | "auto" -> { opts with config = { opts.config with color = `AUTO }} + | _ -> + error_wrong_arg ("Error: on/off/auto expected after option color") + +let set_query opts q = + { opts with main = match opts.main with + | Run -> Queries (default_queries@[q]) + | Queries queries -> Queries (queries@[q]) + } let warn_deprecated_inputstate = CWarnings.create ~name:"deprecated-inputstate" ~category:"deprecated" @@ -190,9 +212,7 @@ let warn_deprecated_simple_require = let set_inputstate opts s = warn_deprecated_inputstate (); - { opts with inputstate = Some s } - -let exitcode opts = if opts.filter_opts then 2 else 0 + { opts with pre = { opts.pre with inputstate = Some s }} (******************************************************************************) (* Parsing helpers *) @@ -261,26 +281,9 @@ let parse_option_set opt = let v = String.sub opt (eqi+1) (len - eqi - 1) in to_opt_key (String.sub opt 0 eqi), Some v -(*s Parsing of the command line. - We no longer use [Arg.parse], in order to use share [Usage.print_usage] - between coqtop and coqc. *) - -let usage_no_coqlib = CWarnings.create ~name:"usage-no-coqlib" ~category:"filesystem" - (fun () -> Pp.str "cannot guess a path for Coq libraries; dynaminally loaded flags will not be mentioned") - -exception NoCoqLib - -let usage help = - begin - try Envars.set_coqlib ~fail:(fun x -> raise NoCoqLib) - with NoCoqLib -> usage_no_coqlib () - end; - let lp = Coqinit.toplevel_init_load_path () in - (* Necessary for finding the toplevels below *) - List.iter Loadpath.add_coq_path lp; - help () - (* Main parsing routine *) +(*s Parsing of the command line *) + let parse_args ~help ~init arglist : t * string list = let args = ref arglist in let extras = ref [] in @@ -320,54 +323,55 @@ let parse_args ~help ~init arglist : t * string list = (* Options with one arg *) |"-coqlib" -> - Envars.set_user_coqlib (next ()); - oval + { oval with config = { oval.config with coqlib = Some (next ()) + }} |"-async-proofs" -> - { oval with stm_flags = { oval.stm_flags with + { oval with config = { oval.config with stm_flags = { oval.config.stm_flags with Stm.AsyncOpts.async_proofs_mode = get_async_proofs_mode opt (next()) - }} + }}} |"-async-proofs-j" -> - { oval with stm_flags = { oval.stm_flags with + { oval with config = { oval.config with stm_flags = { oval.config.stm_flags with Stm.AsyncOpts.async_proofs_n_workers = (get_int opt (next ())) - }} + }}} |"-async-proofs-cache" -> - { oval with stm_flags = { oval.stm_flags with + { oval with config = { oval.config with stm_flags = { oval.config.stm_flags with Stm.AsyncOpts.async_proofs_cache = get_cache opt (next ()) - }} + }}} |"-async-proofs-tac-j" -> let j = get_int opt (next ()) in if j <= 0 then begin error_wrong_arg ("Error: -async-proofs-tac-j only accepts values greater than or equal to 1") end; - { oval with stm_flags = { oval.stm_flags with + { oval with config = { oval.config with stm_flags = { oval.config.stm_flags with Stm.AsyncOpts.async_proofs_n_tacworkers = j - }} + }}} |"-async-proofs-worker-priority" -> - CoqworkmgrApi.async_proofs_worker_priority := get_priority opt (next ()); - oval + { oval with config = { oval.config with stm_flags = { oval.config.stm_flags with + Stm.AsyncOpts.async_proofs_worker_priority = get_priority opt (next ()) + }}} |"-async-proofs-private-flags" -> - { oval with stm_flags = { oval.stm_flags with + { oval with config = { oval.config with stm_flags = { oval.config.stm_flags with Stm.AsyncOpts.async_proofs_private_flags = Some (next ()); - }} + }}} |"-async-proofs-tactic-error-resilience" -> - { oval with stm_flags = { oval.stm_flags with + { oval with config = { oval.config with stm_flags = { oval.config.stm_flags with Stm.AsyncOpts.async_proofs_tac_error_resilience = get_error_resilience opt (next ()) - }} + }}} |"-async-proofs-command-error-resilience" -> - { oval with stm_flags = { oval.stm_flags with + { oval with config = { oval.config with stm_flags = { oval.config.stm_flags with Stm.AsyncOpts.async_proofs_cmd_error_resilience = get_bool opt (next ()) - }} + }}} |"-async-proofs-delegation-threshold" -> - { oval with stm_flags = { oval.stm_flags with + { oval with config = { oval.config with stm_flags = { oval.config.stm_flags with Stm.AsyncOpts.async_proofs_delegation_threshold = get_float opt (next ()) - }} + }}} |"-worker-id" -> set_worker_id opt (next ()); oval @@ -378,7 +382,7 @@ let parse_args ~help ~init arglist : t * string list = |"-dump-glob" -> Dumpglob.dump_into_file (next ()); - { oval with glob_opt = true } + { oval with config = { oval.config with glob_opt = true }} |"-feedback-glob" -> Dumpglob.feedback_glob (); oval @@ -387,7 +391,7 @@ let parse_args ~help ~init arglist : t * string list = System.exclude_directory (next ()); oval |"-init-file" -> - { oval with rcfile = Some (next ()); } + { oval with config = { oval.config with rcfile = Some (next ()); }} |"-inputstate"|"-is" -> set_inputstate oval (next ()) @@ -441,10 +445,10 @@ let parse_args ~help ~init arglist : t * string list = let topname = Libnames.dirpath_of_string (next ()) in if Names.DirPath.is_empty topname then CErrors.user_err Pp.(str "Need a non empty toplevel module name"); - { oval with toplevel_name = Stm.TopLogical topname } + { oval with config = { oval.config with logic = { oval.config.logic with toplevel_name = Stm.TopLogical topname }}} |"-topfile" -> - { oval with toplevel_name = Stm.TopPhysical (next()) } + { oval with config = { oval.config with logic = { oval.config.logic with toplevel_name = Stm.TopPhysical (next()) }}} |"-main-channel" -> Spawned.main_channel := get_host_port opt (next()); oval @@ -462,7 +466,7 @@ let parse_args ~help ~init arglist : t * string list = oval |"-bytecode-compiler" -> - { oval with enable_VM = get_bool opt (next ()) } + { oval with config = { oval.config with enable_VM = get_bool opt (next ()) }} |"-native-compiler" -> @@ -479,68 +483,63 @@ let parse_args ~help ~init arglist : t * string list = | _ -> error_wrong_arg ("Error: (yes|no|ondemand) expected after option -native-compiler") in - { oval with native_compiler } + { oval with config = { oval.config with native_compiler }} | "-set" -> let opt = next() in let opt, v = parse_option_set opt in - { oval with set_options = (opt, OptionSet v) :: oval.set_options } + { oval with config = { oval.config with set_options = (opt, OptionSet v) :: oval.config.set_options }} | "-unset" -> let opt = next() in let opt = to_opt_key opt in - { oval with set_options = (opt, OptionUnset) :: oval.set_options } + { oval with config = { oval.config with set_options = (opt, OptionUnset) :: oval.config.set_options }} (* Options with zero arg *) |"-async-queries-always-delegate" |"-async-proofs-always-delegate" |"-async-proofs-never-reopen-branch" -> - { oval with stm_flags = { oval.stm_flags with + { oval with config = { oval.config with stm_flags = { oval.config.stm_flags with Stm.AsyncOpts.async_proofs_never_reopen_branch = true - }} - |"-batch" -> - Flags.quiet := true; - { oval with batch = true } + }}} |"-test-mode" -> Vernacentries.test_mode := true; oval |"-beautify" -> Flags.beautify := true; oval |"-bt" -> Backtrace.record_backtrace true; oval |"-color" -> set_color oval (next ()) - |"-config"|"--config" -> { oval with print_config = true } + |"-config"|"--config" -> set_query oval PrintConfig |"-debug" -> Coqinit.set_debug (); oval |"-diffs" -> let opt = next () in if List.exists (fun x -> opt = x) ["off"; "on"; "removed"] then Proof_diffs.write_diffs_option opt else error_wrong_arg "Error: on|off|removed expected after -diffs"; - { oval with diffs_set = true } + { oval with config = { oval.config with diffs_set = true }} |"-stm-debug" -> Stm.stm_debug := true; oval |"-emacs" -> set_emacs oval - |"-filteropts" -> { oval with filter_opts = true } |"-impredicative-set" -> - { oval with impredicative_set = Declarations.ImpredicativeSet } - |"-allow-sprop" -> { oval with allow_sprop = true } - |"-disallow-sprop" -> { oval with allow_sprop = false } - |"-sprop-cumulative" -> { oval with cumulative_sprop = true } - |"-indices-matter" -> { oval with indices_matter = true } - |"-m"|"--memory" -> { oval with memory_stat = true } - |"-noinit"|"-nois" -> { oval with load_init = false } - |"-no-glob"|"-noglob" -> Dumpglob.noglob (); { oval with glob_opt = true } - |"-output-context" -> { oval with output_context = true } + set_logic (fun o -> { o with impredicative_set = Declarations.ImpredicativeSet }) oval + |"-allow-sprop" -> set_logic (fun o -> { o with allow_sprop = true }) oval + |"-disallow-sprop" -> set_logic (fun o -> { o with allow_sprop = false }) oval + |"-sprop-cumulative" -> set_logic (fun o -> { o with cumulative_sprop = true }) oval + |"-indices-matter" -> set_logic (fun o -> { o with indices_matter = true }) oval + |"-m"|"--memory" -> { oval with post = { oval.post with memory_stat = true }} + |"-noinit"|"-nois" -> { oval with pre = { oval.pre with load_init = false }} + |"-no-glob"|"-noglob" -> Dumpglob.noglob (); { oval with config = { oval.config with glob_opt = true }} + |"-output-context" -> { oval with post = { oval.post with output_context = true }} |"-profile-ltac" -> Flags.profile_ltac := true; oval - |"-q" -> { oval with load_rcfile = false; } + |"-q" -> { oval with pre = { oval.pre with load_rcfile = false; }} |"-quiet"|"-silent" -> Flags.quiet := true; Flags.make_warn false; oval - |"-list-tags" -> { oval with print_tags = true } - |"-time" -> { oval with time = true } + |"-list-tags" -> set_query oval PrintTags + |"-time" -> { oval with config = { oval.config with time = true }} |"-type-in-type" -> set_type_in_type (); oval |"-unicode" -> add_vo_require oval "Utf8_core" None (Some false) - |"-where" -> { oval with print_where = true } - |"-h"|"-H"|"-?"|"-help"|"--help" -> usage help; oval - |"-v"|"--version" -> Usage.version (exitcode oval) - |"-print-version"|"--print-version" -> - Usage.machine_readable_version (exitcode oval) + |"-where" -> set_query oval PrintWhere + |"-h"|"-H"|"-?"|"-help"|"--help" -> set_query oval (PrintHelp help) + |"-v"|"--version" -> set_query oval PrintVersion + |"-print-version"|"--print-version" -> set_query oval PrintMachineReadableVersion (* Unknown option *) | s -> @@ -560,11 +559,11 @@ let parse_args ~help ~init arglist : t * string list = let prelude_data = "Prelude", Some "Coq", Some false let require_libs opts = - if opts.load_init then prelude_data :: opts.vo_requires else opts.vo_requires + if opts.pre.load_init then prelude_data :: opts.pre.vo_requires else opts.pre.vo_requires let cmdline_load_path opts = - List.rev opts.vo_includes @ List.(rev opts.ml_includes) + List.rev opts.pre.vo_includes @ List.(rev opts.pre.ml_includes) let build_load_path opts = - Coqinit.libs_init_load_path ~load_init:opts.load_init @ + Coqinit.libs_init_load_path ~load_init:opts.pre.load_init @ cmdline_load_path opts diff --git a/toplevel/coqargs.mli b/toplevel/coqargs.mli index 81f8983e98..e414888861 100644 --- a/toplevel/coqargs.mli +++ b/toplevel/coqargs.mli @@ -16,57 +16,69 @@ type native_compiler = NativeOff | NativeOn of { ondemand : bool } type option_command = OptionSet of string option | OptionUnset -type t = { +type coqargs_logic_config = { + impredicative_set : Declarations.set_predicativity; + indices_matter : bool; + toplevel_name : Stm.interactive_top; + allow_sprop : bool; + cumulative_sprop : bool; +} + +type coqargs_config = { + logic : coqargs_logic_config; + rcfile : string option; + coqlib : string option; + color : color; + enable_VM : bool; + native_compiler : native_compiler; + stm_flags : Stm.AsyncOpts.stm_opt; + debug : bool; + diffs_set : bool; + time : bool; + glob_opt : bool; + print_emacs : bool; + set_options : (Goptions.option_name * option_command) list; +} +type coqargs_pre = { load_init : bool; load_rcfile : bool; - rcfile : string option; ml_includes : Loadpath.coq_path list; vo_includes : Loadpath.coq_path list; vo_requires : (string * string option * bool option) list; - - toplevel_name : Stm.interactive_top; + (* None = No Import; Some false = Import; Some true = Export *) load_vernacular_list : (string * bool) list; - batch : bool; - - color : color; - - impredicative_set : Declarations.set_predicativity; - indices_matter : bool; - enable_VM : bool; - native_compiler : native_compiler; - allow_sprop : bool; - cumulative_sprop : bool; - - set_options : (Goptions.option_name * option_command) list; - - stm_flags : Stm.AsyncOpts.stm_opt; - debug : bool; - diffs_set : bool; - time : bool; + inputstate : string option; +} - filter_opts : bool; +type coqargs_query = + | PrintTags | PrintWhere | PrintConfig + | PrintVersion | PrintMachineReadableVersion + | PrintHelp of Usage.specific_usage - glob_opt : bool; +type coqargs_main = + | Queries of coqargs_query list + | Run +type coqargs_post = { memory_stat : bool; - print_tags : bool; - print_where : bool; - print_config: bool; output_context : bool; +} - print_emacs : bool; - - inputstate : string option; +type t = { + config : coqargs_config; + pre : coqargs_pre; + main : coqargs_main; + post : coqargs_post; } (* Default options *) val default : t -val parse_args : help:(unit -> unit) -> init:t -> string list -> t * string list -val exitcode : t -> int +val parse_args : help:Usage.specific_usage -> init:t -> string list -> t * string list +val error_wrong_arg : string -> unit val require_libs : t -> (string * string option * bool option) list val build_load_path : t -> Loadpath.coq_path list diff --git a/toplevel/coqc.ml b/toplevel/coqc.ml index a04552e8db..5678acb2b1 100644 --- a/toplevel/coqc.ml +++ b/toplevel/coqc.ml @@ -8,32 +8,37 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -let set_noninteractive_mode () = - Flags.quiet := true; - System.trust_file_cache := true - let outputstate opts = Option.iter (fun ostate_file -> let fname = CUnix.make_suffix ostate_file ".coq" in States.extern_state fname) opts.Coqcargs.outputstate -let coqc_main () = - (* Careful because init_toplevel will call Summary.init_summaries, - thus options such as `quiet` have to be set after the main - initialisation is run. *) - let coqc_init ~opts args = - set_noninteractive_mode (); - let opts, args = Coqtop.(coqtop_toplevel.init) ~opts args in - opts, args - in - let opts, extras = - Topfmt.(in_phase ~phase:Initialization) - Coqtop.(init_toplevel ~help:Usage.print_usage_coqc ~init:Coqargs.default coqc_init) List.(tl (Array.to_list Sys.argv)) in - - let copts = Coqcargs.parse extras in +let coqc_init _copts ~opts = + Flags.quiet := true; + System.trust_file_cache := true; + Coqtop.init_color opts.Coqargs.config; + if not opts.Coqargs.config.Coqargs.glob_opt then Dumpglob.dump_to_dotglob () - if not opts.Coqargs.glob_opt then Dumpglob.dump_to_dotglob (); +let coqc_specific_usage = Usage.{ + executable_name = "coqc"; + extra_args = "file..."; + extra_options = "\n\ +coqc specific options:\ +\n -o f.vo use f.vo as the output file name\ +\n -verbose compile and output the input file\ +\n -quick quickly compile .v files to .vio files (skip proofs)\ +\n -schedule-vio2vo j f1..fn run up to j instances of Coq to turn each fi.vio\ +\n into fi.vo\ +\n -schedule-vio-checking j f1..fn run up to j instances of Coq to check all\ +\n proofs in each fi.vio\ +\n\ +\nUndocumented:\ +\n -vio2vo [see manual]\ +\n -check-vio-tasks [see manual]\ +\n" +} +let coqc_main copts ~opts = Topfmt.(in_phase ~phase:CompilationPhase) Ccompile.compile_files opts copts; @@ -47,16 +52,16 @@ let coqc_main () = flush_all(); - if opts.Coqargs.output_context then begin + if opts.Coqargs.post.Coqargs.output_context then begin let sigma, env = let e = Global.env () in Evd.from_env e, e in Feedback.msg_notice Pp.(Flags.(with_option raw_print (Prettyp.print_full_pure_context env) sigma) ++ fnl ()) end; CProfile.print_profile () -let main () = +let coqc_run copts ~opts () = let _feeder = Feedback.add_feeder Coqloop.coqloop_feed in try - coqc_main (); + coqc_main ~opts copts; exit 0 with exn -> flush_all(); @@ -64,3 +69,14 @@ let main () = flush_all(); let exit_code = if (CErrors.is_anomaly exn) then 129 else 1 in exit exit_code + +let custom_coqc = Coqtop.{ + parse_extra = (fun ~opts extras -> Coqcargs.parse extras, []); + help = coqc_specific_usage; + init = coqc_init; + run = coqc_run; + opts = Coqargs.default; +} + +let main () = + Coqtop.start_coq custom_coqc diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 4bcde566e3..e49b1c0c07 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -315,8 +315,8 @@ let coqloop_feed (fb : Feedback.feedback) = let open Feedback in (* Flush in a compatible order with 8.5 *) (* This mimics the semantics of the old Pp.flush_all *) let loop_flush_all () = - Pervasives.flush stderr; - Pervasives.flush stdout; + flush stderr; + flush stdout; Format.pp_print_flush !Topfmt.std_ft (); Format.pp_print_flush !Topfmt.err_ft () @@ -444,7 +444,7 @@ let drop_args = ref None let loop ~opts ~state = drop_args := Some opts; let open Coqargs in - print_emacs := opts.print_emacs; + print_emacs := opts.config.print_emacs; (* We initialize the console only if we run the toploop_run *) let tl_feed = Feedback.add_feeder coqloop_feed in if Dumpglob.dump () then begin diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index e43e6a8da4..f09d202edf 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -11,6 +11,9 @@ open Pp open Coqargs +(** This file provides generic support for Coq executables + specific + support for the coqtop executable *) + let () = at_exit flush_all let ( / ) = Filename.concat @@ -30,25 +33,18 @@ let print_header () = Feedback.msg_notice (str "Welcome to Coq " ++ str ver ++ str " (" ++ str rev ++ str ")"); flush_all () -let memory_stat = ref false let print_memory_stat () = - begin (* -m|--memory from the command-line *) - if !memory_stat then - Feedback.msg_notice - (str "total heap size = " ++ int (CObj.heap_size_kb ()) ++ str " kbytes" ++ fnl ()); - end; - begin - (* operf-macro interface: - https://github.com/OCamlPro/operf-macro *) - try - let fn = Sys.getenv "OCAML_GC_STATS" in - let oc = open_out fn in - Gc.print_stat oc; - close_out oc - with _ -> () - end - -let _ = at_exit print_memory_stat + (* -m|--memory from the command-line *) + Feedback.msg_notice + (str "total heap size = " ++ int (CObj.heap_size_kb ()) ++ str " kbytes" ++ fnl ()); + (* operf-macro interface: + https://github.com/OCamlPro/operf-macro *) + try + let fn = Sys.getenv "OCAML_GC_STATS" in + let oc = open_out fn in + Gc.print_stat oc; + close_out oc + with _ -> () let interp_set_option opt v old = let open Goptions in @@ -159,6 +155,14 @@ let print_style_tags opts = let () = List.iter iter tags in flush_all () +let print_query opts = function + | PrintVersion -> Usage.version () + | PrintMachineReadableVersion -> Usage.machine_readable_version () + | PrintWhere -> print_endline (Envars.coqlib ()) + | PrintHelp h -> Usage.print_usage stderr h + | PrintConfig -> Envars.print_config stdout Coq_config.all_src_dirs + | PrintTags -> print_style_tags opts.config + (** GC tweaking *) (** Coq is a heavy user of persistent data structures and symbolic ASTs, so the @@ -184,123 +188,155 @@ let init_gc () = Gc.minor_heap_size = 33554432; (* 4M *) Gc.space_overhead = 120} -(** Main init routine *) -let init_toplevel ~help ~init custom_init arglist = +let init_setup = function + | None -> Envars.set_coqlib ~fail:(fun msg -> CErrors.user_err Pp.(str msg)); + | Some s -> Envars.set_user_coqlib s + +let init_process () = (* Coq's init process, phase 1: OCaml parameters, basic structures, and IO *) CProfile.init_profile (); init_gc (); Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *) - - Lib.init(); - + Lib.init () + +let init_parse parse_extra help init_opts = + let opts, extras = + parse_args ~help:help ~init:init_opts + (List.tl (Array.to_list Sys.argv)) in + let customopts, extras = parse_extra ~opts extras in + if not (CList.is_empty extras) then begin + prerr_endline ("Don't know what to do with "^String.concat " " extras); + prerr_endline "See -help for the list of supported options"; + exit 1 + end; + opts, customopts + +let init_execution opts custom_init = (* Coq's init process, phase 2: Basic Coq environment, load-path, plugins. *) - let opts, extras = parse_args ~help ~init arglist in - memory_stat := opts.memory_stat; - (* If we have been spawned by the Spawn module, this has to be done * early since the master waits us to connect back *) Spawned.init_channels (); - Envars.set_coqlib ~fail:(fun msg -> CErrors.user_err Pp.(str msg)); - if opts.print_where then begin - print_endline (Envars.coqlib ()); - exit (exitcode opts) - end; - if opts.print_config then begin - Envars.print_config stdout Coq_config.all_src_dirs; - exit (exitcode opts) - end; - if opts.print_tags then begin - print_style_tags opts; - exit (exitcode opts) - end; - if opts.filter_opts then begin - print_string (String.concat "\n" extras); - exit 0; - end; + if opts.post.memory_stat then at_exit print_memory_stat; let top_lp = Coqinit.toplevel_init_load_path () in List.iter Loadpath.add_coq_path top_lp; - let opts, extras = custom_init ~opts extras in + CoqworkmgrApi.(init opts.config.stm_flags.Stm.AsyncOpts.async_proofs_worker_priority); Mltop.init_known_plugins (); + (* Configuration *) + Global.set_engagement opts.config.logic.impredicative_set; + Global.set_indices_matter opts.config.logic.indices_matter; + Global.set_VM opts.config.enable_VM; + Global.set_native_compiler (match opts.config.native_compiler with NativeOff -> false | NativeOn _ -> true); + Global.set_allow_sprop opts.config.logic.allow_sprop; + if opts.config.logic.cumulative_sprop then Global.make_sprop_cumulative (); - Global.set_engagement opts.impredicative_set; - Global.set_indices_matter opts.indices_matter; - Global.set_VM opts.enable_VM; - Global.set_native_compiler (match opts.native_compiler with NativeOff -> false | NativeOn _ -> true); - Global.set_allow_sprop opts.allow_sprop; - if opts.cumulative_sprop then Global.make_sprop_cumulative (); - - set_options opts.set_options; + set_options opts.config.set_options; (* Allow the user to load an arbitrary state here *) - inputstate opts; + inputstate opts.pre; (* This state will be shared by all the documents *) Stm.init_core (); + custom_init ~opts + +type 'a extra_args_fn = opts:Coqargs.t -> string list -> 'a * string list + +type ('a,'b) custom_toplevel = + { parse_extra : 'a extra_args_fn + ; help : Usage.specific_usage + ; init : 'a -> opts:Coqargs.t -> 'b + ; run : 'a -> opts:Coqargs.t -> 'b -> unit + ; opts : Coqargs.t + } +(** Main init routine *) +let init_toplevel custom = + let () = init_process () in + let opts, customopts = init_parse custom.parse_extra custom.help custom.opts in + let () = init_setup opts.config.coqlib in + (* Querying or running? *) + match opts.main with + | Queries q -> List.iter (print_query opts) q; exit 0 + | Run -> + let customstate = init_execution opts (custom.init customopts) in + opts, customopts, customstate + +let init_document opts = (* Coq init process, phase 3: Stm initialization, backtracking state. It is essential that the module system is in a consistent state before we take the first snapshot. This was not guaranteed in the past, but now is thanks to the STM API. *) - opts, extras - -type init_fn = opts:Coqargs.t -> string list -> Coqargs.t * string list - -type custom_toplevel = - { init : init_fn - ; run : opts:Coqargs.t -> state:Vernac.State.t -> unit - ; opts : Coqargs.t - } - - -let init_toploop opts = let iload_path = build_load_path opts in let require_libs = require_libs opts in - let stm_options = opts.stm_flags in + let stm_options = opts.config.stm_flags in let open Vernac.State in let doc, sid = Stm.(new_doc - { doc_type = Interactive opts.toplevel_name; + { doc_type = Interactive opts.config.logic.toplevel_name; iload_path; require_libs; stm_options; }) in - let state = { doc; sid; proof = None; time = opts.time } in - Ccompile.load_init_vernaculars opts ~state, opts - -let coqtop_init ~opts extra = - init_color opts; - CoqworkmgrApi.(init !async_proofs_worker_priority); - Flags.if_verbose print_header (); - opts, extra - -let coqtop_toplevel = - { init = coqtop_init - ; run = Coqloop.loop - ; opts = Coqargs.default - } + { doc; sid; proof = None; time = opts.config.time } let start_coq custom = let init_feeder = Feedback.add_feeder Coqloop.coqloop_feed in (* Init phase *) - let state, opts = - try - let opts, extras = - init_toplevel - ~help:Usage.print_usage_coqtop ~init:default custom.init - (List.tl (Array.to_list Sys.argv)) in - if not (CList.is_empty extras) then begin - prerr_endline ("Don't know what to do with "^String.concat " " extras); - prerr_endline "See -help for the list of supported options"; - exit 1 - end; - init_toploop opts + let opts, custom_opts, state = + try init_toplevel custom with any -> flush_all(); fatal_error_exn any in Feedback.del_feeder init_feeder; - if not opts.batch then custom.run ~opts ~state; - exit 0 + (* Run phase *) + custom.run ~opts custom_opts state + +(** ****************************************) +(** Specific support for coqtop executable *) + +type run_mode = Interactive | Batch + +let init_toploop opts = + let state = init_document opts in + let state = Ccompile.load_init_vernaculars opts ~state in + state + +let coqtop_init run_mode ~opts = + if run_mode = Batch then Flags.quiet := true; + init_color opts.config; + Flags.if_verbose print_header (); + init_toploop opts + +let coqtop_parse_extra ~opts extras = + let rec parse_extra run_mode = function + | "-batch" :: rest -> parse_extra Batch rest + | x :: rest -> + let run_mode, rest = parse_extra run_mode rest in run_mode, x :: rest + | [] -> run_mode, [] in + let run_mode, extras = parse_extra Interactive extras in + run_mode, extras + +let coqtop_run run_mode ~opts state = + match run_mode with + | Interactive -> Coqloop.loop ~opts ~state; + | Batch -> exit 0 + +let coqtop_specific_usage = Usage.{ + executable_name = "coqtop"; + extra_args = ""; + extra_options = "\n\ +coqtop specific options:\n\ +\n -batch batch mode (exits after interpretation of command line)\ +\n" +} + +let coqtop_toplevel = + { parse_extra = coqtop_parse_extra + ; help = coqtop_specific_usage + ; init = coqtop_init + ; run = coqtop_run + ; opts = Coqargs.default + } diff --git a/toplevel/coqtop.mli b/toplevel/coqtop.mli index 40f569a1c8..4fe7d538a8 100644 --- a/toplevel/coqtop.mli +++ b/toplevel/coqtop.mli @@ -13,29 +13,33 @@ [run] launches a custom toplevel. *) -type init_fn = opts:Coqargs.t -> string list -> Coqargs.t * string list +type 'a extra_args_fn = opts:Coqargs.t -> string list -> 'a * string list -type custom_toplevel = - { init : init_fn - ; run : opts:Coqargs.t -> state:Vernac.State.t -> unit +type ('a,'b) custom_toplevel = + { parse_extra : 'a extra_args_fn + ; help : Usage.specific_usage + ; init : 'a -> opts:Coqargs.t -> 'b + ; run : 'a -> opts:Coqargs.t -> 'b -> unit ; opts : Coqargs.t } -(** [init_toplevel ~help ~init custom_init arg_list] - Common Coq initialization and argument parsing *) -val init_toplevel - : help:(unit -> unit) - -> init:Coqargs.t - -> init_fn - -> string list - -> Coqargs.t * string list - -val coqtop_toplevel : custom_toplevel - -(** The Coq main module. [start custom] will parse the command line, +(** The generic Coq main module. [start custom] will parse the command line, print the banner, initialize the load path, load the input state, load the files given on the command line, load the resource file, produce the output state if any, and finally will launch [custom.run]. *) +val start_coq : ('a,'b) custom_toplevel -> unit + +(** Initializer color for output *) + +val init_color : Coqargs.coqargs_config -> unit + +(** Prepare state for interactive loop *) + +val init_toploop : Coqargs.t -> Vernac.State.t + +(** The specific characterization of the coqtop_toplevel *) + +type run_mode = Interactive | Batch -val start_coq : custom_toplevel -> unit +val coqtop_toplevel : (run_mode,Vernac.State.t) custom_toplevel diff --git a/toplevel/usage.ml b/toplevel/usage.ml index 91b3c32126..cdb2e36fbd 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -8,21 +8,17 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -let version ret = +let version () = Printf.printf "The Coq Proof Assistant, version %s (%s)\n" Coq_config.version Coq_config.date; - Printf.printf "compiled on %s with OCaml %s\n" Coq_config.compile_date Coq_config.caml_version; - exit ret -let machine_readable_version ret = + Printf.printf "compiled on %s with OCaml %s\n" Coq_config.compile_date Coq_config.caml_version + +let machine_readable_version () = Printf.printf "%s %s\n" - Coq_config.version Coq_config.caml_version; - exit ret + Coq_config.version Coq_config.caml_version (* print the usage of coqtop (or coqc) on channel co *) -let extra_usage = ref [] -let add_to_usage name text = extra_usage := (name,text) :: !extra_usage - let print_usage_common co command = output_string co command; output_string co "Coq options are:\n"; @@ -99,42 +95,16 @@ let print_usage_common co command = \n -bytecode-compiler (yes|no) enable the vm_compute reduction machine\ \n -native-compiler (yes|no|ondemand) enable the native_compute reduction machine\ \n -h, -help, --help print this list of options\ -\n"; - List.iter (fun (name, text) -> - output_string co - ("\nWith the flag '-toploop "^name^ - "' these extra option are also available:\n"^ - text^"\n")) - !extra_usage +\n" -(* print the usage on standard error *) +(* print the usage *) -let print_usage_coqtop () = - print_usage_common stderr "Usage: coqtop <options>\n\n"; - output_string stderr "\n\ -coqtop specific options:\ -\n\ -\n -batch batch mode (exits just after argument parsing)\ -\n"; - flush stderr ; - exit 1 +type specific_usage = { + executable_name : string; + extra_args : string; + extra_options : string; +} -let print_usage_coqc () = - print_usage_common stderr "Usage: coqc <options> <Coq options> file...\n\n"; - output_string stderr "\n\ -coqc specific options:\ -\n\ -\n -o f.vo use f.vo as the output file name\ -\n -verbose compile and output the input file\ -\n -quick quickly compile .v files to .vio files (skip proofs)\ -\n -schedule-vio2vo j f1..fn run up to j instances of Coq to turn each fi.vio\ -\n into fi.vo\ -\n -schedule-vio-checking j f1..fn run up to j instances of Coq to check all\ -\n proofs in each fi.vio\ -\n\ -\nUndocumented:\ -\n -vio2vo [see manual]\ -\n -check-vio-tasks [see manual]\ -\n"; - flush stderr ; - exit 1 +let print_usage co { executable_name; extra_args; extra_options } = + print_usage_common co ("Usage: " ^ executable_name ^ " <options> " ^ extra_args ^ "\n\n"); + output_string co extra_options diff --git a/toplevel/usage.mli b/toplevel/usage.mli index 1f257a5896..536cbdc6b2 100644 --- a/toplevel/usage.mli +++ b/toplevel/usage.mli @@ -8,15 +8,22 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(** {6 Prints the version number on the standard output and exits (with 0). } *) +(** {6 Prints the version number on the standard output. } *) -val version : int -> 'a -val machine_readable_version : int -> 'a +val version : unit -> unit +val machine_readable_version : unit -> unit -(** {6 Enable toploop plugins to insert some text in the usage message. } *) -val add_to_usage : string -> string -> unit +(** {6 extra arguments or options to print when asking usage for a + given executable. } *) -(** {6 Prints the usage on the error output. } *) -val print_usage_coqtop : unit -> unit -val print_usage_coqc : unit -> unit +type specific_usage = { + executable_name : string; + extra_args : string; + extra_options : string; +} + +(** {6 Prints the generic part and specific part of usage for a + given executable. } *) + +val print_usage : out_channel -> specific_usage -> unit diff --git a/toplevel/workerLoop.ml b/toplevel/workerLoop.ml index d362f9db22..5f80ac475c 100644 --- a/toplevel/workerLoop.ml +++ b/toplevel/workerLoop.ml @@ -13,18 +13,28 @@ let rec parse = function | x :: rest -> x :: parse rest | [] -> [] -let arg_init init ~opts extra_args = - let extra_args = parse extra_args in +let worker_parse_extra ~opts extra_args = + (), parse extra_args + +let worker_init init () ~opts = Flags.quiet := true; init (); - CoqworkmgrApi.(init !async_proofs_worker_priority); - opts, extra_args + Coqtop.init_toploop opts + +let worker_specific_usage name = Usage.{ + executable_name = name; + extra_args = ""; + extra_options = ("\n" ^ name ^ " specific options:\ +\n --xml_format=Ppcmds serialize pretty printing messages using the std_ppcmds format\n"); +} -let start ~init ~loop = +let start ~init ~loop name = let open Coqtop in let custom = { + parse_extra = worker_parse_extra; + help = worker_specific_usage name; opts = Coqargs.default; - init = arg_init init; - run = (fun ~opts:_ ~state:_ -> loop ()); + init = worker_init init; + run = (fun () ~opts:_ _state (* why is state not used *) -> loop ()); } in start_coq custom diff --git a/toplevel/workerLoop.mli b/toplevel/workerLoop.mli index 685a10f6f3..8d6f0b1988 100644 --- a/toplevel/workerLoop.mli +++ b/toplevel/workerLoop.mli @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(* Register a STM worker *) +(* Register a STM worker of a given executable name *) val start : init:(unit -> unit) -> - loop:(unit -> unit) -> unit + loop:(unit -> unit) -> string -> unit diff --git a/user-contrib/Ltac2/tac2core.ml b/user-contrib/Ltac2/tac2core.ml index a05612c1b1..f6775ddd1f 100644 --- a/user-contrib/Ltac2/tac2core.ml +++ b/user-contrib/Ltac2/tac2core.ml @@ -1094,7 +1094,7 @@ let () = let () = let intern self ist ref = match ref.CAst.v with | Tac2qexpr.QHypothesis id -> - GlbVal (Globnames.VarRef id), gtypref t_reference + GlbVal (GlobRef.VarRef id), gtypref t_reference | Tac2qexpr.QReference qid -> let gr = try Nametab.locate qid @@ -1106,7 +1106,7 @@ let () = let subst s c = Globnames.subst_global_reference s c in let interp _ gr = return (Value.of_reference gr) in let print _ = function - | Globnames.VarRef id -> str "reference:(" ++ str "&" ++ Id.print id ++ str ")" + | GlobRef.VarRef id -> str "reference:(" ++ str "&" ++ Id.print id ++ str ")" | r -> str "reference:(" ++ Printer.pr_global r ++ str ")" in let obj = { diff --git a/user-contrib/Ltac2/tac2entries.ml b/user-contrib/Ltac2/tac2entries.ml index 624d4d7f04..3b8fc58c6f 100644 --- a/user-contrib/Ltac2/tac2entries.ml +++ b/user-contrib/Ltac2/tac2entries.ml @@ -811,18 +811,18 @@ let () = register_handler begin function | _ -> raise Unhandled end -let () = ExplainErr.register_additional_error_info begin fun (e, info) -> +let () = CErrors.register_additional_error_info begin fun info -> if !Tac2interp.print_ltac2_backtrace then let bt = Exninfo.get info backtrace in let bt = match bt with | Some bt -> bt - | None -> raise Exit + | None -> [] in let bt = str "Backtrace:" ++ fnl () ++ prlist_with_sep fnl pr_frame bt ++ fnl () in Some (Loc.tag @@ Some bt) - else raise Exit + else None end (** Printing *) diff --git a/user-contrib/Ltac2/tac2ffi.ml b/user-contrib/Ltac2/tac2ffi.ml index ee61bdab71..0e6fb94095 100644 --- a/user-contrib/Ltac2/tac2ffi.ml +++ b/user-contrib/Ltac2/tac2ffi.ml @@ -10,7 +10,6 @@ open Util open Names -open Globnames open Tac2dyn open Tac2expr open Proofview.Notations @@ -337,13 +336,13 @@ let of_constant c = of_ext val_constant c let to_constant c = to_ext val_constant c let constant = repr_ext val_constant -let of_reference = function +let of_reference = let open GlobRef in function | VarRef id -> ValBlk (0, [| of_ident id |]) | ConstRef cst -> ValBlk (1, [| of_constant cst |]) | IndRef ind -> ValBlk (2, [| of_ext val_inductive ind |]) | ConstructRef cstr -> ValBlk (3, [| of_ext val_constructor cstr |]) -let to_reference = function +let to_reference = let open GlobRef in function | ValBlk (0, [| id |]) -> VarRef (to_ident id) | ValBlk (1, [| cst |]) -> ConstRef (to_constant cst) | ValBlk (2, [| ind |]) -> IndRef (to_ext val_inductive ind) diff --git a/user-contrib/Ltac2/tac2print.ml b/user-contrib/Ltac2/tac2print.ml index b89067086f..1ece3d4242 100644 --- a/user-contrib/Ltac2/tac2print.ml +++ b/user-contrib/Ltac2/tac2print.ml @@ -473,8 +473,7 @@ end let () = register_init "err" begin fun _ _ e -> let e = to_ext val_exn e in - let (e, _) = ExplainErr.process_vernac_interp_error e in - str "err:(" ++ CErrors.print_no_report e ++ str ")" + str "err:(" ++ CErrors.iprint e ++ str ")" end let () = diff --git a/user-contrib/Ltac2/tac2tactics.ml b/user-contrib/Ltac2/tac2tactics.ml index 6c96ef7742..561bd9c0c5 100644 --- a/user-contrib/Ltac2/tac2tactics.ml +++ b/user-contrib/Ltac2/tac2tactics.ml @@ -11,7 +11,6 @@ open Pp open Util open Names -open Globnames open Tac2types open Tac2extffi open Genredexpr @@ -209,13 +208,13 @@ let letin_pat_tac ev ipat na c cl = Instead, we parse indifferently any pattern and dispatch when the tactic is called. *) let map_pattern_with_occs (pat, occ) = match pat with -| Pattern.PRef (ConstRef cst) -> (mk_occurrences_expr occ, Inl (EvalConstRef cst)) -| Pattern.PRef (VarRef id) -> (mk_occurrences_expr occ, Inl (EvalVarRef id)) +| Pattern.PRef (GlobRef.ConstRef cst) -> (mk_occurrences_expr occ, Inl (EvalConstRef cst)) +| Pattern.PRef (GlobRef.VarRef id) -> (mk_occurrences_expr occ, Inl (EvalVarRef id)) | _ -> (mk_occurrences_expr occ, Inr pat) let get_evaluable_reference = function -| VarRef id -> Proofview.tclUNIT (EvalVarRef id) -| ConstRef cst -> Proofview.tclUNIT (EvalConstRef cst) +| GlobRef.VarRef id -> Proofview.tclUNIT (EvalVarRef id) +| GlobRef.ConstRef cst -> Proofview.tclUNIT (EvalConstRef cst) | r -> Tacticals.New.tclZEROMSG (str "Cannot coerce" ++ spc () ++ Nametab.pr_global_env Id.Set.empty r ++ spc () ++ diff --git a/vernac/assumptions.ml b/vernac/assumptions.ml index d7cb9dc727..ab341e4ab8 100644 --- a/vernac/assumptions.ml +++ b/vernac/assumptions.ml @@ -24,7 +24,6 @@ open Constr open Context open Declarations open Mod_subst -open Globnames open Printer open Context.Named.Declaration @@ -157,13 +156,15 @@ let lookup_mind mind = (** Graph traversal of an object, collecting on the way the dependencies of traversed objects *) -let label_of = function +let label_of = let open GlobRef in function | ConstRef kn -> Constant.label kn | IndRef (kn,_) | ConstructRef ((kn,_),_) -> MutInd.label kn | VarRef id -> Label.of_id id -let rec traverse current ctx accu t = match Constr.kind t with +let rec traverse current ctx accu t = + let open GlobRef in + match Constr.kind t with | Var id -> let body () = id |> Global.lookup_named |> NamedDecl.get_value in traverse_object accu body (VarRef id) @@ -218,7 +219,7 @@ and traverse_object ?inhabits (curr, data, ax2ty) body obj = definition share exactly the same dependencies. Also, there is no explicit dependency between mutually defined inductives and constructors. *) and traverse_inductive (curr, data, ax2ty) mind obj = - let firstind_ref = (IndRef (mind, 0)) in + let firstind_ref = (GlobRef.IndRef (mind, 0)) in let label = label_of obj in let data, ax2ty = (* Invariant : I_0 \in data iff I_i \in data iff c_ij \in data @@ -264,9 +265,9 @@ and traverse_inductive (curr, data, ax2ty) mind obj = (* Maps all these dependencies to inductives and constructors*) let data = Array.fold_left_i (fun n data oib -> let ind = (mind, n) in - let data = GlobRef.Map_env.add (IndRef ind) contents data in + let data = GlobRef.Map_env.add (GlobRef.IndRef ind) contents data in Array.fold_left_i (fun k data _ -> - GlobRef.Map_env.add (ConstructRef (ind, k+1)) contents data + GlobRef.Map_env.add (GlobRef.ConstructRef (ind, k+1)) contents data ) data oib.mind_consnames) data mib.mind_packets in data, ax2ty @@ -298,6 +299,7 @@ let type_of_constant cb = cb.Declarations.const_type let assumptions ?(add_opaque=false) ?(add_transparent=false) st gr t = (* Only keep the transitive dependencies *) let (_, graph, ax2ty) = traverse (label_of gr) t in + let open GlobRef in let fold obj _ accu = match obj with | VarRef id -> let decl = Global.lookup_named id in diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index 9b96fbf68a..d414d57c0d 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -21,7 +21,6 @@ open Vars open Termops open Declarations open Names -open Globnames open Inductiveops open Tactics open Ind_tables @@ -201,7 +200,7 @@ let build_beq_scheme mode kn = let eid = Id.of_string ("eq_"^(Id.to_string x)) in let () = try ignore (Environ.lookup_named eid env) - with Not_found -> raise (ParameterWithoutEquality (VarRef x)) + with Not_found -> raise (ParameterWithoutEquality (GlobRef.VarRef x)) in mkVar eid, Evd.empty_side_effects | Cast (x,_,_) -> aux (Term.applist (x,a)) @@ -240,7 +239,7 @@ let build_beq_scheme mode kn = try let _ = Environ.constant_opt_value_in env (kneq, u) in Term.applist (mkConst kneq,a), Evd.empty_side_effects - with Not_found -> raise (ParameterWithoutEquality (ConstRef kn))) + with Not_found -> raise (ParameterWithoutEquality (GlobRef.ConstRef kn))) | Proj _ -> raise (EqUnknown "projection") | Construct _ -> raise (EqUnknown "constructor") | Case _ -> raise (EqUnknown "match") @@ -655,7 +654,7 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). | App (c,ca) -> ( match EConstr.kind sigma c with | Ind (indeq, u) -> - if GlobRef.equal (IndRef indeq) Coqlib.(lib_ref "core.eq.type") + if GlobRef.equal (GlobRef.IndRef indeq) Coqlib.(lib_ref "core.eq.type") then Tacticals.New.tclTHEN (do_replace_bl mode bl_scheme_key ind diff --git a/vernac/class.ml b/vernac/class.ml index 6dba134764..766625a21a 100644 --- a/vernac/class.ml +++ b/vernac/class.ml @@ -20,8 +20,6 @@ open Termops open Environ open Classops open Declare -open Globnames -open Decl_kinds open Libobject let strength_min l = if List.mem `LOCAL l then `LOCAL else `GLOBAL @@ -72,10 +70,10 @@ let check_reference_arity ref = let check_arity = function | CL_FUN | CL_SORT -> () - | CL_CONST cst -> check_reference_arity (ConstRef cst) - | CL_PROJ p -> check_reference_arity (ConstRef (Projection.Repr.constant p)) - | CL_SECVAR id -> check_reference_arity (VarRef id) - | CL_IND kn -> check_reference_arity (IndRef kn) + | CL_CONST cst -> check_reference_arity (GlobRef.ConstRef cst) + | CL_PROJ p -> check_reference_arity (GlobRef.ConstRef (Projection.Repr.constant p)) + | CL_SECVAR id -> check_reference_arity (GlobRef.VarRef id) + | CL_IND kn -> check_reference_arity (GlobRef.IndRef kn) (* Coercions *) @@ -91,12 +89,12 @@ let uniform_cond sigma ctx lt = lt (Context.Rel.to_extended_list EConstr.mkRel 0 ctx) let class_of_global = function - | ConstRef sp -> + | GlobRef.ConstRef sp -> (match Recordops.find_primitive_projection sp with | Some p -> CL_PROJ p | None -> CL_CONST sp) - | IndRef sp -> CL_IND sp - | VarRef id -> CL_SECVAR id - | ConstructRef _ as c -> + | GlobRef.IndRef sp -> CL_IND sp + | GlobRef.VarRef id -> CL_SECVAR id + | GlobRef.ConstructRef _ as c -> user_err ~hdr:"class_of_global" (str "Constructors, such as " ++ Printer.pr_global c ++ str ", cannot be used as a class.") @@ -153,7 +151,7 @@ let strength_of_cl = function | _ -> `GLOBAL let strength_of_global = function - | VarRef _ -> `LOCAL + | GlobRef.VarRef _ -> `LOCAL | _ -> `GLOBAL let get_strength stre ref cls clt = @@ -180,7 +178,7 @@ let build_id_coercion idf_opt source poly = let env = Global.env () in let sigma = Evd.from_env env in let sigma, vs = match source with - | CL_CONST sp -> Evd.fresh_global env sigma (ConstRef sp) + | CL_CONST sp -> Evd.fresh_global env sigma (GlobRef.ConstRef sp) | _ -> error_not_transparent source in let vs = EConstr.Unsafe.to_constr vs in let c = match constant_opt_value_in env (destConst vs) with @@ -208,7 +206,7 @@ let build_id_coercion idf_opt source poly = user_err (strbrk "Cannot be defined as coercion (maybe a bad number of arguments).") in - let idf = + let name = match idf_opt with | Some idf -> idf | None -> @@ -222,9 +220,9 @@ let build_id_coercion idf_opt source poly = (definition_entry ~types:typ_f ~univs ~inline:true (mkCast (val_f, DEFAULTcast, typ_f))) in - let decl = (constr_entry, IsDefinition IdentityCoercion) in - let kn = declare_constant idf decl in - ConstRef kn + let kind = Decls.(IsDefinition IdentityCoercion) in + let kn = declare_constant ~name ~kind constr_entry in + GlobRef.ConstRef kn let check_source = function | Some (CL_FUN as s) -> raise (CoercionError (ForbiddenSourceClass s)) @@ -268,7 +266,7 @@ let inCoercion : coercion -> obj = let declare_coercion coef ?(local = false) ~isid ~src:cls ~target:clt ~params:ps = let isproj = match coef with - | ConstRef c -> Recordops.find_primitive_projection c + | GlobRef.ConstRef c -> Recordops.find_primitive_projection c | _ -> None in let c = { diff --git a/vernac/classes.ml b/vernac/classes.ml index fbcd1744a8..efe452d5f1 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -193,6 +193,7 @@ let discharge_class (_,cl) = ctx in let abs_context cl = + let open GlobRef in match cl.cl_impl with | VarRef _ | ConstructRef _ -> assert false | ConstRef cst -> Lib.section_segment_of_constant cst @@ -255,7 +256,7 @@ let add_class env sigma cl = | Some (Backward, info) -> (match body with | None -> CErrors.user_err Pp.(str "Non-definable projection can not be declared as a subinstance") - | Some b -> declare_instance ~warn:true env sigma (Some info) false (ConstRef b)) + | Some b -> declare_instance ~warn:true env sigma (Some info) false (GlobRef.ConstRef b)) | _ -> ()) cl.cl_projs @@ -298,6 +299,7 @@ let type_ctx_instance ~program_mode env sigma ctx inst subst = in aux (sigma, subst, []) inst (List.rev ctx) let id_of_class cl = + let open GlobRef in match cl.cl_impl with | ConstRef kn -> Label.to_id @@ Constant.label kn | IndRef (kn,i) -> @@ -313,23 +315,22 @@ let instance_hook info global imps ?hook cst = declare_instance env sigma (Some info) (not global) cst; (match hook with Some h -> h cst | None -> ()) -let declare_instance_constant info global imps ?hook id decl poly sigma term termtype = +let declare_instance_constant info global imps ?hook name decl poly sigma term termtype = (* XXX: Duplication of the declare_constant path *) - let kind = IsDefinition Instance in let sigma = let levels = Univ.LSet.union (CVars.universes_of_constr termtype) (CVars.universes_of_constr term) in Evd.restrict_universe_context sigma levels in let uctx = Evd.check_univ_decl ~poly sigma decl in + let kind = Decls.(IsDefinition Instance) in let entry = Declare.definition_entry ~types:termtype ~univs:uctx term in - let cdecl = (Declare.DefinitionEntry entry, kind) in - let kn = Declare.declare_constant id cdecl in - Declare.definition_message id; - Declare.declare_univ_binders (ConstRef kn) (Evd.universe_binders sigma); - instance_hook info global imps ?hook (ConstRef kn) + let kn = Declare.declare_constant ~name ~kind (Declare.DefinitionEntry entry) in + Declare.definition_message name; + Declare.declare_univ_binders (GlobRef.ConstRef kn) (Evd.universe_binders sigma); + instance_hook info global imps ?hook (GlobRef.ConstRef kn) -let do_declare_instance sigma ~global ~poly k u ctx ctx' pri decl imps subst id = +let do_declare_instance sigma ~global ~poly k u ctx ctx' pri decl imps subst name = let subst = List.fold_left2 (fun subst' s decl -> if is_local_assum decl then s :: subst' else subst') [] subst (snd k.cl_context) @@ -337,19 +338,19 @@ let do_declare_instance sigma ~global ~poly k u ctx ctx' pri decl imps subst id let (_, ty_constr) = instance_constructor (k,u) subst in let termtype = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in let sigma, entry = DeclareDef.prepare_parameter ~allow_evars:false ~poly sigma decl termtype in - let cst = Declare.declare_constant id - (Declare.ParameterEntry entry, Decl_kinds.IsAssumption Decl_kinds.Logical) in - Declare.declare_univ_binders (ConstRef cst) (Evd.universe_binders sigma); - instance_hook pri global imps (ConstRef cst) + let cst = Declare.declare_constant ~name + ~kind:Decls.(IsAssumption Logical) (Declare.ParameterEntry entry) in + Declare.declare_univ_binders (GlobRef.ConstRef cst) (Evd.universe_binders sigma); + instance_hook pri global imps (GlobRef.ConstRef cst) let declare_instance_program env sigma ~global ~poly id pri imps decl term termtype = let hook { DeclareDef.Hook.S.scope; dref; _ } = - let cst = match dref with ConstRef kn -> kn | _ -> assert false in + let cst = match dref with GlobRef.ConstRef kn -> kn | _ -> assert false in Impargs.declare_manual_implicits false dref imps; let pri = intern_info pri in let env = Global.env () in let sigma = Evd.from_env env in - declare_instance env sigma (Some pri) (not global) (ConstRef cst) + declare_instance env sigma (Some pri) (not global) (GlobRef.ConstRef cst) in let obls, constr, typ = match term with @@ -363,7 +364,7 @@ let declare_instance_program env sigma ~global ~poly id pri imps decl term termt let hook = DeclareDef.Hook.make hook in let ctx = Evd.evar_universe_context sigma in ignore(Obligations.add_definition ~name:id ?term:constr - ~univdecl:decl ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) ~poly ~kind:Instance ~hook typ ctx obls) + ~univdecl:decl ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) ~poly ~kind:Decls.Instance ~hook typ ctx obls) let declare_instance_open sigma ?hook ~tac ~global ~poly id pri imps udecl ids term termtype = (* spiwack: it is hard to reorder the actions to do @@ -373,7 +374,7 @@ let declare_instance_open sigma ?hook ~tac ~global ~poly id pri imps udecl ids t let gls = List.rev (Evd.future_goals sigma) in let sigma = Evd.reset_future_goals sigma in let scope = DeclareDef.Global Declare.ImportDefaultBehavior in - let kind = Decl_kinds.DefinitionBody Decl_kinds.Instance in + let kind = Decls.(IsDefinition Instance) in let hook = DeclareDef.Hook.(make (fun { S.dref ; _ } -> instance_hook pri global imps ?hook dref)) in let info = Lemmas.Info.make ~hook ~scope ~kind () in let lemma = Lemmas.start_lemma ~name:id ~poly ~udecl ~info sigma (EConstr.of_constr termtype) in @@ -441,7 +442,7 @@ let do_instance_type_ctx_instance props k env' ctx' sigma ~program_mode subst = let {CAst.loc;v=mid} = get_id loc_mid in List.iter (fun (n, _, x) -> if Name.equal n (Name mid) then - Option.iter (fun x -> Dumpglob.add_glob ?loc (ConstRef x)) x) k.cl_projs; + Option.iter (fun x -> Dumpglob.add_glob ?loc (GlobRef.ConstRef x)) x) k.cl_projs; c :: props, rest' with Not_found -> ((CAst.make @@ CHole (None(* Some Evar_kinds.GoalEvar *), Namegen.IntroAnonymous, None)) :: props), rest diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index e91d8b9d3e..d59d471d5f 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -14,11 +14,9 @@ open Vars open Declare open Names open Context -open Globnames open Constrexpr_ops open Constrintern open Impargs -open Decl_kinds open Pretyping open Entries @@ -36,14 +34,14 @@ let () = optread = (fun _ -> !axiom_into_instance); optwrite = (:=) axiom_into_instance; } -let should_axiom_into_instance = function +let should_axiom_into_instance = let open Decls in function | Context -> (* The typeclass behaviour of Variable and Context doesn't depend on section status *) true | Definitional | Logical | Conjectural -> !axiom_into_instance -let declare_assumption is_coe ~poly ~scope ~kind typ univs pl imps impl nl {CAst.v=ident} = +let declare_assumption is_coe ~poly ~scope ~kind typ univs pl imps impl nl {CAst.v=name} = let open DeclareDef in match scope with | Discharge -> @@ -51,10 +49,11 @@ match scope with | Monomorphic_entry univs -> univs | Polymorphic_entry (_, univs) -> Univ.ContextSet.of_context univs in - let decl = (Lib.cwd(), SectionLocalAssum {typ;univs;poly;impl}, IsAssumption kind) in - let _ = declare_variable ident decl in - let () = assumption_message ident in - let r = VarRef ident in + let kind = Decls.IsAssumption kind in + let decl = SectionLocalAssum {typ; univs; poly; impl} in + let () = declare_variable ~name ~kind decl in + let () = assumption_message name in + let r = GlobRef.VarRef name in let () = maybe_declare_manual_implicits true r imps in let env = Global.env () in let sigma = Evd.from_env env in @@ -69,12 +68,13 @@ match scope with | DefaultInline -> Some (Flags.get_inline_level()) | InlineAt i -> Some i in - let decl = (Declare.ParameterEntry (None,(typ,univs),inl), IsAssumption kind) in - let kn = declare_constant ident ~local decl in - let gr = ConstRef kn in + let kind = Decls.IsAssumption kind in + let decl = Declare.ParameterEntry (None,(typ,univs),inl) in + let kn = declare_constant ~name ~local ~kind decl in + let gr = GlobRef.ConstRef kn in let () = maybe_declare_manual_implicits false gr imps in let () = Declare.declare_univ_binders gr pl in - let () = assumption_message ident in + let () = assumption_message name in let env = Global.env () in let sigma = Evd.from_env env in let () = if do_instance then Classes.declare_instance env sigma None false gr in @@ -211,7 +211,8 @@ let do_primitive id prim typopt = prim_entry_content = prim; } in - let _kn = declare_constant id.CAst.v (PrimitiveEntry entry,IsPrimitive) in + let _kn : Names.Constant.t = + declare_constant ~name:id.CAst.v ~kind:Decls.IsPrimitive (PrimitiveEntry entry) in Flags.if_verbose Feedback.msg_info Pp.(Id.print id.CAst.v ++ str " is declared") let named_of_rel_context l = @@ -269,24 +270,25 @@ let context ~poly l = Monomorphic_entry Univ.ContextSet.empty end in - let fn status (id, b, t) = + let fn status (name, b, t) = let b, t = Option.map (EConstr.to_constr sigma) b, EConstr.to_constr sigma t in if Lib.is_modtype () && not (Lib.sections_are_opened ()) then (* Declare the universe context once *) + let kind = Decls.(IsAssumption Logical) in let decl = match b with | None -> - (Declare.ParameterEntry (None,(t,univs),None), IsAssumption Logical) + Declare.ParameterEntry (None,(t,univs),None) | Some b -> let entry = Declare.definition_entry ~univs ~types:t b in - (Declare.DefinitionEntry entry, IsAssumption Logical) + Declare.DefinitionEntry entry in - let cst = Declare.declare_constant id decl in + let cst = Declare.declare_constant ~name ~kind decl in let env = Global.env () in - Classes.declare_instance env sigma (Some Hints.empty_hint_info) true (ConstRef cst); + Classes.declare_instance env sigma (Some Hints.empty_hint_info) true (GlobRef.ConstRef cst); status else let test x = match x.CAst.v with - | Some (Name id',_) -> Id.equal id id' + | Some (Name id',_) -> Id.equal name id' | _ -> false in let impl = List.exists test impls in @@ -294,13 +296,13 @@ let context ~poly l = if Lib.sections_are_opened () then DeclareDef.Discharge else DeclareDef.Global ImportDefaultBehavior in let nstatus = match b with | None -> - pi3 (declare_assumption false ~scope ~poly ~kind:Context t univs UnivNames.empty_binders [] impl - Declaremods.NoInline (CAst.make id)) + pi3 (declare_assumption false ~scope ~poly ~kind:Decls.Context t univs UnivNames.empty_binders [] impl + Declaremods.NoInline (CAst.make name)) | Some b -> let entry = Declare.definition_entry ~univs ~types:t b in let _gr = DeclareDef.declare_definition - ~name:id ~scope:DeclareDef.Discharge - ~kind:Definition UnivNames.empty_binders entry [] in + ~name ~scope:DeclareDef.Discharge + ~kind:Decls.Definition UnivNames.empty_binders entry [] in Lib.sections_are_opened () || Lib.is_modtype_strict () in status && nstatus diff --git a/vernac/comAssumption.mli b/vernac/comAssumption.mli index 57b4aea9e3..028ed39656 100644 --- a/vernac/comAssumption.mli +++ b/vernac/comAssumption.mli @@ -11,7 +11,6 @@ open Names open Vernacexpr open Constrexpr -open Decl_kinds (** {6 Parameters/Assumptions} *) @@ -19,7 +18,7 @@ val do_assumptions : program_mode:bool -> poly:bool -> scope:DeclareDef.locality - -> kind:assumption_object_kind + -> kind:Decls.assumption_object_kind -> Declaremods.inline -> (ident_decl list * constr_expr) with_coercion list -> bool @@ -30,7 +29,7 @@ val declare_assumption : coercion_flag -> poly:bool -> scope:DeclareDef.locality - -> kind:assumption_object_kind + -> kind:Decls.assumption_object_kind -> Constr.types -> Entries.universes_entry -> UnivNames.universe_binders diff --git a/vernac/comDefinition.mli b/vernac/comDefinition.mli index 71926a9d23..db0c102e14 100644 --- a/vernac/comDefinition.mli +++ b/vernac/comDefinition.mli @@ -9,7 +9,6 @@ (************************************************************************) open Names -open Decl_kinds open Redexpr open Constrexpr @@ -21,7 +20,7 @@ val do_definition -> name:Id.t -> scope:DeclareDef.locality -> poly:bool - -> kind:definition_object_kind + -> kind:Decls.definition_object_kind -> universe_decl_expr option -> local_binder_expr list -> red_expr option diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index e3428d6afc..3f13d772ab 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -20,7 +20,6 @@ open Names open Constrexpr open Constrexpr_ops open Constrintern -open Decl_kinds open Pretyping open Evarutil open Evarconv @@ -257,8 +256,8 @@ let interp_fixpoint ~cofix l ntns = let declare_fixpoint_interactive_generic ?indexes ~scope ~poly ((fixnames,_fixrs,fixdefs,fixtypes),udecl,ctx,fiximps) ntns = let fix_kind, cofix, indexes = match indexes with - | Some indexes -> Fixpoint, false, indexes - | None -> CoFixpoint, true, [] + | Some indexes -> Decls.Fixpoint, false, indexes + | None -> Decls.CoFixpoint, true, [] in let thms = List.map3 (fun name t (ctx,impargs,_) -> @@ -269,7 +268,7 @@ let declare_fixpoint_interactive_generic ?indexes ~scope ~poly ((fixnames,_fixrs Some (List.map (Option.cata (EConstr.of_constr %> Tactics.exact_no_check) Tacticals.New.tclIDTAC) fixdefs) in let evd = Evd.from_ctx ctx in let lemma = - Lemmas.start_lemma_with_initialization ~poly ~scope ~kind:(DefinitionBody fix_kind) ~udecl + Lemmas.start_lemma_with_initialization ~poly ~scope ~kind:(Decls.IsDefinition fix_kind) ~udecl evd (Some(cofix,indexes,init_tac)) thms None in (* Declare notations *) List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns; @@ -278,8 +277,8 @@ let declare_fixpoint_interactive_generic ?indexes ~scope ~poly ((fixnames,_fixrs let declare_fixpoint_generic ?indexes ~scope ~poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximps) ntns = let indexes, cofix, fix_kind = match indexes with - | Some indexes -> indexes, false, Fixpoint - | None -> [], true, CoFixpoint + | Some indexes -> indexes, false, Decls.Fixpoint + | None -> [], true, Decls.CoFixpoint in (* We shortcut the proof process *) let fixdefs = List.map Option.get fixdefs in diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index 283e5ff50a..65db4401d9 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -18,7 +18,6 @@ open Environ open Declare open Names open Libnames -open Globnames open Nameops open Constrexpr open Constrexpr_ops @@ -349,7 +348,7 @@ let restrict_inductive_universes sigma ctx_params arities constructors = let uvars = List.fold_right (fun (_,ctypes,_) -> List.fold_right merge_universes_of_constr ctypes) constructors uvars in Evd.restrict_universe_context sigma uvars -let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) notations cum ~poly prv finite = +let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) notations ~cumulative ~poly ~private_ind finite = check_all_names_different indl; List.iter check_param paramsl; if not (List.is_empty uparamsl) && not (List.is_empty notations) @@ -453,24 +452,24 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not indimpls, List.map (fun impls -> userimpls @ impls) cimpls) indimpls constructors in - let variance = if poly && cum then Some (InferCumulativity.dummy_variance uctx) else None in + let variance = if poly && cumulative then Some (InferCumulativity.dummy_variance uctx) else None in (* Build the mutual inductive entry *) let mind_ent = { mind_entry_params = ctx_params; mind_entry_record = None; mind_entry_finite = finite; mind_entry_inds = entries; - mind_entry_private = if prv then Some false else None; + mind_entry_private = if private_ind then Some false else None; mind_entry_universes = uctx; mind_entry_variance = variance; } in - (if poly && cum then + (if poly && cumulative then InferCumulativity.infer_inductive env_ar mind_ent else mind_ent), Evd.universe_binders sigma, impls -let interp_mutual_inductive ~template udecl (paramsl,indl) notations cum ~poly prv finite = - interp_mutual_inductive_gen (Global.env()) ~template udecl ([],paramsl,indl) notations cum ~poly prv finite +let interp_mutual_inductive ~template udecl (paramsl,indl) notations ~cumulative ~poly ~private_ind finite = + interp_mutual_inductive_gen (Global.env()) ~template udecl ([],paramsl,indl) notations ~cumulative ~poly ~private_ind finite (* Very syntactical equality *) let eq_local_binders bl1 bl2 = @@ -522,7 +521,7 @@ let is_recursive mie = let warn_non_primitive_record = CWarnings.create ~name:"non-primitive-record" ~category:"record" (fun indsp -> - (hov 0 (str "The record " ++ Nametab.pr_global_env Id.Set.empty (IndRef indsp) ++ + (hov 0 (str "The record " ++ Nametab.pr_global_env Id.Set.empty (GlobRef.IndRef indsp) ++ strbrk" could not be defined as a primitive record"))) let declare_mutual_inductive_with_eliminations ?(primitive_expected=false) mie pl impls = @@ -540,15 +539,15 @@ let declare_mutual_inductive_with_eliminations ?(primitive_expected=false) mie p let (_, kn), prim = declare_mind mie in let mind = Global.mind_of_delta_kn kn in if primitive_expected && not prim then warn_non_primitive_record (mind,0); - Declare.declare_univ_binders (IndRef (mind,0)) pl; + Declare.declare_univ_binders (GlobRef.IndRef (mind,0)) pl; List.iteri (fun i (indimpls, constrimpls) -> let ind = (mind,i) in - let gr = IndRef ind in + let gr = GlobRef.IndRef ind in maybe_declare_manual_implicits false gr indimpls; List.iteri (fun j impls -> maybe_declare_manual_implicits false - (ConstructRef (ind, succ j)) impls) + (GlobRef.ConstructRef (ind, succ j)) impls) constrimpls) impls; Flags.if_verbose Feedback.msg_info (minductive_message names); @@ -564,11 +563,11 @@ type uniform_inductive_flag = | UniformParameters | NonUniformParameters -let do_mutual_inductive ~template udecl indl cum ~poly prv ~uniform finite = +let do_mutual_inductive ~template udecl indl ~cumulative ~poly ~private_ind ~uniform finite = let (params,indl),coes,ntns = extract_mutual_inductive_declaration_components indl in (* Interpret the types *) let indl = match uniform with UniformParameters -> (params, [], indl) | NonUniformParameters -> ([], params, indl) in - let mie,pl,impls = interp_mutual_inductive_gen (Global.env()) ~template udecl indl ntns cum ~poly prv finite in + let mie,pl,impls = interp_mutual_inductive_gen (Global.env()) ~template udecl indl ntns ~cumulative ~poly ~private_ind finite in (* Declare the mutual inductive block with its associated schemes *) ignore (declare_mutual_inductive_with_eliminations mie pl impls); (* Declare the possible notations of inductive types *) @@ -614,6 +613,6 @@ let make_cases ind = let n' = Namegen.next_name_away_with_default (Id.to_string Namegen.default_dependent_ident) n.Context.binder_name avoid in Id.to_string n' :: rename (Id.Set.add n' avoid) l in let al' = rename Id.Set.empty al in - let consref = ConstructRef (ith_constructor_of_inductive ind (i + 1)) in + let consref = GlobRef.ConstructRef (ith_constructor_of_inductive ind (i + 1)) in (Libnames.string_of_qualid (Nametab.shortest_qualid_of_global Id.Set.empty consref) :: al') :: l) mip.mind_nf_lc [] diff --git a/vernac/comInductive.mli b/vernac/comInductive.mli index 2d4cd7cac2..97f930c0a1 100644 --- a/vernac/comInductive.mli +++ b/vernac/comInductive.mli @@ -13,7 +13,6 @@ open Entries open Libnames open Vernacexpr open Constrexpr -open Decl_kinds (** {6 Inductive and coinductive types} *) @@ -23,11 +22,16 @@ type uniform_inductive_flag = | UniformParameters | NonUniformParameters -val do_mutual_inductive : - template:bool option -> universe_decl_expr option -> - (one_inductive_expr * decl_notation list) list -> cumulative_inductive_flag -> - poly:bool -> private_flag -> uniform:uniform_inductive_flag -> - Declarations.recursivity_kind -> unit +val do_mutual_inductive + : template:bool option + -> universe_decl_expr option + -> (one_inductive_expr * decl_notation list) list + -> cumulative:bool + -> poly:bool + -> private_ind:bool + -> uniform:uniform_inductive_flag + -> Declarations.recursivity_kind + -> unit (************************************************************************) (** Internal API *) @@ -71,12 +75,16 @@ val extract_mutual_inductive_declaration_components : structured_inductive_expr * (*coercions:*) qualid list * decl_notation list (** Typing mutual inductive definitions *) - -val interp_mutual_inductive : - template:bool option -> universe_decl_expr option -> structured_inductive_expr -> - decl_notation list -> cumulative_inductive_flag -> - poly:bool -> private_flag -> Declarations.recursivity_kind -> - mutual_inductive_entry * UnivNames.universe_binders * one_inductive_impls list +val interp_mutual_inductive + : template:bool option + -> universe_decl_expr option + -> structured_inductive_expr + -> decl_notation list + -> cumulative:bool + -> poly:bool + -> private_ind:bool + -> Declarations.recursivity_kind + -> mutual_inductive_entry * UnivNames.universe_binders * one_inductive_impls list (** Prepare a "match" template for a given inductive type. For each branch of the match, we list the constructor name diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index 3947bb1b14..0fd65ad9b4 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -17,12 +17,10 @@ open Vars open Declare open Names open Libnames -open Globnames open Nameops open Constrexpr open Constrexpr_ops open Constrintern -open Decl_kinds open Evarutil open Context.Rel.Declaration open ComFixpoint @@ -213,8 +211,8 @@ let build_wellfounded (recname,pl,bl,arityc,body) poly r measure notation = (*FIXME poly? *) let ce = definition_entry ~types:ty ~univs (EConstr.to_constr sigma body) in (* FIXME: include locality *) - let c = Declare.declare_constant recname (DefinitionEntry ce, IsDefinition Definition) in - let gr = ConstRef c in + let c = Declare.declare_constant ~name:recname ~kind:Decls.(IsDefinition Definition) (DefinitionEntry ce) in + let gr = GlobRef.ConstRef c in if Impargs.is_implicit_args () || not (List.is_empty impls) then Impargs.declare_manual_implicits false gr impls in @@ -288,8 +286,8 @@ let do_program_recursive ~scope ~poly fixkind fixl ntns = end in let ctx = Evd.evar_universe_context evd in let kind = match fixkind with - | DeclareObl.IsFixpoint _ -> Fixpoint - | DeclareObl.IsCoFixpoint -> CoFixpoint + | DeclareObl.IsFixpoint _ -> Decls.Fixpoint + | DeclareObl.IsCoFixpoint -> Decls.CoFixpoint in Obligations.add_mutual_definitions defs ~poly ~scope ~kind ~univdecl:pl ctx ntns fixkind diff --git a/vernac/declareDef.ml b/vernac/declareDef.ml index d229973936..5e4f2dcd34 100644 --- a/vernac/declareDef.ml +++ b/vernac/declareDef.ml @@ -8,9 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Decl_kinds open Declare -open Globnames open Impargs type locality = Discharge | Global of Declare.import_status @@ -49,11 +47,13 @@ let declare_definition ~name ~scope ~kind ?hook_data udecl ce imps = let fix_exn = Future.fix_exn_of ce.Proof_global.proof_entry_body in let gr = match scope with | Discharge -> - let _ = declare_variable name (Lib.cwd(), SectionLocalDef ce, IsDefinition kind) in - VarRef name + let () = + declare_variable ~name ~kind:Decls.(IsDefinition kind) (SectionLocalDef ce) + in + Names.GlobRef.VarRef name | Global local -> - let kn = declare_constant name ~local (DefinitionEntry ce, IsDefinition kind) in - let gr = ConstRef kn in + let kn = declare_constant ~name ~local ~kind:Decls.(IsDefinition kind) (DefinitionEntry ce) in + let gr = Names.GlobRef.ConstRef kn in let () = Declare.declare_univ_binders gr udecl in gr in diff --git a/vernac/declareDef.mli b/vernac/declareDef.mli index cfff89bc34..606cfade46 100644 --- a/vernac/declareDef.mli +++ b/vernac/declareDef.mli @@ -9,7 +9,6 @@ (************************************************************************) open Names -open Decl_kinds type locality = Discharge | Global of Declare.import_status @@ -43,7 +42,7 @@ end val declare_definition : name:Id.t -> scope:locality - -> kind:definition_object_kind + -> kind:Decls.definition_object_kind -> ?hook_data:(Hook.t * UState.t * (Id.t * Constr.t) list) -> UnivNames.universe_binders -> Evd.side_effects Proof_global.proof_entry @@ -55,7 +54,7 @@ val declare_fix -> ?hook_data:(Hook.t * UState.t * (Id.t * Constr.t) list) -> name:Id.t -> scope:locality - -> kind:definition_object_kind + -> kind:Decls.definition_object_kind -> UnivNames.universe_binders -> Entries.universes_entry -> Evd.side_effects Entries.proof_output diff --git a/vernac/declareObl.ml b/vernac/declareObl.ml index cd521255a0..0c45ff11d7 100644 --- a/vernac/declareObl.ml +++ b/vernac/declareObl.ml @@ -14,7 +14,6 @@ open Environ open Context open Constr open Vars -open Decl_kinds open Entries type 'a obligation_body = DefinedObl of 'a | TermObl of constr @@ -50,11 +49,11 @@ type program_info = ; prg_notations : notations ; prg_poly : bool ; prg_scope : DeclareDef.locality - ; prg_kind : definition_object_kind + ; prg_kind : Decls.definition_object_kind ; prg_reduce : constr -> constr ; prg_hook : DeclareDef.Hook.t option ; prg_opaque : bool - ; prg_sign : named_context_val } + } (* Saving an obligation *) @@ -167,8 +166,9 @@ let declare_obligation prg obl body ty uctx = in (* ppedrot: seems legit to have obligations as local *) let constant = - Declare.declare_constant obl.obl_name ~local:Declare.ImportNeedQualified - (Declare.DefinitionEntry ce, IsProof Property) + Declare.declare_constant ~name:obl.obl_name + ~local:Declare.ImportNeedQualified ~kind:Decls.(IsProof Property) + (Declare.DefinitionEntry ce) in if not opaque then add_hint (Locality.make_section_locality None) prg constant; @@ -423,7 +423,7 @@ let declare_mutual_definition l = let fixdecls = (Array.map2 make_annot namevec rvec, arrrec, recvec) in let fixnames = first.prg_deps in let opaque = first.prg_opaque in - let kind = if fixkind != IsCoFixpoint then Fixpoint else CoFixpoint in + let kind = if fixkind != IsCoFixpoint then Decls.Fixpoint else Decls.CoFixpoint in let indexes, fixdecls = match fixkind with | IsFixpoint wfl -> @@ -548,16 +548,11 @@ let obligation_terminator entries uctx { name; num; auto } = else ctx in let prg = {prg with prg_ctx} in - begin try - ignore (update_obls prg obls (pred rem)); - if pred rem > 0 then - let deps = dependencies obls num in - if not (Int.Set.is_empty deps) then - ignore (auto (Some name) deps None) - with e when CErrors.noncritical e -> - let e = CErrors.push e in - pperror (CErrors.iprint (ExplainErr.process_vernac_interp_error e)) - end + ignore (update_obls prg obls (pred rem)); + if pred rem > 0 then + let deps = dependencies obls num in + if not (Int.Set.is_empty deps) then + ignore (auto (Some name) deps None) | _ -> CErrors.anomaly Pp.( diff --git a/vernac/declareObl.mli b/vernac/declareObl.mli index fae27e1cb3..a8dd5040cb 100644 --- a/vernac/declareObl.mli +++ b/vernac/declareObl.mli @@ -44,11 +44,11 @@ type program_info = ; prg_notations : notations ; prg_poly : bool ; prg_scope : DeclareDef.locality - ; prg_kind : Decl_kinds.definition_object_kind + ; prg_kind : Decls.definition_object_kind ; prg_reduce : constr -> constr ; prg_hook : DeclareDef.Hook.t option ; prg_opaque : bool - ; prg_sign : Environ.named_context_val } + } val declare_obligation : program_info diff --git a/vernac/explainErr.ml b/vernac/explainErr.ml deleted file mode 100644 index 5c5a4ffbcb..0000000000 --- a/vernac/explainErr.ml +++ /dev/null @@ -1,125 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -open Pp -open CErrors -open Type_errors -open Pretype_errors -open Indrec - -let guill s = str "\"" ++ str s ++ str "\"" - -(** Invariant : exceptions embedded in EvaluatedError satisfy - Errors.noncritical *) - -exception EvaluatedError of Pp.t * exn option - -(** Registration of generic errors - Nota: explain_exn does NOT end with a newline anymore! -*) - -let explain_exn_default = function - (* Basic interaction exceptions *) - | Stream.Error txt -> hov 0 (str "Syntax error: " ++ str txt ++ str ".") - | CLexer.Error.E err -> hov 0 (str (CLexer.Error.to_string err)) - | Sys_error msg -> hov 0 (str "System error: " ++ guill msg) - | Out_of_memory -> hov 0 (str "Out of memory.") - | Stack_overflow -> hov 0 (str "Stack overflow.") - | Dynlink.Error e -> hov 0 (str "Dynlink error: " ++ str Dynlink.(error_message e)) - | Timeout -> hov 0 (str "Timeout!") - | Sys.Break -> hov 0 (fnl () ++ str "User interrupt.") - (* Exceptions with pre-evaluated error messages *) - | EvaluatedError (msg,None) -> msg - | EvaluatedError (msg,Some reraise) -> msg ++ CErrors.print reraise - (* Otherwise, not handled here *) - | _ -> raise CErrors.Unhandled - -let _ = CErrors.register_handler explain_exn_default - - -let vernac_interp_error_handler = function - | Univ.UniverseInconsistency i -> - let msg = - if !Constrextern.print_universes then - str "." ++ spc() ++ - Univ.explain_universe_inconsistency UnivNames.pr_with_global_universes i - else - mt() in - str "Universe inconsistency" ++ msg ++ str "." - | TypeError(ctx,te) -> - let te = map_ptype_error EConstr.of_constr te in - Himsg.explain_type_error ctx Evd.empty te - | PretypeError(ctx,sigma,te) -> - Himsg.explain_pretype_error ctx sigma te - | Notation.PrimTokenNotationError(kind,ctx,sigma,te) -> - Himsg.explain_prim_token_notation_error kind ctx sigma te - | Typeclasses_errors.TypeClassError(env, sigma, te) -> - Himsg.explain_typeclass_error env sigma te - | InductiveError e -> - Himsg.explain_inductive_error e - | Modops.ModuleTypingError e -> - Himsg.explain_module_error e - | Modintern.ModuleInternalizationError e -> - Himsg.explain_module_internalization_error e - | RecursionSchemeError (env,e) -> - Himsg.explain_recursion_scheme_error env e - | Cases.PatternMatchingError (env,sigma,e) -> - Himsg.explain_pattern_matching_error env sigma e - | Tacred.ReductionTacticError e -> - Himsg.explain_reduction_tactic_error e - | Logic.RefinerError (env, sigma, e) -> - Himsg.explain_refiner_error env sigma e - | Nametab.GlobalizationError q -> - str "The reference" ++ spc () ++ Libnames.pr_qualid q ++ - spc () ++ str "was not found" ++ - spc () ++ str "in the current" ++ spc () ++ str "environment." - | Refiner.FailError (i,s) -> - let s = Lazy.force s in - str "Tactic failure" ++ - (if Pp.ismt s then s else str ": " ++ s) ++ - if Int.equal i 0 then str "." else str " (level " ++ int i ++ str")." - | AlreadyDeclared msg -> - msg ++ str "." - | _ -> - raise CErrors.Unhandled - -let _ = CErrors.register_handler vernac_interp_error_handler - -(** Pre-explain a vernac interpretation error *) - -let wrap_vernac_error (exn, info) strm = (EvaluatedError (strm, None), info) - -let process_vernac_interp_error exn = - try vernac_interp_error_handler (fst exn) |> wrap_vernac_error exn - with CErrors.Unhandled -> exn - -let rec strip_wrapping_exceptions = function - | Logic_monad.TacticFailure e -> - strip_wrapping_exceptions e - | exc -> exc - -let additional_error_info = ref [] - -let register_additional_error_info f = - additional_error_info := f :: !additional_error_info - -let process_vernac_interp_error (exc, info) = - let exc = strip_wrapping_exceptions exc in - let e = process_vernac_interp_error (exc, info) in - let e' = - try Some (CList.find_map (fun f -> f e) !additional_error_info) - with _ -> None - in - let add_loc_opt ?loc info = Option.cata (fun l -> Loc.add_loc info l) info loc in - match e' with - | None -> e - | Some (loc, None) -> (fst e, add_loc_opt ?loc (snd e)) - | Some (loc, Some msg) -> - (EvaluatedError (msg, Some (fst e)), add_loc_opt ?loc (snd e)) diff --git a/vernac/explainErr.mli b/vernac/explainErr.mli deleted file mode 100644 index cc2a130925..0000000000 --- a/vernac/explainErr.mli +++ /dev/null @@ -1,23 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(** Toplevel Exception *) -exception EvaluatedError of Pp.t * exn option - -(** Pre-explain a vernac interpretation error *) - -val process_vernac_interp_error : Util.iexn -> Util.iexn - -(** General explain function. Should not be used directly now, - see instead function [Errors.print] and variants *) - -val explain_exn_default : exn -> Pp.t - -val register_additional_error_info : (Util.iexn -> (Pp.t option Loc.located) option) -> unit diff --git a/vernac/g_proofs.mlg b/vernac/g_proofs.mlg index 94876d2142..5cffa18511 100644 --- a/vernac/g_proofs.mlg +++ b/vernac/g_proofs.mlg @@ -55,7 +55,7 @@ GRAMMAR EXTEND Gram ; command: [ [ IDENT "Goal"; c = lconstr -> - { VernacDefinition (Decl_kinds.(NoDischarge, Definition), ((CAst.make ~loc Names.Anonymous), None), ProveBody ([], c)) } + { VernacDefinition (Decls.(NoDischarge, Definition), ((CAst.make ~loc Names.Anonymous), None), ProveBody ([], c)) } | IDENT "Proof" -> { VernacProof (None,None) } | IDENT "Proof" ; IDENT "Mode" ; mn = string -> { VernacProofMode mn } | IDENT "Proof"; c = lconstr -> { VernacExactProof c } diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 74bd552459..2b475f1ef9 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -20,7 +20,7 @@ open Impargs open Constrexpr open Constrexpr_ops open Extend -open Decl_kinds +open Decls open Declaremods open Declarations open Namegen diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 2e218942cb..ea34b601e8 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -1353,3 +1353,70 @@ let explain_prim_token_notation_error kind env sigma = function (strbrk "Unexpected non-option term " ++ pr_constr_env env sigma c ++ strbrk (" while parsing a "^kind^" notation.")) + +(** Registration of generic errors + Nota: explain_exn does NOT end with a newline anymore! +*) + +let explain_exn_default = function + (* Basic interaction exceptions *) + | Stream.Error txt -> hov 0 (str "Syntax error: " ++ str txt ++ str ".") + | CLexer.Error.E err -> hov 0 (str (CLexer.Error.to_string err)) + | Sys_error msg -> hov 0 (str "System error: " ++ quote (str msg)) + | Out_of_memory -> hov 0 (str "Out of memory.") + | Stack_overflow -> hov 0 (str "Stack overflow.") + | Dynlink.Error e -> hov 0 (str "Dynlink error: " ++ str Dynlink.(error_message e)) + | CErrors.Timeout -> hov 0 (str "Timeout!") + | Sys.Break -> hov 0 (fnl () ++ str "User interrupt.") + (* Otherwise, not handled here *) + | _ -> raise CErrors.Unhandled + +let _ = CErrors.register_handler explain_exn_default + +let rec vernac_interp_error_handler = function + | Univ.UniverseInconsistency i -> + let msg = + if !Constrextern.print_universes then + str "." ++ spc() ++ + Univ.explain_universe_inconsistency UnivNames.pr_with_global_universes i + else + mt() in + str "Universe inconsistency" ++ msg ++ str "." + | TypeError(ctx,te) -> + let te = map_ptype_error EConstr.of_constr te in + explain_type_error ctx Evd.empty te + | PretypeError(ctx,sigma,te) -> + explain_pretype_error ctx sigma te + | Notation.PrimTokenNotationError(kind,ctx,sigma,te) -> + explain_prim_token_notation_error kind ctx sigma te + | Typeclasses_errors.TypeClassError(env, sigma, te) -> + explain_typeclass_error env sigma te + | InductiveError e -> + explain_inductive_error e + | Modops.ModuleTypingError e -> + explain_module_error e + | Modintern.ModuleInternalizationError e -> + explain_module_internalization_error e + | RecursionSchemeError (env,e) -> + explain_recursion_scheme_error env e + | Cases.PatternMatchingError (env,sigma,e) -> + explain_pattern_matching_error env sigma e + | Tacred.ReductionTacticError e -> + explain_reduction_tactic_error e + | Logic.RefinerError (env, sigma, e) -> + explain_refiner_error env sigma e + | Nametab.GlobalizationError q -> + str "The reference" ++ spc () ++ Libnames.pr_qualid q ++ + spc () ++ str "was not found" ++ + spc () ++ str "in the current" ++ spc () ++ str "environment." + | Refiner.FailError (i,s) -> + let s = Lazy.force s in + str "Tactic failure" ++ + (if Pp.ismt s then s else str ": " ++ s) ++ + if Int.equal i 0 then str "." else str " (level " ++ int i ++ str")." + | Logic_monad.TacticFailure e -> + vernac_interp_error_handler e + | _ -> + raise CErrors.Unhandled + +let _ = CErrors.register_handler vernac_interp_error_handler diff --git a/vernac/himsg.mli b/vernac/himsg.mli index 6458fb9e30..9de5284393 100644 --- a/vernac/himsg.mli +++ b/vernac/himsg.mli @@ -8,37 +8,11 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Environ -open Type_errors -open Pretype_errors -open Typeclasses_errors -open Indrec -open Cases -open Logic - (** This module provides functions to explain the type errors. *) -val explain_type_error : env -> Evd.evar_map -> type_error -> Pp.t - -val explain_pretype_error : env -> Evd.evar_map -> pretype_error -> Pp.t - -val explain_inductive_error : inductive_error -> Pp.t - -val explain_typeclass_error : env -> Evd.evar_map -> typeclass_error -> Pp.t - -val explain_recursion_scheme_error : env -> recursion_scheme_error -> Pp.t - -val explain_refiner_error : env -> Evd.evar_map -> refiner_error -> Pp.t - -val explain_pattern_matching_error : - env -> Evd.evar_map -> pattern_matching_error -> Pp.t - -val explain_reduction_tactic_error : - Tacred.reduction_tactic_error -> Pp.t - -val explain_module_error : Modops.module_typing_error -> Pp.t +(* Used by equations *) +val explain_type_error : Environ.env -> Evd.evar_map -> Pretype_errors.type_error -> Pp.t -val explain_module_internalization_error : - Modintern.module_internalization_error -> Pp.t +val explain_pretype_error : Environ.env -> Evd.evar_map -> Pretype_errors.pretype_error -> Pp.t -val explain_prim_token_notation_error : string -> env -> Evd.evar_map -> Notation.prim_token_notation_error -> Pp.t +val explain_refiner_error : Environ.env -> Evd.evar_map -> Logic.refiner_error -> Pp.t diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index 9559edbea0..23a8bf20a3 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -24,11 +24,9 @@ open Declarations open Term open Constr open Inductive -open Decl_kinds open Indrec open Declare open Libnames -open Globnames open Goptions open Nameops open Termops @@ -100,11 +98,11 @@ let () = (* Util *) -let define ~poly id sigma c t = - let f = declare_constant in +let define ~poly name sigma c t = + let f = declare_constant ~kind:Decls.(IsDefinition Scheme) in let univs = Evd.univ_entry ~poly sigma in let open Proof_global in - let kn = f id + let kn = f ~name (DefinitionEntry { proof_entry_body = c; proof_entry_secctx = None; @@ -113,9 +111,8 @@ let define ~poly id sigma c t = proof_entry_opaque = false; proof_entry_inline_code = false; proof_entry_feedback = None; - }, - Decl_kinds.IsDefinition Scheme) in - definition_message id; + }) in + definition_message name; kn (* Boolean equality *) @@ -161,8 +158,9 @@ let try_declare_scheme what f internal names kn = | UndefinedCst s -> alarm what internal (strbrk "Required constant " ++ str s ++ str " undefined.") - | AlreadyDeclared msg -> - alarm what internal (msg ++ str ".") + | AlreadyDeclared (kind, id) as exn -> + let msg = CErrors.print exn in + alarm what internal msg | DecidabilityMutualNotSupported -> alarm what internal (str "Decidability lemma for mutual inductive types not supported.") @@ -377,7 +375,7 @@ requested | InSet -> recs ^ "_nodep" | InType -> recs ^ "t_nodep") ) in - let newid = add_suffix (Nametab.basename_of_global (IndRef ind)) suffix in + let newid = add_suffix (Nametab.basename_of_global (GlobRef.IndRef ind)) suffix in let newref = CAst.make newid in ((newref,isdep,ind,z)::l1),l2 in @@ -395,7 +393,7 @@ let do_mutual_induction_scheme ?(force_mutual=false) lnamedepindsort = let evd, indu, inst = match inst with | None -> - let _, ctx = Typeops.type_of_global_in_context env0 (IndRef ind) in + let _, ctx = Typeops.type_of_global_in_context env0 (GlobRef.IndRef ind) in let u, ctx = UnivGen.fresh_instance_from ctx None in let evd = Evd.from_ctx (UState.of_context_set ctx) in evd, (ind,u), Some u @@ -409,14 +407,14 @@ let do_mutual_induction_scheme ?(force_mutual=false) lnamedepindsort = (* NB: build_mutual_induction_scheme forces nonempty list of mutual inductives (force_mutual is about the generated schemes) *) let _,_,ind,_ = List.hd lnamedepindsort in - Global.is_polymorphic (IndRef ind) + Global.is_polymorphic (GlobRef.IndRef ind) in let declare decl fi lrecref = let decltype = Retyping.get_type_of env0 sigma (EConstr.of_constr decl) in let decltype = EConstr.to_constr sigma decltype in let proof_output = Future.from_val ((decl,Univ.ContextSet.empty),Evd.empty_side_effects) in let cst = define ~poly fi sigma proof_output (Some decltype) in - ConstRef cst :: lrecref + GlobRef.ConstRef cst :: lrecref in let _ = List.fold_right2 declare listdecl lrecnames [] in fixpoint_message None lrecnames @@ -543,7 +541,7 @@ let do_combined_scheme name schemes = polymorphism of the inductive block). In that case if they want some other polymorphism they can also manually define the combined scheme. *) - let poly = Global.is_polymorphic (ConstRef (List.hd csts)) in + let poly = Global.is_polymorphic (GlobRef.ConstRef (List.hd csts)) in ignore (define ~poly name.v sigma proof_output (Some typ)); fixpoint_message None [name.v] diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index e586200ba3..ecea9ae4c9 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -16,14 +16,9 @@ open Util open Pp open Names open Constr -open Declarations open Declareops open Entries open Nameops -open Globnames -open Decls -open Decl_kinds -open Declare open Pretyping open Termops open Reductionops @@ -75,10 +70,11 @@ module Info = struct (* This could be improved and the CEphemeron removed *) ; other_thms : Recthm.t list ; scope : DeclareDef.locality - ; kind : Decl_kinds.goal_object_kind + ; kind : Decls.logical_kind } - let make ?hook ?(proof_ending=Proof_ending.Regular) ?(scope=DeclareDef.Global Declare.ImportDefaultBehavior) ?(kind=Proof Lemma) () = + let make ?hook ?(proof_ending=Proof_ending.Regular) ?(scope=DeclareDef.Global Declare.ImportDefaultBehavior) + ?(kind=Decls.(IsProof Lemma)) () = { hook ; compute_guard = [] ; impargs = [] @@ -120,15 +116,16 @@ let by tac pf = (* Support for mutually proved theorems *) let retrieve_first_recthm uctx = function - | VarRef id -> - (NamedDecl.get_value (Global.lookup_named id),variable_opacity id) - | ConstRef cst -> - let cb = Global.lookup_constant cst in - (* we get the right order somehow but surely it could be enforced in a better way *) - let uctx = UState.context uctx in - let inst = Univ.UContext.instance uctx in - let map (c, _, _) = Vars.subst_instance_constr inst c in - (Option.map map (Global.body_of_constant_body Library.indirect_accessor cb), is_opaque cb) + | GlobRef.VarRef id -> + NamedDecl.get_value (Global.lookup_named id), + Decls.variable_opacity id + | GlobRef.ConstRef cst -> + let cb = Global.lookup_constant cst in + (* we get the right order somehow but surely it could be enforced in a better way *) + let uctx = UState.context uctx in + let inst = Univ.UContext.instance uctx in + let map (c, _, _) = Vars.subst_instance_constr inst c in + (Option.map map (Global.body_of_constant_body Library.indirect_accessor cb), is_opaque cb) | _ -> assert false let adjust_guardness_conditions const = function @@ -154,93 +151,6 @@ let adjust_guardness_conditions const = function (mkFix ((indexes,0),fixdecls), ctx), eff | _ -> (body, ctx), eff) } -let find_mutually_recursive_statements sigma thms = - let n = List.length thms in - let inds = List.map (fun (id,(t,impls)) -> - let (hyps,ccl) = EConstr.decompose_prod_assum sigma t in - let x = (id,(t,impls)) in - let whnf_hyp_hds = EConstr.map_rel_context_in_env - (fun env c -> fst (Reductionops.whd_all_stack env sigma c)) - (Global.env()) hyps in - let ind_hyps = - List.flatten (List.map_i (fun i decl -> - let t = RelDecl.get_type decl in - match EConstr.kind sigma t with - | Ind ((kn,_ as ind),u) when - let mind = Global.lookup_mind kn in - mind.mind_finite <> Declarations.CoFinite -> - [ind,x,i] - | _ -> - []) 0 (List.rev (List.filter Context.Rel.Declaration.is_local_assum whnf_hyp_hds))) in - let ind_ccl = - let cclenv = EConstr.push_rel_context hyps (Global.env()) in - let whnf_ccl,_ = whd_all_stack cclenv Evd.empty ccl in - match EConstr.kind sigma whnf_ccl with - | Ind ((kn,_ as ind),u) when - let mind = Global.lookup_mind kn in - Int.equal mind.mind_ntypes n && mind.mind_finite == Declarations.CoFinite -> - [ind,x,0] - | _ -> - [] in - ind_hyps,ind_ccl) thms in - let inds_hyps,ind_ccls = List.split inds in - let of_same_mutind ((kn,_),_,_) = function ((kn',_),_,_) -> MutInd.equal kn kn' in - (* Check if all conclusions are coinductive in the same type *) - (* (degenerated cartesian product since there is at most one coind ccl) *) - let same_indccl = - List.cartesians_filter (fun hyp oks -> - if List.for_all (of_same_mutind hyp) oks - then Some (hyp::oks) else None) [] ind_ccls in - let ordered_same_indccl = - List.filter (List.for_all_i (fun i ((kn,j),_,_) -> Int.equal i j) 0) same_indccl in - (* Check if some hypotheses are inductive in the same type *) - let common_same_indhyp = - List.cartesians_filter (fun hyp oks -> - if List.for_all (of_same_mutind hyp) oks - then Some (hyp::oks) else None) [] inds_hyps in - let ordered_inds,finite,guard = - match ordered_same_indccl, common_same_indhyp with - | indccl::rest, _ -> - assert (List.is_empty rest); - (* One occ. of common coind ccls and no common inductive hyps *) - if not (List.is_empty common_same_indhyp) then - Flags.if_verbose Feedback.msg_info (str "Assuming mutual coinductive statements."); - flush_all (); - indccl, true, [] - | [], _::_ -> - let () = match same_indccl with - | ind :: _ -> - if List.distinct_f ind_ord (List.map pi1 ind) - then - Flags.if_verbose Feedback.msg_info - (strbrk - ("Coinductive statements do not follow the order of "^ - "definition, assuming the proof to be by induction.")); - flush_all () - | _ -> () - in - let possible_guards = List.map (List.map pi3) inds_hyps in - (* assume the largest indices as possible *) - List.last common_same_indhyp, false, possible_guards - | _, [] -> - user_err Pp.(str - ("Cannot find common (mutual) inductive premises or coinductive" ^ - " conclusions in the statements.")) - in - (finite,guard,None), ordered_inds - -let look_for_possibly_mutual_statements sigma = function - | [id,(t,impls)] -> - (* One non recursively proved theorem *) - None,[id,(t,impls)],None - | _::_ as thms -> - (* More than one statement and/or an explicit decreasing mark: *) - (* we look for a common inductive hyp or a common coinductive conclusion *) - let recguard,ordered_inds = find_mutually_recursive_statements sigma thms in - let thms = List.map pi2 ordered_inds in - Some recguard,thms, Some (List.map (fun (_,_,i) -> succ i) ordered_inds) - | [] -> anomaly (Pp.str "Empty list of theorems.") - let default_thm_id = Id.of_string "Unnamed_thm" let check_name_freshness locality {CAst.loc;v=id} : unit = @@ -250,30 +160,29 @@ let check_name_freshness locality {CAst.loc;v=id} : unit = then user_err ?loc (Id.print id ++ str " already exists.") -let save_remaining_recthms env sigma ~poly ~scope norm univs body opaq i - { Recthm.name; typ; impargs } = +let save_remaining_recthms env sigma ~poly ~scope norm univs body opaq i { Recthm.name; typ; impargs } = let t_i = norm typ in - let k = IsAssumption Conjectural in + let kind = Decls.(IsAssumption Conjectural) in match body with | None -> let open DeclareDef in (match scope with | Discharge -> - let impl = false in (* copy values from Vernacentries *) - let univs = match univs with - | Polymorphic_entry (_, univs) -> - (* What is going on here? *) - Univ.ContextSet.of_context univs - | Monomorphic_entry univs -> univs - in - let c = SectionLocalAssum {typ=t_i;univs;poly;impl} in - let _ = declare_variable name (Lib.cwd(),c,k) in - (VarRef name,impargs) + let impl = false in (* copy values from Vernacentries *) + let univs = match univs with + | Polymorphic_entry (_, univs) -> + (* What is going on here? *) + Univ.ContextSet.of_context univs + | Monomorphic_entry univs -> univs + in + let c = Declare.SectionLocalAssum {typ=t_i; univs; poly; impl} in + let () = Declare.declare_variable ~name ~kind c in + (GlobRef.VarRef name,impargs) | Global local -> - let k = IsAssumption Conjectural in - let decl = (ParameterEntry (None,(t_i,univs),None), k) in - let kn = declare_constant name ~local decl in - (ConstRef kn,impargs)) + let kind = Decls.(IsAssumption Conjectural) in + let decl = Declare.ParameterEntry (None,(t_i,univs),None) in + let kn = Declare.declare_constant ~name ~local ~kind decl in + (GlobRef.ConstRef kn,impargs)) | Some body -> let body = norm body in let rec body_i t = match Constr.kind t with @@ -288,31 +197,31 @@ let save_remaining_recthms env sigma ~poly ~scope norm univs body opaq i let open DeclareDef in match scope with | Discharge -> - let const = definition_entry ~types:t_i ~opaque:opaq ~univs body_i in - let c = SectionLocalDef const in - let _ = declare_variable name (Lib.cwd(), c, k) in - (VarRef name,impargs) + let const = Declare.definition_entry ~types:t_i ~opaque:opaq ~univs body_i in + let c = Declare.SectionLocalDef const in + let () = Declare.declare_variable ~name ~kind c in + (GlobRef.VarRef name,impargs) | Global local -> - let const = - Declare.definition_entry ~types:t_i ~univs ~opaque:opaq body_i - in - let kn = declare_constant name ~local (DefinitionEntry const, k) in - (ConstRef kn,impargs) + let const = Declare.definition_entry ~types:t_i ~univs ~opaque:opaq body_i in + let kn = Declare.declare_constant ~name ~local ~kind (Declare.DefinitionEntry const) in + (GlobRef.ConstRef kn,impargs) let initialize_named_context_for_proof () = let sign = Global.named_context () in List.fold_right (fun d signv -> let id = NamedDecl.get_id d in - let d = if variable_opacity id then NamedDecl.drop_body d else d in + let d = if Decls.variable_opacity id then NamedDecl.drop_body d else d in Environ.push_named_context_val d signv) sign Environ.empty_named_context_val (* Starting a goal *) let start_lemma ~name ~poly ?(udecl=UState.default_univ_decl) - ?(sign=initialize_named_context_for_proof()) ?(info=Info.make ()) sigma c = + (* We remove the bodies of variables in the named context marked + "opaque", this is a hack tho, see #10446 *) + let sign = initialize_named_context_for_proof () in let goals = [ Global.env_of_context sign , c ] in let proof = Proof_global.start_proof sigma ~name ~udecl ~poly goals in { proof ; info } @@ -387,7 +296,7 @@ let start_lemma_com ~program_mode ~poly ~scope ~kind ?inference_hook ?hook thms (Evarutil.nf_evar evd (EConstr.it_mkProd_or_LetIn t' ctx), (ids, imps @ imps')))) evd thms in - let recguard,thms,snl = look_for_possibly_mutual_statements evd thms in + let recguard,thms,snl = RecLemmas.look_for_possibly_mutual_statements evd thms in let evd = Evd.minimize_universes evd in (* XXX: This nf_evar is critical too!! We are normalizing twice if you look at the previous lines... *) @@ -406,19 +315,9 @@ let start_lemma_com ~program_mode ~poly ~scope ~kind ?inference_hook ?hook thms start_lemma_with_initialization ?hook ~poly ~scope ~kind evd ~udecl recguard thms snl (************************************************************************) -(* Admitting a lemma-like constant *) +(* Commom constant saving path *) (************************************************************************) -let check_anonymity id save_ident = - if not (String.equal (atompart_of_id id) (Id.to_string (default_thm_id))) then - user_err Pp.(str "This command can only be used for unnamed theorem.") - -(* Admitted *) -let warn_let_as_axiom = - CWarnings.create ~name:"let-as-axiom" ~category:"vernacular" - (fun id -> strbrk "Let definition" ++ spc () ++ Id.print id ++ - spc () ++ strbrk "declared as an axiom.") - (* This declares implicits and calls the hooks for all the theorems, including the main one *) let process_recthms ?fix_exn ?hook env sigma uctx ~udecl ~poly ~scope dref imps other_thms = @@ -435,6 +334,16 @@ let process_recthms ?fix_exn ?hook env sigma uctx ~udecl ~poly ~scope dref imps maybe_declare_manual_implicits false dref imps; DeclareDef.Hook.(call ?fix_exn ?hook { S.uctx; obls = []; scope; dref})) thms_data +(************************************************************************) +(* Admitting a lemma-like constant *) +(************************************************************************) + +(* Admitted *) +let warn_let_as_axiom = + CWarnings.create ~name:"let-as-axiom" ~category:"vernacular" + (fun id -> strbrk "Let definition" ++ spc () ++ Id.print id ++ + spc () ++ strbrk "declared as an axiom.") + let get_keep_admitted_vars = Goptions.declare_bool_option_and_ref ~depr:false @@ -446,13 +355,13 @@ let finish_admitted env sigma ~name ~poly ~scope pe ctx hook ~udecl impargs othe let open DeclareDef in let local = match scope with | Global local -> local - | Discharge -> warn_let_as_axiom name; ImportNeedQualified + | Discharge -> warn_let_as_axiom name; Declare.ImportNeedQualified in - let kn = declare_constant name ~local (ParameterEntry pe, IsAssumption Conjectural) in - let () = assumption_message name in - Declare.declare_univ_binders (ConstRef kn) (UState.universe_binders ctx); + let kn = Declare.declare_constant ~name ~local ~kind:Decls.(IsAssumption Conjectural) (Declare.ParameterEntry pe) in + let () = Declare.assumption_message name in + Declare.declare_univ_binders (GlobRef.ConstRef kn) (UState.universe_binders ctx); (* This takes care of the implicits and hook for the current constant*) - process_recthms ?fix_exn:None ?hook env sigma ctx ~udecl ~poly ~scope:(Global local) (ConstRef kn) impargs other_thms; + process_recthms ?fix_exn:None ?hook env sigma ctx ~udecl ~poly ~scope:(Global local) (GlobRef.ConstRef kn) impargs other_thms; Feedback.feedback Feedback.AddedAxiom let save_lemma_admitted ~(lemma : t) : unit = @@ -486,6 +395,10 @@ let save_lemma_admitted ~(lemma : t) : unit = (* Saving a lemma-like constant *) (************************************************************************) +let check_anonymity id save_ident = + if not (String.equal (atompart_of_id id) (Id.to_string (default_thm_id))) then + user_err Pp.(str "This command can only be used for unnamed theorem.") + let finish_proved env sigma idopt po info = let open Proof_global in let { Info.hook; compute_guard; impargs; other_thms; scope; kind } = info in @@ -497,28 +410,27 @@ let finish_proved env sigma idopt po info = let fix_exn = Future.fix_exn_of const.proof_entry_body in let () = try let const = adjust_guardness_conditions const compute_guard in - let k = Kindops.logical_kind_of_goal_kind kind in let should_suggest = const.proof_entry_opaque && Option.is_empty const.proof_entry_secctx in let open DeclareDef in let r = match scope with | Discharge -> - let c = SectionLocalDef const in - let _ = declare_variable name (Lib.cwd(), c, k) in + let c = Declare.SectionLocalDef const in + let () = Declare.declare_variable ~name ~kind c in let () = if should_suggest then Proof_using.suggest_variable (Global.env ()) name in - VarRef name + GlobRef.VarRef name | Global local -> let kn = - declare_constant name ~local (DefinitionEntry const, k) in + Declare.declare_constant ~name ~local ~kind (Declare.DefinitionEntry const) in let () = if should_suggest then Proof_using.suggest_constant (Global.env ()) kn in - let gr = ConstRef kn in + let gr = GlobRef.ConstRef kn in Declare.declare_univ_binders gr (UState.universe_binders universes); gr in - definition_message name; + Declare.definition_message name; (* This takes care of the implicits and hook for the current constant*) process_recthms ~fix_exn ?hook env sigma universes ~udecl ~poly ~scope r impargs other_thms with e when CErrors.noncritical e -> @@ -543,8 +455,9 @@ let finish_derived ~f ~name ~idopt ~entries = (* The opacity of [f_def] is adjusted to be [false], as it must. Then [f] is declared in the global environment. *) let f_def = { f_def with Proof_global.proof_entry_opaque = false } in - let f_def = Declare.DefinitionEntry f_def , Decl_kinds.(IsDefinition Definition) in - let f_kn = Declare.declare_constant f f_def in + let f_kind = Decls.(IsDefinition Definition) in + let f_def = Declare.DefinitionEntry f_def in + let f_kn = Declare.declare_constant ~name:f ~kind:f_kind f_def in let f_kn_term = mkConst f_kn in (* In the type and body of the proof of [suchthat] there can be references to the variable [f]. It needs to be replaced by @@ -566,21 +479,13 @@ let finish_derived ~f ~name ~idopt ~entries = proof_entry_body = lemma_body; proof_entry_type = Some lemma_type } in - let lemma_def = - Declare.DefinitionEntry lemma_def , - Decl_kinds.(IsProof Proposition) - in - let _ : Names.Constant.t = Declare.declare_constant name lemma_def in + let lemma_def = Declare.DefinitionEntry lemma_def in + let _ : Names.Constant.t = Declare.declare_constant ~name ~kind:Decls.(IsProof Proposition) lemma_def in () let finish_proved_equations lid kind proof_obj hook i types wits sigma0 = - let open Decl_kinds in let obls = ref 1 in - let kind = match kind with - | DefinitionBody d -> IsDefinition d - | Proof p -> IsProof p - in let sigma, recobls = CList.fold_left2_map (fun sigma (wit, (evar_env, ev, evi, local_context, type_)) entry -> let id = @@ -589,8 +494,8 @@ let finish_proved_equations lid kind proof_obj hook i types wits sigma0 = | None -> let n = !obls in incr obls; add_suffix i ("_obligation_" ^ string_of_int n) in let entry, args = Abstract.shrink_entry local_context entry in - let cst = Declare.declare_constant id (Declare.DefinitionEntry entry, kind) in - let sigma, app = Evarutil.new_global sigma (ConstRef cst) in + let cst = Declare.declare_constant ~name:id ~kind (Declare.DefinitionEntry entry) in + let sigma, app = Evarutil.new_global sigma (GlobRef.ConstRef cst) in let sigma = Evd.define ev (EConstr.applist (app, List.map EConstr.of_constr args)) sigma in sigma, cst) sigma0 (CList.combine (List.rev !wits) types) proof_obj.Proof_global.entries diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli index d156954c85..fbf91b3ad4 100644 --- a/vernac/lemmas.mli +++ b/vernac/lemmas.mli @@ -9,7 +9,6 @@ (************************************************************************) open Names -open Decl_kinds (** {4 Proofs attached to a constant} *) @@ -18,6 +17,7 @@ type t interactively *) val set_endline_tactic : Genarg.glob_generic_argument -> t -> t +(** [set_endline_tactic tac lemma] set ending tactic for [lemma] *) val pf_map : (Proof_global.t -> Proof_global.t) -> t -> t (** [pf_map f l] map the underlying proof object *) @@ -68,7 +68,7 @@ module Info : sig (** Info for special constants *) -> ?scope : DeclareDef.locality (** locality *) - -> ?kind:goal_object_kind + -> ?kind:Decls.logical_kind (** Theorem, etc... *) -> unit -> t @@ -80,7 +80,6 @@ val start_lemma : name:Id.t -> poly:bool -> ?udecl:UState.universe_decl - -> ?sign:Environ.named_context_val -> ?info:Info.t -> Evd.evar_map -> EConstr.types @@ -101,7 +100,7 @@ val start_lemma_with_initialization : ?hook:DeclareDef.Hook.t -> poly:bool -> scope:DeclareDef.locality - -> kind:goal_object_kind + -> kind:Decls.logical_kind -> udecl:UState.universe_decl -> Evd.evar_map -> (bool * lemma_possible_guards * unit Proofview.tactic list option) option @@ -116,17 +115,12 @@ val start_lemma_com : program_mode:bool -> poly:bool -> scope:DeclareDef.locality - -> kind:goal_object_kind + -> kind:Decls.logical_kind -> ?inference_hook:Pretyping.inference_hook -> ?hook:DeclareDef.Hook.t -> Vernacexpr.proof_expr list -> t -(* Prepare global named context for proof session: remove proofs of - opaque section definitions and remove vm-compiled code *) - -val initialize_named_context_for_proof : unit -> Environ.named_context_val - (** {4 Saving proofs} *) val save_lemma_admitted : lemma:t -> unit diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 90892feb13..e754ead5dd 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -519,7 +519,7 @@ let read_recursive_format sl fmt = let sl = skip_var_in_recursive_format fmt in try split_format_at_ldots [] sl with Exit -> error_not_same ?loc:(fst (List.last (if sl = [] then fmt else sl))) () in let rec get_tail = function - | (loc,a) :: sepfmt, (_,b) :: fmt when Pervasives.(=) a b -> get_tail (sepfmt, fmt) (* FIXME *) + | (loc,a) :: sepfmt, (_,b) :: fmt when (=) a b -> get_tail (sepfmt, fmt) (* FIXME *) | [], tail -> skip_var_in_recursive_format tail | (loc,_) :: _, ([] | (_,UnpTerminal _) :: _)-> error_not_same ?loc () | _, (loc,_)::_ -> error_not_same ?loc () in @@ -953,7 +953,7 @@ let join_auxiliary_recursive_types recvars etyps = | None, None -> typs | Some _, None -> typs | None, Some ytyp -> (x,ytyp)::typs - | Some xtyp, Some ytyp when Pervasives.(=) xtyp ytyp -> typs (* FIXME *) + | Some xtyp, Some ytyp when (=) xtyp ytyp -> typs (* FIXME *) | Some xtyp, Some ytyp -> user_err (strbrk "In " ++ Id.print x ++ str " .. " ++ Id.print y ++ diff --git a/vernac/obligations.ml b/vernac/obligations.ml index e82694b740..37fe0df0ee 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -9,7 +9,6 @@ (************************************************************************) open Printf -open Decl_kinds (** - Get types of existentials ; @@ -299,7 +298,7 @@ let unfold_entry cst = Hints.HintsUnfoldEntry [EvalConstRef cst] let add_hint local prg cst = Hints.add_hints ~local [Id.to_string prg.prg_name] (unfold_entry cst) -let init_prog_info ?(opaque = false) ?hook sign n udecl b t ctx deps fixkind +let init_prog_info ?(opaque = false) ?hook n udecl b t ctx deps fixkind notations obls impls ~scope ~poly ~kind reduce = let obls', b = match b with @@ -336,7 +335,7 @@ let init_prog_info ?(opaque = false) ?hook sign n udecl b t ctx deps fixkind ; prg_reduce = reduce ; prg_hook = hook ; prg_opaque = opaque - ; prg_sign = sign } + } let map_cardinal m = let i = ref 0 in @@ -398,8 +397,8 @@ let deps_remaining obls deps = deps [] -let goal_kind = DeclareDef.(Global Declare.ImportNeedQualified, DefinitionBody Definition) -let goal_proof_kind = DeclareDef.(Global Declare.ImportNeedQualified, Proof Lemma) +let goal_kind = DeclareDef.(Global Declare.ImportNeedQualified, Decls.(IsDefinition Definition)) +let goal_proof_kind = DeclareDef.(Global Declare.ImportNeedQualified, Decls.(IsProof Lemma)) let kind_of_obligation o = match o with @@ -468,12 +467,7 @@ let obligation_hook prg obl num auto { DeclareDef.Hook.S.uctx = ctx'; dref; _ } let obls = Array.copy obls in let () = obls.(num) <- obl in let prg = { prg with prg_ctx = ctx' } in - let () = - try ignore (update_obls prg obls (pred rem)) - with e when CErrors.noncritical e -> - let e = CErrors.push e in - pperror (CErrors.iprint (ExplainErr.process_vernac_interp_error e)) - in + let () = ignore (update_obls prg obls (pred rem)) in if pred rem > 0 then begin let deps = dependencies obls num in if not (Int.Set.is_empty deps) then @@ -501,7 +495,7 @@ let rec solve_obligation prg num tac = let hook = DeclareDef.Hook.make (obligation_hook prg obl num auto) in let info = Lemmas.Info.make ~hook ~proof_ending ~scope ~kind () in let poly = prg.prg_poly in - let lemma = Lemmas.start_lemma ~sign:prg.prg_sign ~name:obl.obl_name ~poly ~info evd (EConstr.of_constr obl.obl_type) in + let lemma = Lemmas.start_lemma ~name:obl.obl_name ~poly ~info evd (EConstr.of_constr obl.obl_type) in let lemma = fst @@ Lemmas.by !default_tactic lemma in let lemma = Option.cata (fun tac -> Lemmas.set_endline_tactic tac lemma) lemma tac in lemma @@ -638,11 +632,10 @@ let show_term n = ++ Printer.pr_constr_env env sigma prg.prg_body) let add_definition ~name ?term t ctx ?(univdecl=UState.default_univ_decl) - ?(implicits=[]) ~poly ?(scope=DeclareDef.Global Declare.ImportDefaultBehavior) ?(kind=Definition) ?tactic + ?(implicits=[]) ~poly ?(scope=DeclareDef.Global Declare.ImportDefaultBehavior) ?(kind=Decls.Definition) ?tactic ?(reduce=reduce) ?hook ?(opaque = false) obls = - let sign = Lemmas.initialize_named_context_for_proof () in let info = Id.print name ++ str " has type-checked" in - let prg = init_prog_info sign ~opaque name univdecl term t ctx [] None [] obls implicits ~poly ~scope ~kind reduce ?hook in + let prg = init_prog_info ~opaque name univdecl term t ctx [] None [] obls implicits ~poly ~scope ~kind reduce ?hook in let obls,_ = prg.prg_obligations in if Int.equal (Array.length obls) 0 then ( Flags.if_verbose Feedback.msg_info (info ++ str "."); @@ -658,13 +651,12 @@ let add_definition ~name ?term t ctx ?(univdecl=UState.default_univ_decl) | _ -> res) let add_mutual_definitions l ctx ?(univdecl=UState.default_univ_decl) ?tactic - ~poly ?(scope=DeclareDef.Global Declare.ImportDefaultBehavior) ?(kind=Definition) ?(reduce=reduce) + ~poly ?(scope=DeclareDef.Global Declare.ImportDefaultBehavior) ?(kind=Decls.Definition) ?(reduce=reduce) ?hook ?(opaque = false) notations fixkind = - let sign = Lemmas.initialize_named_context_for_proof () in let deps = List.map (fun (n, b, t, imps, obls) -> n) l in List.iter (fun (n, b, t, imps, obls) -> - let prg = init_prog_info sign ~opaque n univdecl (Some b) t ctx deps (Some fixkind) + let prg = init_prog_info ~opaque n univdecl (Some b) t ctx deps (Some fixkind) notations obls imps ~poly ~scope ~kind reduce ?hook in progmap_add n (CEphemeron.create prg)) l; let _defined = @@ -689,8 +681,8 @@ let admit_prog prg = | None -> let x = subst_deps_obl obls x in let ctx = UState.univ_entry ~poly:false prg.prg_ctx in - let kn = Declare.declare_constant x.obl_name ~local:Declare.ImportNeedQualified - (Declare.ParameterEntry (None,(x.obl_type,ctx),None), IsAssumption Conjectural) + let kn = Declare.declare_constant ~name:x.obl_name ~local:Declare.ImportNeedQualified + (Declare.ParameterEntry (None,(x.obl_type,ctx),None)) ~kind:Decls.(IsAssumption Conjectural) in assumption_message x.obl_name; obls.(i) <- { x with obl_body = Some (DefinedObl (kn, Univ.Instance.empty)) } diff --git a/vernac/obligations.mli b/vernac/obligations.mli index 233739ee46..f97bc784c3 100644 --- a/vernac/obligations.mli +++ b/vernac/obligations.mli @@ -50,7 +50,7 @@ val add_definition -> ?implicits:Impargs.manual_implicits -> poly:bool -> ?scope:DeclareDef.locality - -> ?kind:Decl_kinds.definition_object_kind + -> ?kind:Decls.definition_object_kind -> ?tactic:unit Proofview.tactic -> ?reduce:(constr -> constr) -> ?hook:DeclareDef.Hook.t @@ -66,7 +66,7 @@ val add_mutual_definitions -> ?tactic:unit Proofview.tactic -> poly:bool -> ?scope:DeclareDef.locality - -> ?kind:Decl_kinds.definition_object_kind + -> ?kind:Decls.definition_object_kind -> ?reduce:(constr -> constr) -> ?hook:DeclareDef.Hook.t -> ?opaque:bool -> DeclareObl.notations diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index 4f053b98ae..e676fe94db 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -16,7 +16,6 @@ open Util open CAst open Extend -open Decl_kinds open Constrexpr open Constrexpr_ops open Vernacexpr @@ -348,18 +347,18 @@ open Pputils let pr_assumption_token many discharge kind = match discharge, kind with - | (NoDischarge,Logical) -> + | (NoDischarge,Decls.Logical) -> keyword (if many then "Axioms" else "Axiom") - | (NoDischarge,Definitional) -> + | (NoDischarge,Decls.Definitional) -> keyword (if many then "Parameters" else "Parameter") - | (NoDischarge,Conjectural) -> str"Conjecture" - | (DoDischarge,Logical) -> + | (NoDischarge,Decls.Conjectural) -> str"Conjecture" + | (DoDischarge,Decls.Logical) -> keyword (if many then "Hypotheses" else "Hypothesis") - | (DoDischarge,Definitional) -> + | (DoDischarge,Decls.Definitional) -> keyword (if many then "Variables" else "Variable") - | (DoDischarge,Conjectural) -> + | (DoDischarge,Decls.Conjectural) -> anomaly (Pp.str "Don't know how to beautify a local conjecture.") - | (_,Context) -> + | (_,Decls.Context) -> anomaly (Pp.str "Context is used only internally.") let pr_params pr_c (xl,(c,t)) = @@ -372,7 +371,7 @@ open Pputils | (c,(idl,t))::l -> match factorize l with | (xl,((c', t') as r))::l' - when (c : bool) == c' && Pervasives.(=) t t' -> + when (c : bool) == c' && (=) t t' -> (* FIXME: we need equality on constr_expr *) (idl@xl,r)::l' | l' -> (idl,(c,t))::l' @@ -388,7 +387,16 @@ open Pputils prlist_with_sep pr_semicolon (pr_params pr_c) *) - let pr_thm_token k = keyword (Kindops.string_of_theorem_kind k) +let string_of_theorem_kind = let open Decls in function + | Theorem -> "Theorem" + | Lemma -> "Lemma" + | Fact -> "Fact" + | Remark -> "Remark" + | Property -> "Property" + | Proposition -> "Proposition" + | Corollary -> "Corollary" + + let pr_thm_token k = keyword (string_of_theorem_kind k) let pr_syntax_modifier = let open Gramlib.Gramext in function | SetItemLevel (l,bko,n) -> @@ -588,6 +596,18 @@ open Pputils with Not_found -> hov 1 (str "TODO(" ++ str (fst s) ++ spc () ++ prlist_with_sep sep pr_arg cl ++ str ")") + +let string_of_definition_object_kind = let open Decls in function + | Definition -> "Definition" + | Example -> "Example" + | Coercion -> "Coercion" + | SubClass -> "SubClass" + | CanonicalStructure -> "Canonical Structure" + | Instance -> "Instance" + | Let -> "Let" + | (StructureComponent|Scheme|CoFixpoint|Fixpoint|IdentityCoercion|Method) -> + CErrors.anomaly (Pp.str "Internal definition kind.") + let pr_vernac_expr v = let return = tag_vernac v in let env = Global.env () in @@ -719,7 +739,7 @@ open Pputils keyword ( if Name.is_anonymous (fst id).v then "Goal" - else Kindops.string_of_definition_object_kind dk) + else string_of_definition_object_kind dk) in let pr_reduce = function | None -> mt() diff --git a/vernac/recLemmas.ml b/vernac/recLemmas.ml new file mode 100644 index 0000000000..e6d428968c --- /dev/null +++ b/vernac/recLemmas.ml @@ -0,0 +1,102 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Util +open Constr +open Declarations + +module RelDecl = Context.Rel.Declaration + +let find_mutually_recursive_statements sigma thms = + let n = List.length thms in + let inds = List.map (fun (id,(t,impls)) -> + let (hyps,ccl) = EConstr.decompose_prod_assum sigma t in + let x = (id,(t,impls)) in + let whnf_hyp_hds = EConstr.map_rel_context_in_env + (fun env c -> fst (Reductionops.whd_all_stack env sigma c)) + (Global.env()) hyps in + let ind_hyps = + List.flatten (List.map_i (fun i decl -> + let t = RelDecl.get_type decl in + match EConstr.kind sigma t with + | Ind ((kn,_ as ind),u) when + let mind = Global.lookup_mind kn in + mind.mind_finite <> Declarations.CoFinite -> + [ind,x,i] + | _ -> + []) 0 (List.rev (List.filter Context.Rel.Declaration.is_local_assum whnf_hyp_hds))) in + let ind_ccl = + let cclenv = EConstr.push_rel_context hyps (Global.env()) in + let whnf_ccl,_ = Reductionops.whd_all_stack cclenv Evd.empty ccl in + match EConstr.kind sigma whnf_ccl with + | Ind ((kn,_ as ind),u) when + let mind = Global.lookup_mind kn in + Int.equal mind.mind_ntypes n && mind.mind_finite == Declarations.CoFinite -> + [ind,x,0] + | _ -> + [] in + ind_hyps,ind_ccl) thms in + let inds_hyps,ind_ccls = List.split inds in + let of_same_mutind ((kn,_),_,_) = function ((kn',_),_,_) -> Names.MutInd.equal kn kn' in + (* Check if all conclusions are coinductive in the same type *) + (* (degenerated cartesian product since there is at most one coind ccl) *) + let same_indccl = + List.cartesians_filter (fun hyp oks -> + if List.for_all (of_same_mutind hyp) oks + then Some (hyp::oks) else None) [] ind_ccls in + let ordered_same_indccl = + List.filter (List.for_all_i (fun i ((kn,j),_,_) -> Int.equal i j) 0) same_indccl in + (* Check if some hypotheses are inductive in the same type *) + let common_same_indhyp = + List.cartesians_filter (fun hyp oks -> + if List.for_all (of_same_mutind hyp) oks + then Some (hyp::oks) else None) [] inds_hyps in + let ordered_inds,finite,guard = + match ordered_same_indccl, common_same_indhyp with + | indccl::rest, _ -> + assert (List.is_empty rest); + (* One occ. of common coind ccls and no common inductive hyps *) + if not (List.is_empty common_same_indhyp) then + Flags.if_verbose Feedback.msg_info (Pp.str "Assuming mutual coinductive statements."); + flush_all (); + indccl, true, [] + | [], _::_ -> + let () = match same_indccl with + | ind :: _ -> + if List.distinct_f Names.ind_ord (List.map pi1 ind) + then + Flags.if_verbose Feedback.msg_info + (Pp.strbrk + ("Coinductive statements do not follow the order of "^ + "definition, assuming the proof to be by induction.")); + flush_all () + | _ -> () + in + let possible_guards = List.map (List.map pi3) inds_hyps in + (* assume the largest indices as possible *) + List.last common_same_indhyp, false, possible_guards + | _, [] -> + CErrors.user_err Pp.(str + ("Cannot find common (mutual) inductive premises or coinductive" ^ + " conclusions in the statements.")) + in + (finite,guard,None), ordered_inds + +let look_for_possibly_mutual_statements sigma = function + | [id,(t,impls)] -> + (* One non recursively proved theorem *) + None,[id,(t,impls)],None + | _::_ as thms -> + (* More than one statement and/or an explicit decreasing mark: *) + (* we look for a common inductive hyp or a common coinductive conclusion *) + let recguard,ordered_inds = find_mutually_recursive_statements sigma thms in + let thms = List.map pi2 ordered_inds in + Some recguard,thms, Some (List.map (fun (_,_,i) -> succ i) ordered_inds) + | [] -> CErrors.anomaly (Pp.str "Empty list of theorems.") diff --git a/library/kindops.mli b/vernac/recLemmas.mli index 3c9f2bb7c3..dfb5e4a644 100644 --- a/library/kindops.mli +++ b/vernac/recLemmas.mli @@ -1,6 +1,6 @@ (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) (* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) @@ -8,10 +8,8 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Decl_kinds - -(** Operations about types defined in [Decl_kinds] *) - -val logical_kind_of_goal_kind : goal_object_kind -> logical_kind -val string_of_theorem_kind : theorem_kind -> string -val string_of_definition_object_kind : definition_object_kind -> string +val look_for_possibly_mutual_statements + : Evd.evar_map + -> ('a * (EConstr.t * 'b)) list + -> (bool * int list list * 'c option) option * + ('a * (EConstr.t * 'b)) list * int list option diff --git a/vernac/record.ml b/vernac/record.ml index cc4f02349d..86745212e7 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -14,7 +14,6 @@ open Term open Sorts open Util open Names -open Globnames open Nameops open Constr open Context @@ -24,7 +23,6 @@ open Declarations open Entries open Declare open Constrintern -open Decl_kinds open Type_errors open Constrexpr open Constrexpr_ops @@ -282,7 +280,7 @@ type projection_flags = { } (* We build projections *) -let declare_projections indsp ctx ?(kind=StructureComponent) binder_name flags fieldimpls fields = +let declare_projections indsp ctx ?(kind=Decls.StructureComponent) binder_name flags fieldimpls fields = let env = Global.env() in let (mib,mip) = Global.lookup_inductive indsp in let poly = Declareops.inductive_is_polymorphic mib in @@ -352,8 +350,8 @@ let declare_projections indsp ctx ?(kind=StructureComponent) binder_name flags f proof_entry_opaque = false; proof_entry_inline_code = false; proof_entry_feedback = None } in - let k = (Declare.DefinitionEntry entry,IsDefinition kind) in - let kn = declare_constant fid k in + let kind = Decls.IsDefinition kind in + let kn = declare_constant ~name:fid ~kind (Declare.DefinitionEntry entry) in let constr_fip = let proj_args = (*Rel 1 refers to "x"*) paramargs@[mkRel 1] in applist (mkConstU (kn,u),proj_args) @@ -363,10 +361,10 @@ let declare_projections indsp ctx ?(kind=StructureComponent) binder_name flags f with Type_errors.TypeError (ctx,te) -> raise (NotDefinable (BadTypedProj (fid,ctx,te))) in - let refi = ConstRef kn in + let refi = GlobRef.ConstRef kn in Impargs.maybe_declare_manual_implicits false refi impls; if flags.pf_subclass then begin - let cl = Class.class_of_global (IndRef indsp) in + let cl = Class.class_of_global (GlobRef.IndRef indsp) in Class.try_add_new_coercion_with_source refi ~local:false ~poly ~source:cl end; let i = if is_local_assum decl then i+1 else i in @@ -402,7 +400,7 @@ let inStruc : Recordops.struc_tuple -> obj = let declare_structure_entry o = Lib.add_anonymous_leaf (inStruc o) -let declare_structure ~cum finite ubinders univs paramimpls params template ?(kind=StructureComponent) ?name record_data = +let declare_structure ~cumulative finite ubinders univs paramimpls params template ?(kind=Decls.StructureComponent) ?name record_data = let nparams = List.length params in let poly, ctx = match univs with @@ -411,7 +409,7 @@ let declare_structure ~cum finite ubinders univs paramimpls params template ?(ki | Polymorphic_entry (nas, ctx) -> true, Polymorphic_entry (nas, ctx) in - let variance = if poly && cum then Some (InferCumulativity.dummy_variance ctx) else None in + let variance = if poly && cumulative then Some (InferCumulativity.dummy_variance ctx) else None in let binder_name = match name with | None -> @@ -469,7 +467,7 @@ let declare_structure ~cum finite ubinders univs paramimpls params template ?(ki let rsp = (kn, i) in (* This is ind path of idstruc *) let cstr = (rsp, 1) in let kinds,sp_projs = declare_projections rsp ctx ~kind binder_name.(i) coers fieldimpls fields in - let build = ConstructRef cstr in + let build = GlobRef.ConstructRef cstr in let () = if is_coe then Class.try_add_new_coercion build ~local:false ~poly in let () = declare_structure_entry (cstr, List.rev kinds, List.rev sp_projs) in rsp @@ -480,8 +478,8 @@ let implicits_of_context ctx = List.map (fun name -> CAst.make (Some (name,true))) (List.rev (Anonymous :: (List.map RelDecl.get_name ctx))) -let declare_class def cum ubinders univs id idbuild paramimpls params arity - template fieldimpls fields ?(kind=StructureComponent) coers priorities = +let declare_class def cumulative ubinders univs id idbuild paramimpls params arity + template fieldimpls fields ?(kind=Decls.StructureComponent) coers priorities = let fieldimpls = (* Make the class implicit in the projections, and the params if applicable. *) let impls = implicits_of_context params in @@ -497,8 +495,8 @@ let declare_class def cum ubinders univs id idbuild paramimpls params arity let class_type = it_mkProd_or_LetIn arity params in let class_entry = Declare.definition_entry ~types:class_type ~univs class_body in - let cst = Declare.declare_constant id - (DefinitionEntry class_entry, IsDefinition Definition) + let cst = Declare.declare_constant ~name:id + (DefinitionEntry class_entry) ~kind:Decls.(IsDefinition Definition) in let inst, univs = match univs with | Polymorphic_entry (_, uctx) -> Univ.UContext.instance uctx, univs @@ -512,12 +510,12 @@ let declare_class def cum ubinders univs id idbuild paramimpls params arity let proj_body = it_mkLambda_or_LetIn (mkLambda (binder, inst_type, mkRel 1)) params in let proj_entry = Declare.definition_entry ~types:proj_type ~univs proj_body in - let proj_cst = Declare.declare_constant proj_name - (DefinitionEntry proj_entry, IsDefinition Definition) + let proj_cst = Declare.declare_constant ~name:proj_name + (DefinitionEntry proj_entry) ~kind:Decls.(IsDefinition Definition) in - let cref = ConstRef cst in + let cref = GlobRef.ConstRef cst in Impargs.declare_manual_implicits false cref paramimpls; - Impargs.declare_manual_implicits false (ConstRef proj_cst) (List.hd fieldimpls); + Impargs.declare_manual_implicits false (GlobRef.ConstRef proj_cst) (List.hd fieldimpls); Classes.set_typeclass_transparency (EvalConstRef cst) false false; let sub = match List.hd coers with | Some b -> Some ((if b then Backward else Forward), List.hd priorities) @@ -527,8 +525,8 @@ let declare_class def cum ubinders univs id idbuild paramimpls params arity | _ -> let record_data = [id, idbuild, arity, fieldimpls, fields, false, List.map (fun _ -> { pf_subclass = false ; pf_canonical = true }) fields] in - let inds = declare_structure ~cum Declarations.BiFinite ubinders univs paramimpls - params template ~kind:Method ~name:[|binder_name|] record_data + let inds = declare_structure ~cumulative Declarations.BiFinite ubinders univs paramimpls + params template ~kind:Decls.Method ~name:[|binder_name|] record_data in let coers = List.map2 (fun coe pri -> Option.map (fun b -> @@ -538,7 +536,7 @@ let declare_class def cum ubinders univs id idbuild paramimpls params arity let map ind = let l = List.map3 (fun decl b y -> RelDecl.get_name decl, b, y) (List.rev fields) coers (Recordops.lookup_projections ind) - in IndRef ind, l + in GlobRef.IndRef ind, l in List.map map inds in @@ -581,14 +579,14 @@ let declare_class def cum ubinders univs id idbuild paramimpls params arity let add_constant_class env sigma cst = - let ty, univs = Typeops.type_of_global_in_context env (ConstRef cst) in + let ty, univs = Typeops.type_of_global_in_context env (GlobRef.ConstRef cst) in let r = (Environ.lookup_constant cst env).const_relevance in let ctx, _ = decompose_prod_assum ty in let args = Context.Rel.to_extended_vect Constr.mkRel 0 ctx in let t = mkApp (mkConstU (cst, Univ.make_abstract_instance univs), args) in let tc = { cl_univs = univs; - cl_impl = ConstRef cst; + cl_impl = GlobRef.ConstRef cst; cl_context = (List.map (const None) ctx, ctx); cl_props = [LocalAssum (make_annot Anonymous r, t)]; cl_projs = []; @@ -610,7 +608,7 @@ let add_inductive_class env sigma ind = let ty = Inductive.type_of_inductive env ((mind, oneind), inst) in let r = Inductive.relevance_of_inductive env ind in { cl_univs = univs; - cl_impl = IndRef ind; + cl_impl = GlobRef.IndRef ind; cl_context = List.map (const None) ctx, ctx; cl_props = [LocalAssum (make_annot Anonymous r, ty)]; cl_projs = []; @@ -629,8 +627,8 @@ let declare_existing_class g = if Typeclasses.is_class g then warn_already_existing_class g else match g with - | ConstRef x -> add_constant_class env sigma x - | IndRef x -> add_inductive_class env sigma x + | GlobRef.ConstRef x -> add_constant_class env sigma x + | GlobRef.IndRef x -> add_inductive_class env sigma x | _ -> user_err ~hdr:"declare_existing_class" (Pp.str"Unsupported class type, only constants and inductives are allowed") @@ -680,7 +678,7 @@ let extract_record_data records = (* [fs] corresponds to fields and [ps] to parameters; [coers] is a list telling if the corresponding fields must me declared as coercions or subinstances. *) -let definition_structure udecl kind ~template cum ~poly finite records = +let definition_structure udecl kind ~template ~cumulative ~poly finite records = let () = check_unique_names records in let () = check_priorities kind records in let ps, data = extract_record_data records in @@ -696,7 +694,7 @@ let definition_structure udecl kind ~template cum ~poly finite records = in let priorities = List.map (fun (_, { rf_priority }) -> {hint_priority = rf_priority ; hint_pattern = None}) cfs in let coers = List.map (fun (_, { rf_subclass }) -> rf_subclass) cfs in - declare_class def cum ubinders univs id.CAst.v idbuild + declare_class def cumulative ubinders univs id.CAst.v idbuild implpars params arity template implfs fields coers priorities | _ -> let map impls = implpars @ [CAst.make None] @ impls in @@ -710,5 +708,5 @@ let definition_structure udecl kind ~template cum ~poly finite records = id.CAst.v, idbuild, arity, implfs, fields, is_coe, coe in let data = List.map2 map data records in - let inds = declare_structure ~cum finite ubinders univs implpars params template data in - List.map (fun ind -> IndRef ind) inds + let inds = declare_structure ~cumulative finite ubinders univs implpars params template data in + List.map (fun ind -> GlobRef.IndRef ind) inds diff --git a/vernac/record.mli b/vernac/record.mli index d0164572f3..571fd9536e 100644 --- a/vernac/record.mli +++ b/vernac/record.mli @@ -22,7 +22,7 @@ type projection_flags = { val declare_projections : inductive -> Entries.universes_entry -> - ?kind:Decl_kinds.definition_object_kind -> + ?kind:Decls.definition_object_kind -> Id.t -> projection_flags list -> Impargs.manual_implicits list -> @@ -35,7 +35,7 @@ val definition_structure : universe_decl_expr option -> inductive_kind -> template:bool option - -> Decl_kinds.cumulative_inductive_flag + -> cumulative:bool -> poly:bool -> Declarations.recursivity_kind -> (coercion_flag * diff --git a/vernac/search.ml b/vernac/search.ml index a7f1dd33c2..06554aae20 100644 --- a/vernac/search.ml +++ b/vernac/search.ml @@ -17,7 +17,6 @@ open Libobject open Environ open Pattern open Libnames -open Globnames module NamedDecl = Context.Named.Declaration @@ -53,7 +52,7 @@ module SearchBlacklist = let iter_constructors indsp u fn env nconstr = for i = 1 to nconstr do let typ = Inductiveops.type_of_constructor env ((indsp, i), u) in - fn (ConstructRef (indsp, i)) env typ + fn (GlobRef.ConstructRef (indsp, i)) env typ done let iter_named_context_name_type f = @@ -67,7 +66,7 @@ let get_current_or_goal_context ?pstate glnum = (* General search over hypothesis of a goal *) let iter_hypothesis ?pstate glnum (fn : GlobRef.t -> env -> constr -> unit) = let env = Global.env () in - let iter_hyp idh typ = fn (VarRef idh) env typ in + let iter_hyp idh typ = fn (GlobRef.VarRef idh) env typ in let evmap,e = get_current_or_goal_context ?pstate glnum in let pfctxt = named_context e in iter_named_context_name_type iter_hyp pfctxt @@ -75,31 +74,32 @@ let iter_hypothesis ?pstate glnum (fn : GlobRef.t -> env -> constr -> unit) = (* General search over declarations *) let iter_declarations (fn : GlobRef.t -> env -> constr -> unit) = let env = Global.env () in - let iter_obj (sp, kn) lobj = match object_tag lobj with - | "VARIABLE" -> - begin try - let decl = Global.lookup_named (basename sp) in - fn (VarRef (NamedDecl.get_id decl)) env (NamedDecl.get_type decl) - with Not_found -> (* we are in a section *) () end - | "CONSTANT" -> - let cst = Global.constant_of_delta_kn kn in - let gr = ConstRef cst in - let (typ, _) = Typeops.type_of_global_in_context (Global.env ()) gr in - fn gr env typ - | "INDUCTIVE" -> - let mind = Global.mind_of_delta_kn kn in - let mib = Global.lookup_mind mind in - let iter_packet i mip = - let ind = (mind, i) in - let u = Univ.make_abstract_instance (Declareops.inductive_polymorphic_context mib) in - let i = (ind, u) in - let typ = Inductiveops.type_of_inductive env i in - let () = fn (IndRef ind) env typ in - let len = Array.length mip.mind_user_lc in - iter_constructors ind u fn env len - in - Array.iteri iter_packet mib.mind_packets - | _ -> () + List.iter (fun d -> fn (GlobRef.VarRef (NamedDecl.get_id d)) env (NamedDecl.get_type d)) + (Environ.named_context env); + let iter_obj (sp, kn) lobj = match lobj with + | AtomicObject o -> + begin match object_tag o with + | "CONSTANT" -> + let cst = Global.constant_of_delta_kn kn in + let gr = GlobRef.ConstRef cst in + let (typ, _) = Typeops.type_of_global_in_context (Global.env ()) gr in + fn gr env typ + | "INDUCTIVE" -> + let mind = Global.mind_of_delta_kn kn in + let mib = Global.lookup_mind mind in + let iter_packet i mip = + let ind = (mind, i) in + let u = Univ.make_abstract_instance (Declareops.inductive_polymorphic_context mib) in + let i = (ind, u) in + let typ = Inductiveops.type_of_inductive env i in + let () = fn (GlobRef.IndRef ind) env typ in + let len = Array.length mip.mind_user_lc in + iter_constructors ind u fn env len + in + Array.iteri iter_packet mib.mind_packets + | _ -> () + end + | _ -> () in try Declaremods.iter_all_segments iter_obj with Not_found -> () @@ -147,7 +147,7 @@ module ConstrPriority = struct -(3*(num_symbols t) + size t) let compare (_,_,_,p1) (_,_,_,p2) = - Pervasives.compare p1 p2 + pervasives_compare p1 p2 end module PriorityQueue = Heap.Functional(ConstrPriority) diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml index 7644f4c5b6..046defc26b 100644 --- a/vernac/topfmt.ml +++ b/vernac/topfmt.ml @@ -329,8 +329,8 @@ let init_terminal_output ~color = Format.pp_set_print_tags !std_ft true; Format.pp_set_print_tags !err_ft true end; - Format.pp_set_formatter_tag_functions !std_ft (tag_handler !std_ft); - Format.pp_set_formatter_tag_functions !err_ft (tag_handler !err_ft) + Format.pp_set_formatter_tag_functions !std_ft (tag_handler !std_ft) [@warning "-3"]; + Format.pp_set_formatter_tag_functions !err_ft (tag_handler !err_ft) [@warning "-3"] (* Rules for emacs: - Debug/info: emacs_quote_info diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib index d28eeb341d..20de6b4ff2 100644 --- a/vernac/vernac.mllib +++ b/vernac/vernac.mllib @@ -5,7 +5,6 @@ G_vernac G_proofs Vernacprop Himsg -ExplainErr Locality Egramml Vernacextend @@ -16,6 +15,7 @@ Metasyntax DeclareDef DeclareObl Canonical +RecLemmas Lemmas Class Auto_ind_decl diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 9b9be0209e..68b7462bde 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -24,7 +24,6 @@ open Goptions open Libnames open Globnames open Vernacexpr -open Decl_kinds open Constrexpr open Redexpr open Lemmas @@ -287,8 +286,8 @@ let print_strategy r = match r with | None -> let fold key lvl (vacc, cacc) = match key with - | VarKey id -> ((VarRef id, lvl) :: vacc, cacc) - | ConstKey cst -> (vacc, (ConstRef cst, lvl) :: cacc) + | VarKey id -> ((GlobRef.VarRef id, lvl) :: vacc, cacc) + | ConstKey cst -> (vacc, (GlobRef.ConstRef cst, lvl) :: cacc) | RelKey _ -> (vacc, cacc) in let var_lvl, cst_lvl = fold_strategy fold oracle ([], []) in @@ -305,7 +304,7 @@ let print_strategy r = var_msg ++ cst_msg | Some r -> let r = Smartlocate.smart_global r in - let key = match r with + let key = let open GlobRef in match r with | VarRef id -> VarKey id | ConstRef cst -> ConstKey cst | IndRef _ | ConstructRef _ -> user_err Pp.(str "The reference is not unfoldable") @@ -525,7 +524,7 @@ let start_proof_and_print ~program_mode ~poly ?hook ~scope ~kind l = in start_lemma_com ~program_mode ?inference_hook ?hook ~poly ~scope ~kind l -let vernac_definition_hook ~poly = function +let vernac_definition_hook ~poly = let open Decls in function | Coercion -> Some (Class.add_coercion_hook ~poly) | CanonicalStructure -> @@ -558,7 +557,7 @@ let vernac_definition_interactive ~atts (discharge, kind) (lid, pl) bl t = let program_mode = atts.program in let poly = atts.polymorphic in let name = vernac_definition_name lid local in - start_proof_and_print ~program_mode ~poly ~scope:local ~kind:(DefinitionBody kind) ?hook [(name, pl), (bl, t)] + start_proof_and_print ~program_mode ~poly ~scope:local ~kind:(Decls.IsDefinition kind) ?hook [(name, pl), (bl, t)] let vernac_definition ~atts (discharge, kind) (lid, pl) bl red_option c typ_opt = let open DefAttributes in @@ -581,7 +580,7 @@ let vernac_start_proof ~atts kind l = let scope = enforce_locality_exp atts.locality NoDischarge in if Dumpglob.dump () then List.iter (fun ((id, _), _) -> Dumpglob.dump_definition id false "prf") l; - start_proof_and_print ~program_mode:atts.program ~poly:atts.polymorphic ~scope ~kind:(Proof kind) l + start_proof_and_print ~program_mode:atts.program ~poly:atts.polymorphic ~scope ~kind:(Decls.IsProof kind) l let vernac_end_proof ~lemma = let open Vernacexpr in function | Admitted -> @@ -636,7 +635,7 @@ let should_treat_as_uniform () = else ComInductive.NonUniformParameters let vernac_record ~template udecl cum k poly finite records = - let is_cumulative = should_treat_as_cumulative cum poly in + let cumulative = should_treat_as_cumulative cum poly in let map ((coe, id), binders, sort, nameopt, cfs) = let const = match nameopt with | None -> add_prefix "Build_" id.v @@ -657,7 +656,7 @@ let vernac_record ~template udecl cum k poly finite records = coe, id, binders, cfs, const, sort in let records = List.map map records in - ignore(Record.definition_structure ~template udecl k is_cumulative ~poly finite records) + ignore(Record.definition_structure ~template udecl k ~cumulative ~poly finite records) let extract_inductive_udecl (indl:(inductive_expr * decl_notation list) list) = match indl with @@ -755,9 +754,9 @@ let vernac_inductive ~atts cum lo finite indl = | RecordDecl _ -> assert false (* ruled out above *) in let indl = List.map unpack indl in - let is_cumulative = should_treat_as_cumulative cum poly in + let cumulative = should_treat_as_cumulative cum poly in let uniform = should_treat_as_uniform () in - ComInductive.do_mutual_inductive ~template udecl indl is_cumulative ~poly lo ~uniform finite + ComInductive.do_mutual_inductive ~template udecl indl ~cumulative ~poly ~private_ind:lo ~uniform finite else user_err (str "Mixed record-inductive definitions are not allowed") (* @@ -1460,7 +1459,7 @@ let vernac_arguments ~section_local reference args more_implicits nargs_for_red if red_modifiers_specified then begin match sr with - | ConstRef _ as c -> + | GlobRef.ConstRef _ as c -> Reductionops.ReductionBehaviour.set ~local:section_local c (Option.get red_behavior) @@ -1732,8 +1731,8 @@ let vernac_set_strategy ~local l = let local = Option.default false local in let glob_ref r = match smart_global r with - | ConstRef sp -> EvalConstRef sp - | VarRef id -> EvalVarRef id + | GlobRef.ConstRef sp -> EvalConstRef sp + | GlobRef.VarRef id -> EvalVarRef id | _ -> user_err Pp.(str "cannot set an inductive type or a constructor as transparent") in let l = List.map (fun (lev,ql) -> (lev,List.map glob_ref ql)) l in @@ -1743,8 +1742,8 @@ let vernac_set_opacity ~local (v,l) = let local = Option.default true local in let glob_ref r = match smart_global r with - | ConstRef sp -> EvalConstRef sp - | VarRef id -> EvalVarRef id + | GlobRef.ConstRef sp -> EvalConstRef sp + | GlobRef.VarRef id -> EvalVarRef id | _ -> user_err Pp.(str "cannot set an inductive type or a constructor as transparent") in let l = List.map glob_ref l in @@ -2091,7 +2090,7 @@ let vernac_register qid r = match r with | RegisterInline -> begin match gr with - | ConstRef c -> Global.register_inline c + | GlobRef.ConstRef c -> Global.register_inline c | _ -> CErrors.user_err (Pp.str "Register Inline: expecting a constant") end | RegisterCoqlib n -> @@ -2107,7 +2106,7 @@ let vernac_register qid r = | k -> CErrors.user_err Pp.(str "Register: unknown identifier “" ++ str k ++ str "” in the “kernel” namespace") in match gr with - | IndRef ind -> Global.register_inductive ind pind + | GlobRef.IndRef ind -> Global.register_inductive ind pind | _ -> CErrors.user_err (Pp.str "Register in kernel: expecting an inductive type") end else Coqlib.register_ref (Libnames.string_of_qualid n) gr @@ -2234,7 +2233,7 @@ let with_fail f : (Pp.t, unit) result = (* Fail Timeout is a common pattern so we need to support it. *) | e when CErrors.noncritical e || e = Timeout -> (* The error has to be printed in the failing state *) - Ok CErrors.(iprint ExplainErr.(process_vernac_interp_error (push e))) + Ok CErrors.(iprint (push e)) (* We restore the state always *) let with_fail ~st f = @@ -2290,7 +2289,7 @@ let interp_typed_vernac c ~stack = (* We interpret vernacular commands to a DSL that specifies their allowed actions on proof states *) -let translate_vernac ~atts v = let open Vernacextend in match v with +let rec translate_vernac ~atts v = let open Vernacextend in match v with | VernacAbortAll | VernacRestart | VernacUndo _ @@ -2299,8 +2298,7 @@ let translate_vernac ~atts v = let open Vernacextend in match v with | VernacResetInitial | VernacBack _ | VernacBackTo _ - | VernacAbort _ - | VernacLoad _ -> + | VernacAbort _ -> anomaly (str "type_vernac") (* Syntax *) | VernacSyntaxExtension (infix, sl) -> @@ -2604,6 +2602,11 @@ let translate_vernac ~atts v = let open Vernacextend in match v with | VernacEndProof pe -> VtCloseProof (vernac_end_proof pe) + | VernacLoad (verbosely,fname) -> + VtNoProof(fun () -> + unsupported_attributes atts; + vernac_load ~verbosely fname) + (* Extensions *) | VernacExtend (opn,args) -> Vernacextend.type_vernac ~atts opn args @@ -2612,7 +2615,7 @@ let translate_vernac ~atts v = let open Vernacextend in match v with * is the outdated/deprecated "Local" attribute of some vernacular commands * still parsed as the obsolete_locality grammar entry for retrocompatibility. * loc is the Loc.t of the vernacular command being interpreted. *) -let rec interp_expr ?proof ~atts ~st c = +and interp_expr ?proof ~atts ~st c = let stack = st.Vernacstate.lemmas in vernac_pperr_endline (fun () -> str "interpreting: " ++ Ppvernac.pr_vernac_expr c); match c with @@ -2632,12 +2635,6 @@ let rec interp_expr ?proof ~atts ~st c = (* This one is possible to handle here *) | VernacAbort id -> CErrors.user_err (str "Abort cannot be used through the Load command") - (* Loading a file requires access to the control interpreter so - [vernac_load] is mutually-recursive with [interp_expr] *) - | VernacLoad (verbosely,fname) -> - unsupported_attributes atts; - vernac_load ~verbosely ~st fname - | v -> let fv = translate_vernac ~atts v in interp_typed_vernac ~stack fv @@ -2647,13 +2644,10 @@ let rec interp_expr ?proof ~atts ~st c = the classifier. The proper fix is to move it to the STM, however, the way the proof mode is set there makes the task non trivial without a considerable amount of refactoring. - *) -and vernac_load ~verbosely ~st fname = - let there_are_pending_proofs ~stack = not Option.(is_empty stack) in - let stack = st.Vernacstate.lemmas in - if there_are_pending_proofs ~stack then - CErrors.user_err Pp.(str "Load is not supported inside proofs."); - (* Open the file *) +*) +and vernac_load ~verbosely fname = + (* Note that no proof should be open here, so the state here is just token for now *) + let st = Vernacstate.freeze_interp_state ~marshallable:false in let fname = Envars.expand_path_macros ~warn:(fun x -> Feedback.msg_warning (str x)) fname in let fname = CUnix.make_suffix fname ".v" in @@ -2664,10 +2658,10 @@ and vernac_load ~verbosely ~st fname = (* Parsing loop *) let v_mod = if verbosely then Flags.verbosely else Flags.silently in let parse_sentence proof_mode = Flags.with_option Flags.we_are_parsing - (fun po -> - match Pcoq.Entry.parse (Pvernac.main_entry proof_mode) po with - | Some x -> x - | None -> raise End_of_input) in + (fun po -> + match Pcoq.Entry.parse (Pvernac.main_entry proof_mode) po with + | Some x -> x + | None -> raise End_of_input) in let rec load_loop ~stack = try let proof_mode = Option.map (fun _ -> get_default_proof_mode ()) stack in @@ -2679,15 +2673,18 @@ and vernac_load ~verbosely ~st fname = End_of_input -> stack in - let stack = load_loop ~stack in + let stack = load_loop ~stack:st.Vernacstate.lemmas in (* If Load left a proof open, we fail too. *) - if there_are_pending_proofs ~stack then + if Option.has_some stack then CErrors.user_err Pp.(str "Files processed by Load cannot leave open proofs."); - stack + () and interp_control ?proof ~st v = match v with | { v=VernacExpr (atts, cmd) } -> - interp_expr ?proof ~atts ~st cmd + let before_univs = Global.universes () in + let pstack = interp_expr ?proof ~atts ~st cmd in + if before_univs == Global.universes () then pstack + else Option.map (Vernacstate.LemmaStack.map_top_pstate ~f:Proof_global.update_global_env) pstack | { v=VernacFail v } -> with_fail ~st (fun () -> interp_control ?proof ~st v); st.Vernacstate.lemmas diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index dc5df5904e..ee1f839b8d 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -276,13 +276,13 @@ type nonrec vernac_expr = | VernacDeclareCustomEntry of string (* Gallina *) - | VernacDefinition of (discharge * Decl_kinds.definition_object_kind) * name_decl * definition_expr - | VernacStartTheoremProof of Decl_kinds.theorem_kind * proof_expr list + | VernacDefinition of (discharge * Decls.definition_object_kind) * name_decl * definition_expr + | VernacStartTheoremProof of Decls.theorem_kind * proof_expr list | VernacEndProof of proof_end | VernacExactProof of constr_expr - | VernacAssumption of (discharge * Decl_kinds.assumption_object_kind) * + | VernacAssumption of (discharge * Decls.assumption_object_kind) * Declaremods.inline * (ident_decl list * constr_expr) with_coercion list - | VernacInductive of vernac_cumulative option * Decl_kinds.private_flag * inductive_flag * (inductive_expr * decl_notation list) list + | VernacInductive of vernac_cumulative option * bool (* private *) * inductive_flag * (inductive_expr * decl_notation list) list | VernacFixpoint of discharge * (fixpoint_expr * decl_notation list) list | VernacCoFixpoint of discharge * (cofixpoint_expr * decl_notation list) list | VernacScheme of (lident option * scheme) list |