diff options
292 files changed, 4564 insertions, 3874 deletions
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 68bb24ac77..5aa0fee16f 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -18,7 +18,7 @@ stages: variables: # Format: $IMAGE-V$DATE [Cache is not used as of today but kept here # for reference] - CACHEKEY: "bionic_coq-V2019-03-01-V43" + CACHEKEY: "bionic_coq-V2019-03-14-V14" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" diff --git a/Makefile.build b/Makefile.build index 9e0a402730..2bb32dc6c2 100644 --- a/Makefile.build +++ b/Makefile.build @@ -570,8 +570,8 @@ bin/votour.byte: $(VOTOURCMO) $(LIBCOQRUN) ########################################################################### CSDPCERTCMO:=clib/clib.cma $(addprefix plugins/micromega/, \ - micromega.cmo mutils.cmo \ - sos_types.cmo sos_lib.cmo sos.cmo csdpcert.cmo ) + micromega.cmo numCompat.cmo mutils.cmo \ + sos_types.cmo sos_lib.cmo sos.cmo csdpcert.cmo ) $(CSDPCERT): $(call bestobj, $(CSDPCERTCMO)) $(SHOW)'OCAMLBEST -o $@' diff --git a/Makefile.doc b/Makefile.doc index 1249555cd7..5aa1ae9850 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -38,10 +38,11 @@ SPHINXENV:=COQBIN="$(CURDIR)/bin/" COQLIB="$(WIN_CURDIR)" else SPHINXENV:=COQBIN="$(CURDIR)/bin/" COQLIB="$(CURDIR)" endif -SPHINXOPTS= -j4 SPHINXWARNERROR ?= 1 ifeq ($(SPHINXWARNERROR),1) -SPHINXOPTS += -W +SPHINXOPTS= -W +else +SPHINXOPTS= endif SPHINXBUILD= sphinx-build SPHINXBUILDDIR= doc/sphinx/_build diff --git a/azure-pipelines.yml b/azure-pipelines.yml index aba2b05037..98e17e8fe8 100644 --- a/azure-pipelines.yml +++ b/azure-pipelines.yml @@ -40,7 +40,7 @@ jobs: - job: macOS pool: - vmImage: 'macOS-10.13' + vmImage: 'macOS-10.14' variables: MACOSX_DEPLOYMENT_TARGET: '10.11' diff --git a/checker/analyze.ml b/checker/analyze.ml index 91137a0ce2..94acba6b05 100644 --- a/checker/analyze.ml +++ b/checker/analyze.ml @@ -25,6 +25,12 @@ let code_codepointer = 0x10 let code_infixpointer = 0x11 let code_custom = 0x12 let code_block64 = 0x13 +let code_shared64 = 0x14 +let code_string64 = 0x15 +let code_double_array64_big = 0x16 +let code_double_array64_little = 0x17 +let code_custom_len = 0x18 +let code_custom_fixed = 0x19 [@@@ocaml.warning "-37"] type code_descr = @@ -48,8 +54,14 @@ type code_descr = | CODE_INFIXPOINTER | CODE_CUSTOM | CODE_BLOCK64 +| CODE_SHARED64 +| CODE_STRING64 +| CODE_DOUBLE_ARRAY64_BIG +| CODE_DOUBLE_ARRAY64_LITTLE +| CODE_CUSTOM_LEN +| CODE_CUSTOM_FIXED -let code_max = 0x13 +let code_max = 0x19 let magic_number = "\132\149\166\190" @@ -342,7 +354,8 @@ let parse_object chan = let addr = input_int32u chan in for _i = 0 to 15 do ignore (input_byte chan); done; RCode addr - | CODE_CUSTOM -> + | CODE_CUSTOM + | CODE_CUSTOM_FIXED -> begin match input_cstring chan with | "_j" -> Rint64 (input_intL chan) | s -> Printf.eprintf "Unhandled custom code: %s" s; assert false @@ -356,6 +369,11 @@ let parse_object chan = | CODE_DOUBLE_ARRAY8_LITTLE | CODE_DOUBLE_ARRAY32_BIG | CODE_INFIXPOINTER + | CODE_SHARED64 + | CODE_STRING64 + | CODE_DOUBLE_ARRAY64_BIG + | CODE_DOUBLE_ARRAY64_LITTLE + | CODE_CUSTOM_LEN -> Printf.eprintf "Unhandled code %04x\n%!" data; assert false let parse chan = diff --git a/checker/checkInductive.ml b/checker/checkInductive.ml index 62e732ce69..c4c6d9bb4f 100644 --- a/checker/checkInductive.ml +++ b/checker/checkInductive.ml @@ -20,7 +20,7 @@ exception InductiveMismatch of MutInd.t * string let check mind field b = if not b then raise (InductiveMismatch (mind,field)) -let to_entry mind (mb:mutual_inductive_body) : Entries.mutual_inductive_entry = +let to_entry (mb:mutual_inductive_body) : Entries.mutual_inductive_entry = let open Entries in let nparams = List.length mb.mind_params_ctxt in (* include letins *) let mind_entry_record = match mb.mind_record with @@ -33,39 +33,27 @@ let to_entry mind (mb:mutual_inductive_body) : Entries.mutual_inductive_entry = inductive types. The set of monomorphic constraints is already part of the graph at that point, but we need to emulate a broken bound variable mechanism for template inductive types. *) - let fold accu ind = match ind.mind_arity with - | RegularArity _ -> accu - | TemplateArity ar -> - match accu with - | None -> Some ar.template_context - | Some ctx -> - (* Ensure that all template contexts agree. This is enforced by the - kernel. *) - let () = check mind "mind_arity" (ContextSet.equal ctx ar.template_context) in - Some ctx - in - let univs = match Array.fold_left fold None mb.mind_packets with + let univs = match mb.mind_template with | None -> ContextSet.empty - | Some ctx -> ctx + | Some ctx -> ctx.template_context in Monomorphic_entry univs | Polymorphic auctx -> Polymorphic_entry (AUContext.names auctx, AUContext.repr auctx) in let mind_entry_inds = Array.map_to_list (fun ind -> - let mind_entry_arity, mind_entry_template = match ind.mind_arity with + let mind_entry_arity = match ind.mind_arity with | RegularArity ar -> let ctx, arity = Term.decompose_prod_n_assum nparams ar.mind_user_arity in ignore ctx; (* we will check that the produced user_arity is equal to the input *) - arity, false + arity | TemplateArity ar -> let ctx = ind.mind_arity_ctxt in let ctx = List.firstn (List.length ctx - nparams) ctx in - Term.mkArity (ctx, Sorts.sort_of_univ ar.template_level), true + Term.mkArity (ctx, Sorts.sort_of_univ ar.template_level) in { mind_entry_typename = ind.mind_typename; mind_entry_arity; - mind_entry_template; mind_entry_consnames = Array.to_list ind.mind_consnames; mind_entry_lc = Array.map_to_list (fun c -> let ctx, c = Term.decompose_prod_n_assum nparams c in @@ -75,12 +63,19 @@ let to_entry mind (mb:mutual_inductive_body) : Entries.mutual_inductive_entry = }) mb.mind_packets in + let check_template ind = match ind.mind_arity with + | RegularArity _ -> false + | TemplateArity _ -> true + in + let mind_entry_template = Array.exists check_template mb.mind_packets in + let () = if mind_entry_template then assert (Array.for_all check_template mb.mind_packets) in { mind_entry_record; mind_entry_finite = mb.mind_finite; mind_entry_params = mb.mind_params_ctxt; mind_entry_inds; mind_entry_universes; + mind_entry_template; mind_entry_cumulative= Option.has_some mb.mind_variance; mind_entry_private = mb.mind_private; } @@ -89,13 +84,18 @@ let check_arity env ar1 ar2 = match ar1, ar2 with | RegularArity ar, RegularArity {mind_user_arity;mind_sort} -> Constr.equal ar.mind_user_arity mind_user_arity && Sorts.equal ar.mind_sort mind_sort - | TemplateArity ar, TemplateArity {template_param_levels;template_level;template_context} -> - List.equal (Option.equal Univ.Level.equal) ar.template_param_levels template_param_levels && - ContextSet.equal template_context ar.template_context && + | TemplateArity ar, TemplateArity {template_level} -> UGraph.check_leq (universes env) template_level ar.template_level (* template_level is inferred by indtypes, so functor application can produce a smaller one *) | (RegularArity _ | TemplateArity _), _ -> assert false +let check_template ar1 ar2 = match ar1, ar2 with +| None, None -> true +| Some ar, Some {template_context; template_param_levels} -> + List.equal (Option.equal Univ.Level.equal) ar.template_param_levels template_param_levels && + ContextSet.equal template_context ar.template_context +| None, Some _ | Some _, None -> false + let check_kelim k1 k2 = Sorts.family_leq k1 k2 (* Use [eq_ind_chk] because when we rebuild the recargs we have lost @@ -157,10 +157,10 @@ let check_same_record r1 r2 = match r1, r2 with | (NotRecord | FakeRecord | PrimRecord _), _ -> false let check_inductive env mind mb = - let entry = to_entry mind mb in + let entry = to_entry mb in let { mind_packets; mind_record; mind_finite; mind_ntypes; mind_hyps; mind_nparams; mind_nparams_rec; mind_params_ctxt; - mind_universes; mind_variance; mind_sec_variance; + mind_universes; mind_template; mind_variance; mind_sec_variance; mind_private; mind_typing_flags; } = (* Locally set typing flags for further typechecking *) @@ -191,6 +191,7 @@ let check_inductive env mind mb = check "mind_params_ctxt" (Context.Rel.equal Constr.equal mb.mind_params_ctxt mind_params_ctxt); ignore mind_universes; (* Indtypes did the necessary checking *) + check "mind_template" (check_template mb.mind_template mind_template); check "mind_variance" (Option.equal (Array.equal Univ.Variance.equal) mb.mind_variance mind_variance); check "mind_sec_variance" (Option.is_empty mind_sec_variance); diff --git a/checker/checkTypes.mli b/checker/checkTypes.mli index ac9ea2fb31..9ef6ff017c 100644 --- a/checker/checkTypes.mli +++ b/checker/checkTypes.mli @@ -17,4 +17,4 @@ open Environ (*s Typing functions (not yet tagged as safe) *) val check_polymorphic_arity : - env -> rel_context -> template_arity -> unit + env -> rel_context -> template_universes -> unit diff --git a/checker/values.ml b/checker/values.ml index ed730cff8e..cba96e6636 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -227,8 +227,11 @@ let v_oracle = v_pred v_cst; |] -let v_pol_arity = - v_tuple "polymorphic_arity" [|List(Opt v_level);v_univ;v_context_set|] +let v_template_arity = + v_tuple "template_arity" [|v_univ|] + +let v_template_universes = + v_tuple "template_universes" [|List(Opt v_level);v_context_set|] let v_primitive = v_enum "primitive" 44 (* Number of "Primitive" in Int63.v and PrimFloat.v *) @@ -265,7 +268,7 @@ let v_mono_ind_arity = v_tuple "monomorphic_inductive_arity" [|v_constr;v_sort|] let v_ind_arity = v_sum "inductive_arity" 0 - [|[|v_mono_ind_arity|];[|v_pol_arity|]|] + [|[|v_mono_ind_arity|];[|v_template_arity|]|] let v_one_ind = v_tuple "one_inductive_body" [|v_id; @@ -301,6 +304,7 @@ let v_ind_pack = v_tuple "mutual_inductive_body" Int; v_rctxt; v_univs; (* universes *) + Opt v_template_universes; Opt (Array v_variance); Opt (Array v_variance); Opt v_bool; diff --git a/clib/cStack.ml b/clib/cStack.ml deleted file mode 100644 index 0432e29fad..0000000000 --- a/clib/cStack.ml +++ /dev/null @@ -1,44 +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) *) -(************************************************************************) - -exception Empty = Stack.Empty - -type 'a t = { - mutable stack : 'a list; -} - -let create () = { stack = [] } - -let push x s = s.stack <- x :: s.stack - -let pop = function - | { stack = [] } -> raise Stack.Empty - | { stack = x::xs } as s -> s.stack <- xs; x - -let top = function - | { stack = [] } -> raise Stack.Empty - | { stack = x::_ } -> x - -let to_list { stack = s } = s - -let find f s = List.find f (to_list s) - -let find_map f s = CList.find_map f s.stack - -let fold_until f accu s = CList.fold_left_until f accu s.stack - -let is_empty { stack = s } = s = [] - -let iter f { stack = s } = List.iter f s - -let clear s = s.stack <- [] - -let length { stack = s } = List.length s - diff --git a/clib/cStack.mli b/clib/cStack.mli deleted file mode 100644 index de802160e7..0000000000 --- a/clib/cStack.mli +++ /dev/null @@ -1,58 +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) *) -(************************************************************************) - -(** Extended interface for OCaml stacks. *) - -type 'a t - -exception Empty -(** Alias for Stack.Empty. *) - -val create : unit -> 'a t -(** Create an empty stack. *) - -val push : 'a -> 'a t -> unit -(** Add an element to a stack. *) - -val find : ('a -> bool) -> 'a t -> 'a -(** Find the first element satisfying the predicate. - @raise Not_found it there is none. *) - -val is_empty : 'a t -> bool -(** Whether a stack is empty. *) - -val iter : ('a -> unit) -> 'a t -> unit -(** Iterate a function over elements, from the last added one. *) - -val clear : 'a t -> unit -(** Empty a stack. *) - -val length : 'a t -> int -(** Length of a stack. *) - -val pop : 'a t -> 'a -(** Remove and returns the first element of the stack. - @raise Empty if empty. *) - -val top : 'a t -> 'a -(** Remove the first element of the stack without modifying it. - @raise Empty if empty. *) - -val to_list : 'a t -> 'a list -(** Convert to a list. *) - -val find_map : ('a -> 'b option) -> 'a t -> 'b -(** Find the first element that returns [Some _]. - @raise Not_found it there is none. *) - -val fold_until : ('c -> 'a -> 'c CSig.until) -> 'c -> 'a t -> 'c -(** Like CList.fold_left_until. - The stack is traversed from the top and is not altered. *) - diff --git a/clib/clib.mllib b/clib/clib.mllib index 5a2c9a9ce9..be3b5971be 100644 --- a/clib/clib.mllib +++ b/clib/clib.mllib @@ -9,7 +9,6 @@ CSet CMap CList CString -CStack Int Range @@ -33,7 +32,6 @@ Unionfind Dyn Store Exninfo -Backtrace IStream Terminal Monad diff --git a/config/dune b/config/dune index 5f2f7b1222..bf1aa4f471 100644 --- a/config/dune +++ b/config/dune @@ -13,5 +13,7 @@ %{project_root}/configure.ml %{project_root}/dev/ocamldebug-coq.run %{project_root}/dev/header.c + ; Needed to generate include lists for coq_makefile + (source_tree %{project_root}/plugins) (env_var COQ_CONFIGURE_PREFIX)) (action (chdir %{project_root} (run %{ocaml} configure.ml -no-ask -native-compiler no)))) diff --git a/coqpp/dune b/coqpp/dune index 12071c7c05..d4b49301fb 100644 --- a/coqpp/dune +++ b/coqpp/dune @@ -1,9 +1,15 @@ (ocamllex coqpp_lex) (ocamlyacc coqpp_parse) +(library + (name coqpp) + (wrapped false) + (modules coqpp_ast coqpp_lex coqpp_parse coqpp_parser) + (modules_without_implementation coqpp_ast)) + (executable (name coqpp_main) (public_name coqpp) (package coq) - (modules coqpp_ast coqpp_lex coqpp_parse coqpp_parser coqpp_main) - (modules_without_implementation coqpp_ast)) + (libraries coqpp) + (modules coqpp_main)) diff --git a/default.nix b/default.nix index ae6a8d06e5..841bccb129 100644 --- a/default.nix +++ b/default.nix @@ -22,7 +22,7 @@ # a symlink to where Coq was installed. { pkgs ? import ./dev/nixpkgs.nix {} -, ocamlPackages ? pkgs.ocamlPackages +, ocamlPackages ? pkgs.ocaml-ng.ocamlPackages_4_09 , buildIde ? true , buildDoc ? true , doInstallCheck ? true diff --git a/dev/build/osx/make-macos-dmg.sh b/dev/build/osx/make-macos-dmg.sh index 3a096fec06..35d0379008 100755 --- a/dev/build/osx/make-macos-dmg.sh +++ b/dev/build/osx/make-macos-dmg.sh @@ -24,4 +24,14 @@ mkdir -p _build # Temporary countermeasure to hdiutil error 5341 # head -c9703424 /dev/urandom > $DMGDIR/.padding -hdiutil create -imagekey zlib-level=9 -volname "coq-$VERSION-installer-macos" -srcfolder "$DMGDIR" -ov -format UDZO "_build/coq-$VERSION-installer-macos.dmg" +hdi_opts=(-volname "coq-$VERSION-installer-macos" + -srcfolder "$DMGDIR" + -ov # overwrite existing file + -format UDZO + -imagekey "zlib-level=9" + + # needed for backward compat since macOS 10.14 which uses APFS by default + # see discussion in #11803 + -fs hfs+ + ) +hdiutil create "${hdi_opts[@]}" "_build/coq-$VERSION-installer-macos.dmg" diff --git a/dev/ci/README-users.md b/dev/ci/README-users.md index 6649820f22..994ff87674 100644 --- a/dev/ci/README-users.md +++ b/dev/ci/README-users.md @@ -105,5 +105,10 @@ images for testing against Coq master. Using these images is highly recommended: - For Docker, see: https://github.com/coq-community/docker-coq + + The https://github.com/coq-community/docker-coq/wiki/CI-setup wiki + page contains additional information and templates to help setting + Docker-based CI up for your Coq project + - For Nix, see the setup at https://github.com/coq-community/manifesto/wiki/Continuous-Integration-with-Nix diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 60c266699c..bd7ee46358 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -214,12 +214,16 @@ : "${equations_CI_ARCHIVEURL:=${equations_CI_GITURL}/archive}" ######################################################################## -# Elpi +# Elpi + Hierarchy Builder ######################################################################## : "${elpi_CI_REF:=coq-master}" : "${elpi_CI_GITURL:=https://github.com/LPCIC/coq-elpi}" : "${elpi_CI_ARCHIVEURL:=${elpi_CI_GITURL}/archive}" +: "${elpi_hb_CI_REF:=coq-master}" +: "${elpi_hb_CI_GITURL:=https://github.com/math-comp/hierarchy-builder}" +: "${elpi_hb_CI_ARCHIVEURL:=${elpi_hb_CI_GITURL}/archive}" + ######################################################################## # fcsl-pcm ######################################################################## diff --git a/dev/ci/ci-common.sh b/dev/ci/ci-common.sh index 7aa265cf90..f0dbe485f7 100644 --- a/dev/ci/ci-common.sh +++ b/dev/ci/ci-common.sh @@ -19,7 +19,7 @@ then elif [ -d "$PWD/_build/install/default/" ]; then # Dune build - export OCAMLPATH="$PWD/_build/install/default/lib/" + export OCAMLPATH="$PWD/_build/install/default/lib/:$OCAMLPATH" export COQBIN="$PWD/_build/install/default/bin" export COQLIB="$PWD/_build/install/default/lib/coq" CI_BRANCH="$(git rev-parse --abbrev-ref HEAD)" diff --git a/dev/ci/ci-elpi.sh b/dev/ci/ci-elpi.sh index d60bf34ba2..4f185db813 100755 --- a/dev/ci/ci-elpi.sh +++ b/dev/ci/ci-elpi.sh @@ -6,3 +6,7 @@ ci_dir="$(dirname "$0")" git_download elpi ( cd "${CI_BUILD_DIR}/elpi" && make && make install ) + +git_download elpi_hb + +( cd "${CI_BUILD_DIR}/elpi_hb" && make && make install ) diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index 41392b4b8c..979b5917d4 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -1,4 +1,4 @@ -# CACHEKEY: "bionic_coq-V2019-03-01-V43" +# CACHEKEY: "bionic_coq-V2019-03-14-V14" # ^^ Update when modifying this file. FROM ubuntu:bionic @@ -37,12 +37,12 @@ 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.1 dune.2.0.1 ounit.2.0.8 odoc.1.4.2" \ +ENV BASE_OPAM="num ocamlfind.1.8.1 dune.2.0.1 ounit.2.2.2 odoc.1.5.0" \ CI_OPAM="menhir.20190626 ocamlgraph.1.8.8" \ BASE_ONLY_OPAM="elpi.1.10.2" # BASE switch; CI_OPAM contains Coq's CI dependencies. -ENV COQIDE_OPAM="cairo2.0.6.1 lablgtk3-sourceview3.3.0.beta6" +ENV COQIDE_OPAM="cairo2.0.6.1 lablgtk3-sourceview3.3.1.0" # Must add this to COQIDE_OPAM{,_EDGE} when we update the opam # packages "lablgtk3-gtksourceview3" @@ -57,12 +57,11 @@ RUN opam switch create "${COMPILER}+32bit" && eval $(opam env) && \ # EDGE switch ENV COMPILER_EDGE="4.09.0" \ - COQIDE_OPAM_EDGE="cairo2.0.6.1 lablgtk3-sourceview3.3.0.beta6" \ BASE_OPAM_EDGE="dune-release.1.3.3 ocamlformat.0.12" # EDGE+flambda switch, we install CI_OPAM as to be able to use # `ci-template-flambda` with everything. RUN opam switch create "${COMPILER_EDGE}+flambda" && eval $(opam env) && \ - opam install $BASE_OPAM $BASE_OPAM_EDGE $COQIDE_OPAM_EDGE $CI_OPAM + opam install $BASE_OPAM $BASE_OPAM_EDGE $COQIDE_OPAM $CI_OPAM RUN opam clean -a -c diff --git a/dev/ci/user-overlays/08726-herbelin-master+more-stable-meaning-to-Discharge-flag.sh b/dev/ci/user-overlays/08726-herbelin-master+more-stable-meaning-to-Discharge-flag.sh deleted file mode 100644 index 242b177d71..0000000000 --- a/dev/ci/user-overlays/08726-herbelin-master+more-stable-meaning-to-Discharge-flag.sh +++ /dev/null @@ -1,23 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "8726" ] || [ "$CI_BRANCH" = "master+more-stable-meaning-to-Discharge-flag" ]; then - - fiat_parsers_CI_BRANCH=master+change-for-coq-pr8726 - fiat_parsers_CI_REF=master+change-for-coq-pr8726 - fiat_parsers_CI_GITURL=https://github.com/herbelin/fiat - - elpi_CI_BRANCH=coq-master+fix-global-pr8726 - elpi_CI_REF=coq-master+fix-global-pr8726 - elpi_CI_GITURL=https://github.com/herbelin/coq-elpi - - equations_CI_BRANCH=master+fix-global-pr8726 - equations_CI_REF=master+fix-global-pr8726 - equations_CI_GITURL=https://github.com/herbelin/Coq-Equations - - mtac2_CI_BRANCH=master+fix-global-pr8726 - mtac2_CI_REF=master+fix-global-pr8726 - mtac2_CI_GITURL=https://github.com/herbelin/Mtac2 - - paramcoq_CI_BRANCH=master+fix-global-pr8726 - paramcoq_CI_REF=master+fix-global-pr8726 - paramcoq_CI_GITURL=https://github.com/herbelin/paramcoq - -fi diff --git a/dev/ci/user-overlays/09566-ejgallego-proof_global+move_termination_routine_out.sh b/dev/ci/user-overlays/09566-ejgallego-proof_global+move_termination_routine_out.sh deleted file mode 100644 index e4cf74aa51..0000000000 --- a/dev/ci/user-overlays/09566-ejgallego-proof_global+move_termination_routine_out.sh +++ /dev/null @@ -1,12 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9566" ] || [ "$CI_BRANCH" = "proof_global+move_termination_routine_out" ]; then - - aac_tactics_CI_REF=proof_global+move_termination_routine_out - aac_tactics_CI_GITURL=https://github.com/ejgallego/aac-tactics - - equations_CI_REF=proof_global+move_termination_routine_out - equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations - - paramcoq_CI_REF=proof_global+move_termination_routine_out - paramcoq_CI_GITURL=https://github.com/ejgallego/paramcoq - -fi diff --git a/dev/ci/user-overlays/09645-ejgallego-proof+sayonara_baby.sh b/dev/ci/user-overlays/09645-ejgallego-proof+sayonara_baby.sh deleted file mode 100644 index 3029f3019c..0000000000 --- a/dev/ci/user-overlays/09645-ejgallego-proof+sayonara_baby.sh +++ /dev/null @@ -1,12 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9645" ] || [ "$CI_BRANCH" = "proof+sayonara_baby" ]; then - - equations_CI_REF=proof+sayonara_baby - equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations - - mtac2_CI_REF=proof+sayonara_baby - mtac2_CI_GITURL=https://github.com/ejgallego/Mtac2 - - paramcoq_CI_REF=proof+sayonara_baby - paramcoq_CI_GITURL=https://github.com/ejgallego/paramcoq - -fi diff --git a/dev/ci/user-overlays/09867-primitive-floats.sh b/dev/ci/user-overlays/09867-primitive-floats.sh deleted file mode 100644 index a0e9085afd..0000000000 --- a/dev/ci/user-overlays/09867-primitive-floats.sh +++ /dev/null @@ -1,12 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9867" ] || [ "$CI_BRANCH" = "primitive-floats" ]; then - - unicoq_CI_REF=primitive-floats - unicoq_CI_GITURL=https://github.com/validsdp/unicoq - - elpi_CI_REF=primitive-floats - elpi_CI_GITURL=https://github.com/validsdp/coq-elpi - - coqhammer_CI_REF=primitive-floats - coqhammer_CI_GITURL=https://github.com/validsdp/coqhammer - -fi diff --git a/dev/ci/user-overlays/10204-rm-unsafe-type-of-coercion.sh b/dev/ci/user-overlays/10204-rm-unsafe-type-of-coercion.sh deleted file mode 100644 index 87dad61dbc..0000000000 --- a/dev/ci/user-overlays/10204-rm-unsafe-type-of-coercion.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10204" ] || [ "$CI_BRANCH" = "rm-unsafe-type-of-coercion" ]; then - - paramcoq_CI_REF=fix-papp - paramcoq_CI_GITURL=https://github.com/maximedenes/paramcoq - -fi diff --git a/dev/ci/user-overlays/10231-herbelin-master+locating-warning-different-implicit-term-type.sh b/dev/ci/user-overlays/10231-herbelin-master+locating-warning-different-implicit-term-type.sh deleted file mode 100644 index c8cf85e73e..0000000000 --- a/dev/ci/user-overlays/10231-herbelin-master+locating-warning-different-implicit-term-type.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10231" ] || [ "$CI_BRANCH" = "master+locating-warning-different-implicit-term-type" ]; then - - equations_CI_REF=master+fix-manual-implicit-pr10231 - equations_CI_GITURL=https://github.com/herbelin/Coq-Equations - - mtac2_CI_REF=master+fix-manual-implicit-pr10231 - mtac2_CI_GITURL=https://github.com/herbelin/Mtac2 - -fi diff --git a/dev/ci/user-overlays/10316-ejgallego-proof+recthms.sh b/dev/ci/user-overlays/10316-ejgallego-proof+recthms.sh deleted file mode 100644 index d133bc9993..0000000000 --- a/dev/ci/user-overlays/10316-ejgallego-proof+recthms.sh +++ /dev/null @@ -1,18 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10316" ] || [ "$CI_BRANCH" = "proof+recthms" ]; then - - elpi_CI_REF=proof+recthms - elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi - - equations_CI_REF=proof+recthms - equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations - - mtac2_CI_REF=proof+recthms - mtac2_CI_GITURL=https://github.com/ejgallego/Mtac2 - - paramcoq_CI_REF=proof+recthms - paramcoq_CI_GITURL=https://github.com/ejgallego/paramcoq - - quickchick_CI_REF=proof+recthms - quickchick_CI_GITURL=https://github.com/ejgallego/QuickChick - -fi diff --git a/dev/ci/user-overlays/10319-SkySkimmer-vernac-when-sideff.sh b/dev/ci/user-overlays/10319-SkySkimmer-vernac-when-sideff.sh deleted file mode 100644 index c5f1510357..0000000000 --- a/dev/ci/user-overlays/10319-SkySkimmer-vernac-when-sideff.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10319" ] || [ "$CI_BRANCH" = "vernac-when-sideff" ]; then - - mtac2_CI_REF=vernac-when-sideff - mtac2_CI_GITURL=https://github.com/SkySkimmer/Mtac2 - - equations_CI_REF=vernac-when-sideff - equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/10334-ppedrot-rm-kernel-sideeff-role.sh b/dev/ci/user-overlays/10334-ppedrot-rm-kernel-sideeff-role.sh deleted file mode 100644 index 2c3f490c03..0000000000 --- a/dev/ci/user-overlays/10334-ppedrot-rm-kernel-sideeff-role.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10334" ] || [ "$CI_BRANCH" = "rm-kernel-sideeff-role" ]; then - - equations_CI_REF=rm-kernel-sideeff-role - equations_CI_GITURL=https://github.com/ppedrot/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/10337-ejgallego-vernac+qed_special_case_inject_proof.sh b/dev/ci/user-overlays/10337-ejgallego-vernac+qed_special_case_inject_proof.sh deleted file mode 100644 index 288e14c866..0000000000 --- a/dev/ci/user-overlays/10337-ejgallego-vernac+qed_special_case_inject_proof.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10337" ] || [ "$CI_BRANCH" = "vernac+qed_special_case_inject_proof" ]; then - - paramcoq_CI_REF=vernac+qed_special_case_inject_proof - paramcoq_CI_GITURL=https://github.com/ejgallego/paramcoq - - equations_CI_REF=vernac+qed_special_case_inject_proof - equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/10362-ppedrot-delay-poly-opaque.sh b/dev/ci/user-overlays/10362-ppedrot-delay-poly-opaque.sh deleted file mode 100644 index 735b2ebbc3..0000000000 --- a/dev/ci/user-overlays/10362-ppedrot-delay-poly-opaque.sh +++ /dev/null @@ -1,15 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10362" ] || [ "$CI_BRANCH" = "delay-poly-opaque" ]; then - - paramcoq_CI_REF=delay-poly-opaque - paramcoq_CI_GITURL=https://github.com/ppedrot/paramcoq - - elpi_CI_REF=delay-poly-opaque - elpi_CI_GITURL=https://github.com/ppedrot/coq-elpi - - coqhammer_CI_REF=delay-poly-opaque - coqhammer_CI_GITURL=https://github.com/ppedrot/coqhammer - - coq_dpdgraph_CI_REF=delay-poly-opaque - coq_dpdgraph_CI_GITURL=https://github.com/ppedrot/coq-dpdgraph - -fi diff --git a/dev/ci/user-overlays/10406-ppedrot-desync-entry-proof.sh b/dev/ci/user-overlays/10406-ppedrot-desync-entry-proof.sh deleted file mode 100644 index 3122f953de..0000000000 --- a/dev/ci/user-overlays/10406-ppedrot-desync-entry-proof.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10406" ] || [ "$CI_BRANCH" = "desync-entry-proof" ]; then - - equations_CI_REF=desync-entry-proof - equations_CI_GITURL=https://github.com/ppedrot/Coq-Equations - - quickchick_CI_REF=desync-entry-proof - quickchick_CI_GITURL=https://github.com/ppedrot/QuickChick - -fi diff --git a/dev/ci/user-overlays/10419-ejgallego-heads+test.sh b/dev/ci/user-overlays/10419-ejgallego-heads+test.sh deleted file mode 100644 index 0ec0c3673a..0000000000 --- a/dev/ci/user-overlays/10419-ejgallego-heads+test.sh +++ /dev/null @@ -1,18 +0,0 @@ -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/ci/user-overlays/10434-ejgallego-proof+hook_record.sh b/dev/ci/user-overlays/10434-ejgallego-proof+hook_record.sh deleted file mode 100644 index 3a2f4e1001..0000000000 --- a/dev/ci/user-overlays/10434-ejgallego-proof+hook_record.sh +++ /dev/null @@ -1,12 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10434" ] || [ "$CI_BRANCH" = "proof+hook_record" ]; then - - equations_CI_REF=proof+hook_record - equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations - - mtac2_CI_REF=proof+hook_record - mtac2_CI_GITURL=https://github.com/ejgallego/Mtac2 - - paramcoq_CI_REF=proof+hook_record - paramcoq_CI_GITURL=https://github.com/ejgallego/paramcoq - -fi diff --git a/dev/ci/user-overlays/10441-ppedrot-static-poly-section.sh b/dev/ci/user-overlays/10441-ppedrot-static-poly-section.sh deleted file mode 100644 index 00f544f894..0000000000 --- a/dev/ci/user-overlays/10441-ppedrot-static-poly-section.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10441" ] || [ "$CI_BRANCH" = "static-poly-section" ]; then - - ext_lib_CI_REF=static-poly-section - ext_lib_CI_GITURL=https://github.com/ppedrot/coq-ext-lib - -fi diff --git a/dev/ci/user-overlays/10476-maximedenes-rm-library-optim.sh b/dev/ci/user-overlays/10476-maximedenes-rm-library-optim.sh deleted file mode 100644 index 10526a9ffe..0000000000 --- a/dev/ci/user-overlays/10476-maximedenes-rm-library-optim.sh +++ /dev/null @@ -1,10 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10476" ] || [ "$CI_BRANCH" = "rm-library-optim" ]; then - - sf_lf_CI_TARURL=https://www.maximedenes.fr/download/lf.tgz - sf_plf_CI_TARURL=https://www.maximedenes.fr/download/plf.tgz - sf_vfa_CI_TARURL=https://www.maximedenes.fr/download/vfa.tgz - - vst_CI_REF=fix-export - vst_CI_GITURL=https://github.com/maximedenes/VST - -fi diff --git a/dev/ci/user-overlays/10516-ejgallego-proof+dup_save.sh b/dev/ci/user-overlays/10516-ejgallego-proof+dup_save.sh deleted file mode 100644 index 7001c3d0c8..0000000000 --- a/dev/ci/user-overlays/10516-ejgallego-proof+dup_save.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10516" ] || [ "$CI_BRANCH" = "proof+dup_save" ]; then - - elpi_CI_REF=proof+dup_save - elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi - -fi diff --git a/dev/ci/user-overlays/10642-SkySkimmer-feedback-added-axiom.sh b/dev/ci/user-overlays/10642-SkySkimmer-feedback-added-axiom.sh deleted file mode 100644 index 413805e8e9..0000000000 --- a/dev/ci/user-overlays/10642-SkySkimmer-feedback-added-axiom.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10642" ] || [ "$CI_BRANCH" = "feedback-added-axiom" ]; then - - elpi_CI_REF=feedback-added-axiom - elpi_CI_GITURL=https://github.com/SkySkimmer/coq-elpi - -fi diff --git a/dev/ci/user-overlays/10660-ejgallego-errors+private.sh b/dev/ci/user-overlays/10660-ejgallego-errors+private.sh deleted file mode 100644 index 21ff60493b..0000000000 --- a/dev/ci/user-overlays/10660-ejgallego-errors+private.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10660" ] || [ "$CI_BRANCH" = "errors+private" ]; then - - coqhammer_CI_REF=errors+private - coqhammer_CI_GITURL=https://github.com/ejgallego/coqhammer - -fi diff --git a/dev/ci/user-overlays/10665-ejgallego-api+varkind.sh b/dev/ci/user-overlays/10665-ejgallego-api+varkind.sh deleted file mode 100644 index 0c47f6a60b..0000000000 --- a/dev/ci/user-overlays/10665-ejgallego-api+varkind.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10665" ] || [ "$CI_BRANCH" = "api+varkind" ]; then - - elpi_CI_REF=api+varkind - elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi - - quickchick_CI_REF=api+varkind - quickchick_CI_GITURL=https://github.com/ejgallego/QuickChick - -fi diff --git a/dev/ci/user-overlays/10674-ejgallego-proofs+declare_unif.sh b/dev/ci/user-overlays/10674-ejgallego-proofs+declare_unif.sh deleted file mode 100644 index 6dc44aa627..0000000000 --- a/dev/ci/user-overlays/10674-ejgallego-proofs+declare_unif.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10674" ] || [ "$CI_BRANCH" = "proofs+declare_unif" ]; then - - equations_CI_REF=proofs+declare_unif - equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/10681-ejgallego-proof+private_entry.sh b/dev/ci/user-overlays/10681-ejgallego-proof+private_entry.sh deleted file mode 100644 index f4840c2a83..0000000000 --- a/dev/ci/user-overlays/10681-ejgallego-proof+private_entry.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10681" ] || [ "$CI_BRANCH" = "proof+private_entry" ]; then - - equations_CI_REF=proof+private_entry - equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/10727-ejgallego-library+to_vernac_step2.sh b/dev/ci/user-overlays/10727-ejgallego-library+to_vernac_step2.sh deleted file mode 100644 index a5f6551474..0000000000 --- a/dev/ci/user-overlays/10727-ejgallego-library+to_vernac_step2.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10727" ] || [ "$CI_BRANCH" = "library+to_vernac_step2" ]; then - - elpi_CI_REF=library+to_vernac_step2 - elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi - -fi diff --git a/dev/ci/user-overlays/10811-SkySkimmer-sprop-default-on.sh b/dev/ci/user-overlays/10811-SkySkimmer-sprop-default-on.sh deleted file mode 100644 index d7af6b7a36..0000000000 --- a/dev/ci/user-overlays/10811-SkySkimmer-sprop-default-on.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10811" ] || [ "$CI_BRANCH" = "sprop-default-on" ]; then - - elpi_CI_REF=sprop-default-on - elpi_CI_GITURL=https://github.com/SkySkimmer/coq-elpi - - coq_dpdgraph_CI_REF=sprop-default-on - coq_dpdgraph_CI_GITURL=https://github.com/SkySkimmer/coq-dpdgraph - -fi diff --git a/dev/ci/user-overlays/10832-herbelin-master+fix6082-7766-overriding-notation-format.sh b/dev/ci/user-overlays/10832-herbelin-master+fix6082-7766-overriding-notation-format.sh deleted file mode 100644 index c17fe4fcba..0000000000 --- a/dev/ci/user-overlays/10832-herbelin-master+fix6082-7766-overriding-notation-format.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10832" ] || [ "$CI_BRANCH" = "master+fix6082-7766-overriding-notation-format" ]; then - - equations_CI_REF=master+fix-interpretation-notation-format-pr10832 - equations_CI_GITURL=https://github.com/herbelin/Coq-Equations - - quickchick_CI_REF=master+fix-interpretation-notation-format-pr10832 - quickchick_CI_GITURL=https://github.com/herbelin/QuickChick - -fi diff --git a/dev/ci/user-overlays/11027-SkySkimmer-expose-comind-univ.sh b/dev/ci/user-overlays/11027-SkySkimmer-expose-comind-univ.sh deleted file mode 100644 index bb65beb043..0000000000 --- a/dev/ci/user-overlays/11027-SkySkimmer-expose-comind-univ.sh +++ /dev/null @@ -1,19 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "11027" ] || [ "$CI_BRANCH" = "cleanup-comind-univ" ]; then - - elpi_CI_REF=expose-comind-univ - elpi_CI_GITURL=https://github.com/SkySkimmer/coq-elpi - - equations_CI_REF=expose-comind-univ - equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations - - paramcoq_CI_REF=expose-comind-univ - paramcoq_CI_GITURL=https://github.com/SkySkimmer/paramcoq - - mtac2_CI_REF=expose-comind-univ - mtac2_CI_GITURL=https://github.com/SkySkimmer/Mtac2 - - rewriter_CI_REF=cleanup-comind-univ - rewriter_CI_GITURL=https://github.com/SkySkimmer/rewriter - - -fi diff --git a/dev/ci/user-overlays/11141-herbelin-master+labelled-pr_lconstr-and-co.sh b/dev/ci/user-overlays/11141-herbelin-master+labelled-pr_lconstr-and-co.sh deleted file mode 100644 index fb66217487..0000000000 --- a/dev/ci/user-overlays/11141-herbelin-master+labelled-pr_lconstr-and-co.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "11141" ] || [ "$CI_BRANCH" = "master+labelled-pr_lconstr-and-co" ]; then - - quickchick_CI_REF=master+adapt-coq-pr11141 - quickchick_CI_GITURL=https://github.com/herbelin/QuickChick - -fi diff --git a/dev/ci/user-overlays/11172-herbelin-master+coercion-notation-interleaved-printing.sh b/dev/ci/user-overlays/11172-herbelin-master+coercion-notation-interleaved-printing.sh deleted file mode 100644 index e0d9dc6469..0000000000 --- a/dev/ci/user-overlays/11172-herbelin-master+coercion-notation-interleaved-printing.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "11172" ] || [ "$CI_BRANCH" = "master+coercion-notation-interleaved-printing" ]; then - - elpi_CI_REF=coq-master+mini-fix-mkGApp - elpi_CI_GITURL=https://github.com/herbelin/coq-elpi - -fi diff --git a/dev/ci/user-overlays/11235-non-maximal-implicit.sh b/dev/ci/user-overlays/11235-non-maximal-implicit.sh deleted file mode 100644 index fd63980036..0000000000 --- a/dev/ci/user-overlays/11235-non-maximal-implicit.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "11235" ] || [ "$CI_BRANCH" = "non-maximal-implicit" ]; then - - quickchick_CI_REF=non_maximal_implicit - quickchick_CI_GITURL=https://github.com/SimonBoulier/QuickChick - - elpi_CI_REF=non_maximal_implicit - elpi_CI_GITURL=https://github.com/SimonBoulier/coq-elpi - -fi diff --git a/dev/ci/user-overlays/11293-ppedrot-rename-class-files.sh b/dev/ci/user-overlays/11293-ppedrot-rename-class-files.sh deleted file mode 100644 index a95170a455..0000000000 --- a/dev/ci/user-overlays/11293-ppedrot-rename-class-files.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "11293" ] || [ "$CI_BRANCH" = "rename-class-files" ]; then - - elpi_CI_REF=rename-class-files - elpi_CI_GITURL=https://github.com/ppedrot/coq-elpi - - mtac2_CI_REF=rename-class-files - mtac2_CI_GITURL=https://github.com/ppedrot/Mtac2 - -fi diff --git a/dev/ci/user-overlays/11338-ppedrot-rm-global-uses-evd.sh b/dev/ci/user-overlays/11338-ppedrot-rm-global-uses-evd.sh deleted file mode 100644 index f41271804a..0000000000 --- a/dev/ci/user-overlays/11338-ppedrot-rm-global-uses-evd.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "11338" ] || [ "$CI_BRANCH" = "rm-global-uses-evd" ]; then - - unicoq_CI_REF=rm-global-uses-evd - unicoq_CI_GITURL=https://github.com/ppedrot/unicoq - - equations_CI_REF=rm-global-uses-evd - equations_CI_GITURL=https://github.com/ppedrot/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/11368-trailing-implicit-error.sh b/dev/ci/user-overlays/11368-trailing-implicit-error.sh deleted file mode 100644 index a125337dd9..0000000000 --- a/dev/ci/user-overlays/11368-trailing-implicit-error.sh +++ /dev/null @@ -1,33 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "11368" ] || [ "$CI_BRANCH" = "trailing_implicit_error" ]; then - - mathcomp_CI_REF=non_maximal_implicit - mathcomp_CI_GITURL=https://github.com/SimonBoulier/math-comp - - oddorder_CI_REF=non_maximal_implicit - oddorder_CI_GITURL=https://github.com/SimonBoulier/odd-order - - stdlib2_CI_REF=non_maximal_implicit - stdlib2_CI_GITURL=https://github.com/SimonBoulier/stdlib2 - - coq_dpdgraph_CI_REF=non_maximal_implicit - coq_dpdgraph_CI_GITURL=https://github.com/SimonBoulier/coq-dpdgraph - - vst_CI_REF=non_maximal_implicit - vst_CI_GITURL=https://github.com/SimonBoulier/VST - - equations_CI_REF=non_maximal_implicit - equations_CI_GITURL=https://github.com/SimonBoulier/Coq-Equations - - mtac2_CI_REF=non_maximal_implicit - mtac2_CI_GITURL=https://github.com/SimonBoulier/Mtac2 - - relation_algebra_CI_REF=non_maximal_implicit - relation_algebra_CI_GITURL=https://github.com/SimonBoulier/relation-algebra - - fiat_parsers_CI_REF=non_maximal_implicit - fiat_parsers_CI_GITURL=https://github.com/SimonBoulier/fiat - - Corn_CI_REF=non_maximal_implicit - Corn_CI_GITURL=https://github.com/SimonBoulier/corn - -fi diff --git a/dev/ci/user-overlays/11417-ppedrot-rm-kind-of-type.sh b/dev/ci/user-overlays/11417-ppedrot-rm-kind-of-type.sh deleted file mode 100644 index 5fb29e1826..0000000000 --- a/dev/ci/user-overlays/11417-ppedrot-rm-kind-of-type.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "11417" ] || [ "$CI_BRANCH" = "rm-kind-of-type" ]; then - - elpi_CI_REF=rm-kind-of-type - elpi_CI_GITURL=https://github.com/ppedrot/coq-elpi - -fi diff --git a/dev/ci/user-overlays/11521-SkySkimmer-no-optname.sh b/dev/ci/user-overlays/11521-SkySkimmer-no-optname.sh deleted file mode 100644 index f2a431978d..0000000000 --- a/dev/ci/user-overlays/11521-SkySkimmer-no-optname.sh +++ /dev/null @@ -1,15 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "11521" ] || [ "$CI_BRANCH" = "no-optname" ]; then - - coqhammer_CI_REF=no-optname - coqhammer_CI_GITURL=https://github.com/SkySkimmer/coqhammer - - equations_CI_REF=no-optname - equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations - - unicoq_CI_REF=no-optname - unicoq_CI_GITURL=https://github.com/SkySkimmer/unicoq - - paramcoq_CI_REF=no-optname - paramcoq_CI_GITURL=https://github.com/SkySkimmer/paramcoq - -fi diff --git a/dev/ci/user-overlays/11557-SkySkimmer-template-directify.sh b/dev/ci/user-overlays/11557-SkySkimmer-template-directify.sh deleted file mode 100644 index 913b39c30c..0000000000 --- a/dev/ci/user-overlays/11557-SkySkimmer-template-directify.sh +++ /dev/null @@ -1,12 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "11557" ] || [ "$CI_BRANCH" = "template-directify" ]; then - - equations_CI_REF=template-directify - equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations - - paramcoq_CI_REF=template-directify - paramcoq_CI_GITURL=https://github.com/SkySkimmer/paramcoq - - elpi_CI_REF=template-directify - elpi_CI_GITURL=https://github.com/SkySkimmer/coq-elpi - -fi diff --git a/dev/ci/user-overlays/11708-gares-elpi-1.10.sh b/dev/ci/user-overlays/11708-gares-elpi-1.10.sh deleted file mode 100644 index 121190e5f6..0000000000 --- a/dev/ci/user-overlays/11708-gares-elpi-1.10.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "11708" ] || [ "$CI_BRANCH" = " elpi-1.10+coq-elpi-1.3" ]; then - - elpi_CI_REF="coq-master+coq-elpi-1.3" - elpi_CI_GITURL=https://github.com/LPCIC/coq-elpi - -fi diff --git a/dev/doc/build-system.dune.md b/dev/doc/build-system.dune.md index 777eec97c6..0506216541 100644 --- a/dev/doc/build-system.dune.md +++ b/dev/doc/build-system.dune.md @@ -125,10 +125,9 @@ dune exec -- dev/dune-dbg checker foo.vo (ocd) source dune_db ``` -Unfortunately, dependency handling here is not fully refined, so you -need to build enough of Coq once to use this target [it will then -correctly compute the deps and rebuild if you call the script again] -This will be fixed in the future. +Unfortunately, dependency handling is not fully refined / automated, +you may find the occasional hiccup due to libraries being renamed, +etc... Please report any issue. For running in emacs, use `coqdev-ocamldebug` from `coqdev.el`. @@ -9,12 +9,34 @@ (rule (targets dune-dbg) - (deps dune-dbg.in - ../checker/coqchk.bc - ../topbin/coqc_bin.bc - ../ide/coqide_main.bc - %{lib:coq.plugins.ltac:ltac_plugin.cma} - ; This is not enough, the call to `ocamlfind` may fail if the - ; META file is not yet in place :/ - top_printers.cma) + (deps + dune-dbg.in + ../checker/coqchk.bc + ../topbin/coqc_bin.bc + ../ide/coqide_main.bc + ; We require all the OCaml libs to be in place and searchable + ; by OCamlfind, this is a bit of a hack but until Dune gets + ; proper ocamldebug support we have to live with that. + %{lib:coq.config:config.cma} + %{lib:coq.clib:clib.cma} + %{lib:coq.lib:lib.cma} + %{lib:coq.kernel:kernel.cma} + %{lib:coq.vm:byterun.cma} + %{lib:coq.vm:../../stublibs/dllbyterun_stubs.so} + %{lib:coq.library:library.cma} + %{lib:coq.engine:engine.cma} + %{lib:coq.pretyping:pretyping.cma} + %{lib:coq.gramlib:gramlib.cma} + %{lib:coq.interp:interp.cma} + %{lib:coq.proofs:proofs.cma} + %{lib:coq.parsing:parsing.cma} + %{lib:coq.printing:printing.cma} + %{lib:coq.tactics:tactics.cma} + %{lib:coq.vernac:vernac.cma} + %{lib:coq.stm:stm.cma} + %{lib:coq.toplevel:toplevel.cma} + %{lib:coq.plugins.ltac:ltac_plugin.cma} + %{lib:coq.top_printers:top_printers.cmi} + %{lib:coq.top_printers:top_printers.cma} + %{lib:coq.top_printers:../META}) (action (copy dune-dbg.in dune-dbg))) diff --git a/dev/nixpkgs.nix b/dev/nixpkgs.nix index 54baaee1fe..b8a696ef21 100644 --- a/dev/nixpkgs.nix +++ b/dev/nixpkgs.nix @@ -1,4 +1,4 @@ import (fetchTarball { - url = "https://github.com/NixOS/nixpkgs/archive/8da81465c19fca393a3b17004c743e4d82a98e4f.tar.gz"; - sha256 = "1f3s27nrssfk413pszjhbs70wpap43bbjx2pf4zq5x2c1kd72l6y"; + url = "https://github.com/NixOS/nixpkgs/archive/34e41a91547e342f6fbc901929134b34000297eb.tar.gz"; + sha256 = "0mlqxim36xg8aj4r35mpcgqg27wy1dbbim9l1cpjl24hcy96v48w"; }) diff --git a/doc/changelog/01-kernel/11811-uncheck_positivity_bug.rst b/doc/changelog/01-kernel/11811-uncheck_positivity_bug.rst new file mode 100644 index 0000000000..c08ebb7f25 --- /dev/null +++ b/doc/changelog/01-kernel/11811-uncheck_positivity_bug.rst @@ -0,0 +1,4 @@ +- **Fixed:** + Allow more inductive types in `Unset Positivity Checking` mode + (`#11811 <https://github.com/coq/coq/pull/11811>`_, + by SimonBoulier). diff --git a/doc/changelog/02-specification-language/10858-stuck-classed.md b/doc/changelog/02-specification-language/10858-stuck-classed.md new file mode 100644 index 0000000000..c7186f2c1d --- /dev/null +++ b/doc/changelog/02-specification-language/10858-stuck-classed.md @@ -0,0 +1,12 @@ +- **Changed:** + Typeclass resolution, accessible through :tacn:`typeclasses eauto`, + now suspends constraints according to their modes + instead of failing. If a typeclass constraint does not match + any of the declared modes for its class, the constraint is postponed, and + the proof search continues on other goals. Proof search does a fixed point + computation to try to solve them at a later stage of resolution. It does + not fail if there remain only stuck constraints at the end of resolution. + This makes typeclasses with declared modes more robust with respect to the + order of resolution. + (`#10858 <https://github.com/coq/coq/pull/10858>`_, + fixes `#9058 <https://github.com/coq/coq/issues/9058>_`, by Matthieu Sozeau). diff --git a/doc/changelog/02-specification-language/11098-master+arguments-supports-anonymous-implicit.rst b/doc/changelog/02-specification-language/11098-master+arguments-supports-anonymous-implicit.rst index 32526babdb..633bb6731e 100644 --- a/doc/changelog/02-specification-language/11098-master+arguments-supports-anonymous-implicit.rst +++ b/doc/changelog/02-specification-language/11098-master+arguments-supports-anonymous-implicit.rst @@ -1,8 +1,8 @@ - **Added:** :cmd:`Arguments <Arguments (implicits)>` now supports setting - implicit an anonymous argument, as e.g. in :g:`Arguments id {A} {_}`. + implicit an anonymous argument, as e.g. in :g:`Arguments id {A} {_}` (`#11098 <https://github.com/coq/coq/pull/11098>`_, by Hugo Herbelin, fixes `#4696 <https://github.com/coq/coq/pull/4696>`_, `#5173 <https://github.com/coq/coq/pull/5173>`_, `#9098 - <https://github.com/coq/coq/pull/9098>`_.). + <https://github.com/coq/coq/pull/9098>`_). diff --git a/doc/changelog/02-specification-language/11368-trailing_implicit_error.rst b/doc/changelog/02-specification-language/11368-trailing_implicit_error.rst index a7ffde31fc..b0e658998b 100644 --- a/doc/changelog/02-specification-language/11368-trailing_implicit_error.rst +++ b/doc/changelog/02-specification-language/11368-trailing_implicit_error.rst @@ -1,6 +1,6 @@ - **Changed:** The warning raised when a trailing implicit is declared to be non maximally - inserted (with the command cmd:`Arguments <Arguments (implicits)>`) has been turned into an error. - This was deprecated since Coq 8.10. + inserted (with the command :cmd:`Arguments <Arguments (implicits)>`) has been turned into an error. + This was deprecated since Coq 8.10 (`#11368 <https://github.com/coq/coq/pull/11368>`_, by SimonBoulier). diff --git a/doc/changelog/02-specification-language/11600-uniform-syntax.rst b/doc/changelog/02-specification-language/11600-uniform-syntax.rst index 3fa3f80301..b95bad2eb8 100644 --- a/doc/changelog/02-specification-language/11600-uniform-syntax.rst +++ b/doc/changelog/02-specification-language/11600-uniform-syntax.rst @@ -1,4 +1,5 @@ - **Added:** New syntax :g:`Inductive Acc A R | x : Prop := ...` to specify which parameters of an inductive are uniform. + See :ref:`parametrized-inductive-types` (`#11600 <https://github.com/coq/coq/pull/11600>`_, by Gaëtan Gilbert). diff --git a/doc/changelog/03-notations/10832-master+fix6082-7766-overriding-notation-format.rst b/doc/changelog/03-notations/10832-master+fix6082-7766-overriding-notation-format.rst index 5393fb3d8c..a8d4fc6ed2 100644 --- a/doc/changelog/03-notations/10832-master+fix6082-7766-overriding-notation-format.rst +++ b/doc/changelog/03-notations/10832-master+fix6082-7766-overriding-notation-format.rst @@ -1 +1,6 @@ -- Different interpretations in different scopes of the same notation string can now be associated to different printing formats; this fixes bug #6092 and #7766 (`#10832 <https://github.com/coq/coq/pull/10832>`_, by Hugo Herbelin). +- **Fixed:** + Different interpretations in different scopes of the same notation + string can now be associated to different printing formats (`#10832 + <https://github.com/coq/coq/pull/10832>`_, by Hugo Herbelin, + fixes `#6092 <https://github.com/coq/coq/issues/6092>`_ + and `#7766 <https://github.com/coq/coq/issues/7766>`_). diff --git a/doc/changelog/03-notations/11602-master+support-only-parsing-where-clause.rst b/doc/changelog/03-notations/11602-master+support-only-parsing-where-clause.rst new file mode 100644 index 0000000000..1d30d16664 --- /dev/null +++ b/doc/changelog/03-notations/11602-master+support-only-parsing-where-clause.rst @@ -0,0 +1,6 @@ +- **Added:** + Notations declared with the ``where`` clause in the declaration of + inductive types, coinductive types, record fields, fixpoints and + cofixpoints now support the ``only parsing`` modifier + (`#11602 <https://github.com/coq/coq/pull/11602>`_, + by Hugo Herbelin). diff --git a/doc/changelog/03-notations/11650-parensNew.rst b/doc/changelog/03-notations/11650-parensNew.rst index 5e2da594c6..f52a720428 100644 --- a/doc/changelog/03-notations/11650-parensNew.rst +++ b/doc/changelog/03-notations/11650-parensNew.rst @@ -1,4 +1,4 @@ - **Added:** - added option Set Printing Parentheses to print parentheses even when implied by associativity or precedence. + added the :flag:`Printing Parentheses` flag to print parentheses even when implied by associativity or precedence. (`#11650 <https://github.com/coq/coq/pull/11650>`_, by Hugo Herbelin and Abhishek Anand). diff --git a/doc/changelog/04-tactics/10760-more-rapply.rst b/doc/changelog/04-tactics/10760-more-rapply.rst index eeae2ec519..32cd9b7135 100644 --- a/doc/changelog/04-tactics/10760-more-rapply.rst +++ b/doc/changelog/04-tactics/10760-more-rapply.rst @@ -4,5 +4,5 @@ rare cases where users were relying on :tacn:`rapply` inserting exactly 15 underscores and no more, due to the lemma having a completely unspecified codomain (and thus allowing for any number of - underscores), the tactic will now instead loop. (`#10760 - <https://github.com/coq/coq/pull/10760>`_, by Jason Gross) + underscores), the tactic will now instead loop (`#10760 + <https://github.com/coq/coq/pull/10760>`_, by Jason Gross). diff --git a/doc/changelog/04-tactics/10998-zify-complements.rst b/doc/changelog/04-tactics/10998-zify-complements.rst index c72d085687..ba4d10590f 100644 --- a/doc/changelog/04-tactics/10998-zify-complements.rst +++ b/doc/changelog/04-tactics/10998-zify-complements.rst @@ -4,5 +4,5 @@ `Z.pred_double`, `Z.succ_double`, `Z.square`, `Z.div2`, and `Z.quot2`. Injections for internal definitions in module `ZifyBool` (`isZero` and `isLeZero`) are also added to help users to declare new :tacn:`zify` class instances using - Micromega tactics. + Micromega tactics (`#10998 <https://github.com/coq/coq/pull/10998>`_, by Kazuhiko Sakaguchi). diff --git a/doc/changelog/04-tactics/11023-nativecompute-timing.rst b/doc/changelog/04-tactics/11023-nativecompute-timing.rst index 2afa3990ac..e8cdfcca21 100644 --- a/doc/changelog/04-tactics/11023-nativecompute-timing.rst +++ b/doc/changelog/04-tactics/11023-nativecompute-timing.rst @@ -3,5 +3,5 @@ compiler) to emit separate timing information about compilation, execution, and reification. It replaces the timing information previously emitted when the `-debug` flag was set, and allows more - fine-grained timing of the native compiler. (`#11023 + fine-grained timing of the native compiler (`#11023 <https://github.com/coq/coq/pull/11023>`_, by Jason Gross). diff --git a/doc/changelog/04-tactics/11288-omega+depr.rst b/doc/changelog/04-tactics/11288-omega+depr.rst index 2832e6db61..3a2d421967 100644 --- a/doc/changelog/04-tactics/11288-omega+depr.rst +++ b/doc/changelog/04-tactics/11288-omega+depr.rst @@ -1,6 +1,6 @@ - **Removed:** The undocumented ``omega with`` tactic variant has been removed, - using ``lia`` is the recommended replacement, tho the old semantics - of ``omega with *`` can be recovered with ``zify; omega`` + using :tacn:`lia` is the recommended replacement, although the old semantics + of ``omega with *`` can also be recovered with ``zify; omega`` (`#11288 <https://github.com/coq/coq/pull/11288>`_, by Emilio Jesus Gallego Arias). diff --git a/doc/changelog/04-tactics/11362-micromega-fix-11191.rst b/doc/changelog/04-tactics/11362-micromega-fix-11191.rst index 5ecd46bced..79879c78d5 100644 --- a/doc/changelog/04-tactics/11362-micromega-fix-11191.rst +++ b/doc/changelog/04-tactics/11362-micromega-fix-11191.rst @@ -1,5 +1,5 @@ - **Fixed:** - Regression of ``lia`` due to more powerful ``zify`` + Regression of :tacn:`lia` due to more powerful :tacn:`zify` (`#11362 <https://github.com/coq/coq/pull/11362>`_, fixes `#11191 <https://github.com/coq/coq/issues/11191>`_, by Frédéric Besson). diff --git a/doc/changelog/04-tactics/11370-zify-elim-let.rst b/doc/changelog/04-tactics/11370-zify-elim-let.rst index 4eb2732106..944dde99b8 100644 --- a/doc/changelog/04-tactics/11370-zify-elim-let.rst +++ b/doc/changelog/04-tactics/11370-zify-elim-let.rst @@ -1,3 +1,3 @@ -- **Changed** - Improve the efficiency of `PreOmega.elim_let` using an iterator implemented in OCaml. +- **Changed:** + Improve the efficiency of `PreOmega.elim_let` using an iterator implemented in OCaml (`#11370 <https://github.com/coq/coq/pull/11370>`_, by Frédéric Besson). diff --git a/doc/changelog/04-tactics/11429-zify-optimisation.rst b/doc/changelog/04-tactics/11429-zify-optimisation.rst new file mode 100644 index 0000000000..25927f9182 --- /dev/null +++ b/doc/changelog/04-tactics/11429-zify-optimisation.rst @@ -0,0 +1,3 @@ +- **Changed:** + Improve the efficiency of :tacn:`zify` by rewritting the remaining Ltac code in OCaml + (`#11429 <https://github.com/coq/coq/pull/11429>`_, by Frédéric Besson). diff --git a/doc/changelog/04-tactics/11474-lia-bug-fix-11436.rst b/doc/changelog/04-tactics/11474-lia-bug-fix-11436.rst index 2a341261e5..52a2b2f0f6 100644 --- a/doc/changelog/04-tactics/11474-lia-bug-fix-11436.rst +++ b/doc/changelog/04-tactics/11474-lia-bug-fix-11436.rst @@ -1,9 +1,9 @@ - **Added:** - :cmd:`Show Lia Profile` prints some statistics about :tacn:`lia` calls. + :cmd:`Show Lia Profile` prints some statistics about :tacn:`lia` calls (`#11474 <https://github.com/coq/coq/pull/11474>`_, by Frédéric Besson). - **Fixed:** - Efficiency regression of ``lia`` + Efficiency regression of :tacn:`lia` (`#11474 <https://github.com/coq/coq/pull/11474>`_, fixes `#11436 <https://github.com/coq/coq/issues/11436>`_, by Frédéric Besson). diff --git a/doc/changelog/04-tactics/11522-master+pose-proof-wo-as-syntax.rst b/doc/changelog/04-tactics/11522-master+pose-proof-wo-as-syntax.rst new file mode 100644 index 0000000000..3dd103b115 --- /dev/null +++ b/doc/changelog/04-tactics/11522-master+pose-proof-wo-as-syntax.rst @@ -0,0 +1,6 @@ +- **Added:** + Syntax :n:`pose proof (@ident:=@term)` as an + alternative to :n:`pose proof @term as @ident`, following the model of + :n:`pose (@ident:=@term)`. See documentation of :tacn:`pose proof` + (`#11522 <https://github.com/coq/coq/pull/11522>`_, + by Hugo Herbelin). diff --git a/doc/changelog/05-tactic-language/10343-issue-10342-ltac2-standard-library.rst b/doc/changelog/05-tactic-language/10343-issue-10342-ltac2-standard-library.rst index 4acc423d10..e8233b9d13 100644 --- a/doc/changelog/05-tactic-language/10343-issue-10342-ltac2-standard-library.rst +++ b/doc/changelog/05-tactic-language/10343-issue-10342-ltac2-standard-library.rst @@ -1,4 +1,4 @@ - **Added:** - An array library for ltac2 (OCaml standard library compatible where possible). + An array library for Ltac2 (as compatible as possible with OCaml standard library) (`#10343 <https://github.com/coq/coq/pull/10343>`_, by Michael Soegtrop). diff --git a/doc/changelog/05-tactic-language/11740-ltac2-enough.rst b/doc/changelog/05-tactic-language/11740-ltac2-enough.rst new file mode 100644 index 0000000000..5d3671bce1 --- /dev/null +++ b/doc/changelog/05-tactic-language/11740-ltac2-enough.rst @@ -0,0 +1,4 @@ +- **Added:** + Ltac2 notations for :tacn:`enough` and :tacn:`eenough` + (`#11740 <https://github.com/coq/coq/pull/11740>`_, + by Michael Soegtrop). diff --git a/doc/changelog/07-commands-and-options/07791-deprecate-hint-constr.rst b/doc/changelog/07-commands-and-options/07791-deprecate-hint-constr.rst new file mode 100644 index 0000000000..b627fdbcc9 --- /dev/null +++ b/doc/changelog/07-commands-and-options/07791-deprecate-hint-constr.rst @@ -0,0 +1,5 @@ +- **Deprecated:** + Deprecated the declaration of arbitrary terms as hints. Global + references are now preferred + (`#7791 <https://github.com/coq/coq/pull/7791>`_, + by Pierre-Marie Pédrot). diff --git a/doc/changelog/07-commands-and-options/10747-canonical-better-message.rst b/doc/changelog/07-commands-and-options/10747-canonical-better-message.rst index e73be9c642..b263de017b 100644 --- a/doc/changelog/07-commands-and-options/10747-canonical-better-message.rst +++ b/doc/changelog/07-commands-and-options/10747-canonical-better-message.rst @@ -1,5 +1,5 @@ - **Changed:** - The :cmd:`Print Canonical Projections` command now can take constants and + The :cmd:`Print Canonical Projections` command can now take constants and prints only the unification rules that involve or are synthesized from given constants (`#10747 <https://github.com/coq/coq/pull/10747>`_, by Kazuhiko Sakaguchi). diff --git a/doc/changelog/07-commands-and-options/11164-let-cs.rst b/doc/changelog/07-commands-and-options/11164-let-cs.rst index ec34c075ae..2bdc8052c6 100644 --- a/doc/changelog/07-commands-and-options/11164-let-cs.rst +++ b/doc/changelog/07-commands-and-options/11164-let-cs.rst @@ -1,3 +1,3 @@ -- **Added:** A section variable introduces with :g:`Let` can be - declared as a :g:`Canonical Structure` (`#11164 +- **Added:** A section variable introduced with :cmd:`Let` can be + declared as a :cmd:`Canonical Structure` (`#11164 <https://github.com/coq/coq/pull/11164>`_, by Enrico Tassi). diff --git a/doc/changelog/07-commands-and-options/11618-loadpath+split_ml_handling.rst b/doc/changelog/07-commands-and-options/11618-loadpath+split_ml_handling.rst new file mode 100644 index 0000000000..99f2d22d11 --- /dev/null +++ b/doc/changelog/07-commands-and-options/11618-loadpath+split_ml_handling.rst @@ -0,0 +1,9 @@ +- **Removed:** + Recursive OCaml loadpaths are not supported anymore; the command + ``Add Rec ML Path`` has been removed; :cmd:`Add ML Path` is now the + preferred one. We have also dropped support for the non-qualified + version of the :cmd:`Add LoadPath` command, that is to say, + the ``Add LoadPath dir`` version; now, + you must always specify a prefix now using ``Add Loadpath dir as Prefix`` + (`#11618 <https://github.com/coq/coq/pull/11618>`_, + by Emilio Jesus Gallego Arias). diff --git a/doc/changelog/07-commands-and-options/11409-mltop+deprecate_use.rst b/doc/changelog/08-tools/11409-mltop+deprecate_use.rst index db433ad64c..f4f110ed67 100644 --- a/doc/changelog/07-commands-and-options/11409-mltop+deprecate_use.rst +++ b/doc/changelog/08-tools/11409-mltop+deprecate_use.rst @@ -1,5 +1,5 @@ - **Removed:** The `-load-ml-source` and `-load-ml-object` command line options have been removed; their use was very limited, you can achieve the same adding - additional object files in the linking step or using a plugin. + additional object files in the linking step or using a plugin (`#11409 <https://github.com/coq/coq/pull/11409>`_, by Emilio Jesus Gallego Arias). diff --git a/doc/changelog/08-tools/11523-coqdep+refactor2.rst b/doc/changelog/08-tools/11523-coqdep+refactor2.rst index 32a4750b73..3f93d60926 100644 --- a/doc/changelog/08-tools/11523-coqdep+refactor2.rst +++ b/doc/changelog/08-tools/11523-coqdep+refactor2.rst @@ -4,7 +4,7 @@ files are not supported as input. Also, several deprecated options have been removed: ``-w``, ``-D``, ``-mldep``, ``-prefix``, ``-slash``, and ``-dumpbox``. Passing ``-boot`` to ``coqdep`` will - not load any path by default now, ``-R/-Q`` should be used instead. + not load any path by default now, ``-R/-Q`` should be used instead (`#11523 <https://github.com/coq/coq/pull/11523>`_ and `#11589 <https://github.com/coq/coq/pull/11589>`_, by Emilio Jesus Gallego Arias). diff --git a/doc/changelog/07-commands-and-options/11617-toplevel+boot.rst b/doc/changelog/08-tools/11617-toplevel+boot.rst index 49dd0ee2d8..49dd0ee2d8 100644 --- a/doc/changelog/07-commands-and-options/11617-toplevel+boot.rst +++ b/doc/changelog/08-tools/11617-toplevel+boot.rst diff --git a/doc/changelog/09-coqide/10008-snyke7+escape_spaces.rst b/doc/changelog/09-coqide/10008-snyke7+escape_spaces.rst index 99b1592fb3..cbd97688c3 100644 --- a/doc/changelog/09-coqide/10008-snyke7+escape_spaces.rst +++ b/doc/changelog/09-coqide/10008-snyke7+escape_spaces.rst @@ -1,4 +1,4 @@ - **Fixed:** - Fix file paths containing spaces when compiling + Compiling file paths containing spaces (`#10008 <https://github.com/coq/coq/pull/10008>`_, by snyke7, fixing `#11595 <https://github.com/coq/coq/pull/11595>`_). diff --git a/doc/changelog/09-coqide/11414-remove-ide-tactic-menu.rst b/doc/changelog/09-coqide/11414-remove-ide-tactic-menu.rst index 6294cdb24a..49ac16eee9 100644 --- a/doc/changelog/09-coqide/11414-remove-ide-tactic-menu.rst +++ b/doc/changelog/09-coqide/11414-remove-ide-tactic-menu.rst @@ -1,4 +1,4 @@ - **Removed:** - Removed the "Tactic" menu from CoqIDE which had been unmaintained for a number of years + "Tactic" menu from CoqIDE which had been unmaintained for a number of years (`#11414 <https://github.com/coq/coq/pull/11414>`_, by Pierre-Marie Pédrot). diff --git a/doc/changelog/09-coqide/11415-remove-ide-revert-all-buffers.rst b/doc/changelog/09-coqide/11415-remove-ide-revert-all-buffers.rst index cb92945b8b..9d22a858f1 100644 --- a/doc/changelog/09-coqide/11415-remove-ide-revert-all-buffers.rst +++ b/doc/changelog/09-coqide/11415-remove-ide-revert-all-buffers.rst @@ -1,4 +1,4 @@ - **Removed:** - Removed the "Revert all buffers" command from CoqIDE which had been broken for a long time + "Revert all buffers" command from CoqIDE which had been broken for a long time (`#11415 <https://github.com/coq/coq/pull/11415>`_, by Pierre-Marie Pédrot). diff --git a/doc/changelog/10-standard-library/11127-trunk.rst b/doc/changelog/10-standard-library/11127-trunk.rst index ef1d41d17f..3f461397ae 100644 --- a/doc/changelog/10-standard-library/11127-trunk.rst +++ b/doc/changelog/10-standard-library/11127-trunk.rst @@ -1,2 +1,2 @@ -- **Added:** theorem :g:`bezout_comm` for natural numbers +- **Added:** Theorem :g:`bezout_comm` for natural numbers (`#11127 <https://github.com/coq/coq/pull/11127>`_, by Daniel de Rauglaudre). diff --git a/doc/changelog/03-notations/11240-rew-dependent.rst b/doc/changelog/10-standard-library/11240-rew-dependent.rst index e9daab0c2c..e9daab0c2c 100644 --- a/doc/changelog/03-notations/11240-rew-dependent.rst +++ b/doc/changelog/10-standard-library/11240-rew-dependent.rst diff --git a/doc/changelog/10-standard-library/11686-fix-int-notations.rst b/doc/changelog/10-standard-library/11686-fix-int-notations.rst index cc820c5a25..4959a9f9b1 100644 --- a/doc/changelog/10-standard-library/11686-fix-int-notations.rst +++ b/doc/changelog/10-standard-library/11686-fix-int-notations.rst @@ -2,5 +2,5 @@ Notations :n:`[|@term|]` and :n:`[||@term||]` for morphisms from 63-bit integers to :g:`Z` and :g:`zn2z int` have been removed in favor of :n:`φ(@term)` and :n:`Φ(@term)` respectively. These notations were - breaking Ltac parsing. (`#11686 <https://github.com/coq/coq/pull/11686>`_, + breaking Ltac parsing (`#11686 <https://github.com/coq/coq/pull/11686>`_, by Maxime Dénès). diff --git a/doc/changelog/11-infrastructure-and-dependencies/11245-bye+py2.rst b/doc/changelog/11-infrastructure-and-dependencies/11245-bye+py2.rst index 03c2ccc1d2..dc76178e0d 100644 --- a/doc/changelog/11-infrastructure-and-dependencies/11245-bye+py2.rst +++ b/doc/changelog/11-infrastructure-and-dependencies/11245-bye+py2.rst @@ -1,4 +1,4 @@ - **Removed:** - Python 2 is not longer required in any part of the codebase. + Python 2 is not longer required in any part of the codebase (`#11245 <https://github.com/coq/coq/pull/11245>`_, by Emilio Jesus Gallego Arias). diff --git a/doc/changelog/12-misc/10486-native-string-extraction.rst b/doc/changelog/12-misc/10486-native-string-extraction.rst index c6778403d4..0636e303c4 100644 --- a/doc/changelog/12-misc/10486-native-string-extraction.rst +++ b/doc/changelog/12-misc/10486-native-string-extraction.rst @@ -2,6 +2,6 @@ Support for better extraction of strings in OCaml and Haskell: `ExtOcamlNativeString` provides bindings from the Coq `String` type to the OCaml `string` type, and string literals can be extracted to literals, - both in OCaml and Haskell. (`#10486 + both in OCaml and Haskell (`#10486 <https://github.com/coq/coq/pull/10486>`_, by Xavier Leroy, with help from Maxime Dénès, review by Hugo Herbelin). @@ -14,7 +14,7 @@ unreleased.rst (env_var SPHINXWARNOPT)) (action - (run env COQLIB=%{project_root} sphinx-build -j4 %{env:SPHINXWARNOPT=-W} -b html -d sphinx_build/doctrees sphinx sphinx_build/html))) + (run env COQLIB=%{project_root} sphinx-build %{env:SPHINXWARNOPT=-W} -b html -d sphinx_build/doctrees sphinx sphinx_build/html))) (alias (name refman-html) diff --git a/doc/sphinx/README.rst b/doc/sphinx/README.rst index 89b4bda71a..0802b5d0b4 100644 --- a/doc/sphinx/README.rst +++ b/doc/sphinx/README.rst @@ -3,8 +3,8 @@ ============================= .. - README.rst is auto-generated from README.template.rst and the coqrst docs; - use ``doc/tools/coqrst/regen_readme.py`` to rebuild it. + README.rst is auto-generated from README.template.rst and the coqrst/*.py files + (in particular coqdomain.py). Use ``doc/tools/coqrst/regen_readme.py`` to rebuild it. Coq's reference manual is written in `reStructuredText <http://www.sphinx-doc.org/en/master/usage/restructuredtext/basics.html>`_ (“reST”), and compiled with `Sphinx <http://www.sphinx-doc.org/en/master/>`_. @@ -97,7 +97,7 @@ Here is the list of all objects of the Coq domain (The symbol :black_nib: indica ``.. cmd::`` :black_nib: A Coq command. Example:: - .. cmd:: Infix @string := @term1_extended {? ( {+, @syntax_modifier } ) } {? : @ident } + .. cmd:: Infix @string := @one_term {? ( {+, @syntax_modifier } ) } {? : @ident } This command is equivalent to :n:`…`. diff --git a/doc/sphinx/README.template.rst b/doc/sphinx/README.template.rst index c5e0007e78..5762967c36 100644 --- a/doc/sphinx/README.template.rst +++ b/doc/sphinx/README.template.rst @@ -3,8 +3,8 @@ ============================= .. - README.rst is auto-generated from README.template.rst and the coqrst docs; - use ``doc/tools/coqrst/regen_readme.py`` to rebuild it. + README.rst is auto-generated from README.template.rst and the coqrst/*.py files + (in particular coqdomain.py). Use ``doc/tools/coqrst/regen_readme.py`` to rebuild it. Coq's reference manual is written in `reStructuredText <http://www.sphinx-doc.org/en/master/usage/restructuredtext/basics.html>`_ (“reST”), and compiled with `Sphinx <http://www.sphinx-doc.org/en/master/>`_. diff --git a/doc/sphinx/addendum/extended-pattern-matching.rst b/doc/sphinx/addendum/extended-pattern-matching.rst index 15f42591ce..8ec51e45ba 100644 --- a/doc/sphinx/addendum/extended-pattern-matching.rst +++ b/doc/sphinx/addendum/extended-pattern-matching.rst @@ -5,8 +5,6 @@ Extended pattern matching :Authors: Cristina Cornes and Hugo Herbelin -.. TODO links to figures - This section describes the full form of pattern matching in |Coq| terms. .. |rhs| replace:: right hand sides @@ -14,7 +12,7 @@ This section describes the full form of pattern matching in |Coq| terms. Patterns -------- -The full syntax of match is presented in Figures 1.1 and 1.2. +The full syntax of :g:`match` is presented in section :ref:`term`. Identifiers in patterns are either constructor names or variables. Any identifier that is not the constructor of an inductive or co-inductive type is considered to be a variable. A variable name cannot occur more @@ -496,9 +494,8 @@ We can use multiple patterns to write the proof of the lemma In the example of :g:`dec`, the first match is dependent while the second is not. -The user can also use match in combination with the tactic :tacn:`refine` (see -Section 8.2.3) to build incomplete proofs beginning with a match -construction. +The user can also use match in combination with the tactic :tacn:`refine` +to build incomplete proofs beginning with a :g:`match` construction. Pattern-matching on inductive objects involving local definitions diff --git a/doc/sphinx/addendum/generalized-rewriting.rst b/doc/sphinx/addendum/generalized-rewriting.rst index 94ab6e789c..315c9d4a80 100644 --- a/doc/sphinx/addendum/generalized-rewriting.rst +++ b/doc/sphinx/addendum/generalized-rewriting.rst @@ -713,48 +713,119 @@ Definitions ~~~~~~~~~~~ The generalized rewriting tactic is based on a set of strategies that can be -combined to obtain custom rewriting procedures. Its set of strategies is based +combined to create custom rewriting procedures. Its set of strategies is based on the programmable rewriting strategies with generic traversals by Visser et al. :cite:`Luttik97specificationof` :cite:`Visser98`, which formed the core of the Stratego transformation language :cite:`Visser01`. Rewriting strategies -are applied using the tactic :n:`rewrite_strat @strategy` where :token:`strategy` is a -strategy expression. Strategies are defined inductively as described by the -following grammar: - -.. productionlist:: coq - strategy : `qualid` (lemma, left to right) - : <- `qualid` (lemma, right to left) - : fail (failure) - : id (identity) - : refl (reflexivity) - : progress `strategy` (progress) - : try `strategy` (try catch) - : `strategy` ; `strategy` (composition) - : choice `strategy` `strategy` (left_biased_choice) - : repeat `strategy` (one or more) - : any `strategy` (zero or more) - : subterm `strategy` (one subterm) - : subterms `strategy` (all subterms) - : innermost `strategy` (innermost first) - : outermost `strategy` (outermost first) - : bottomup `strategy` (bottom-up) - : topdown `strategy` (top-down) - : hints `ident` (apply hints from hint database) - : terms `term` ... `term` (any of the terms) - : eval `red_expr` (apply reduction) - : fold `term` (unify) - : ( `strategy` ) - -Actually a few of these are defined in term of the others using a +are applied using the tactic :n:`rewrite_strat @rewstrategy`. + +.. insertprodn rewstrategy rewstrategy + +.. prodn:: + rewstrategy ::= @one_term + | <- @one_term + | fail + | id + | refl + | progress @rewstrategy + | try @rewstrategy + | @rewstrategy ; @rewstrategy + | choice @rewstrategy @rewstrategy + | repeat @rewstrategy + | any @rewstrategy + | subterm @rewstrategy + | subterms @rewstrategy + | innermost @rewstrategy + | outermost @rewstrategy + | bottomup @rewstrategy + | topdown @rewstrategy + | hints @ident + | terms {* @one_term } + | eval @red_expr + | fold @one_term + | ( @rewstrategy ) + | old_hints @ident + +:n:`@one_term` + lemma, left to right + +:n:`<- @one_term` + lemma, right to left + +:n:`fail` + failure + +:n:`id` + identity + +:n:`refl` + reflexivity + +:n:`progress @rewstrategy` + progress + +:n:`try @rewstrategy` + try catch + +:n:`@rewstrategy ; @rewstrategy` + composition + +:n:`choice @rewstrategy @rewstrategy` + left_biased_choice + +:n:`repeat @rewstrategy` + one or more + +:n:`any @rewstrategy` + zero or more + +:n:`subterm @rewstrategy` + one subterm + +:n:`subterms @rewstrategy` + all subterms + +:n:`innermost @rewstrategy` + innermost first + +:n:`outermost @rewstrategy` + outermost first + +:n:`bottomup @rewstrategy` + bottom-up + +:n:`topdown @rewstrategy` + top-down + +:n:`hints @ident` + apply hints from hint database + +:n:`terms {* @one_term }` + any of the terms + +:n:`eval @red_expr` + apply reduction + +:n:`fold @term` + unify + +:n:`( @rewstrategy )` + to be documented + +:n:`old_hints @ident` + to be documented + + +A few of these are defined in terms of the others using a primitive fixpoint operator: -- :n:`try @strategy := choice @strategy id` -- :n:`any @strategy := fix @ident. try (@strategy ; @ident)` -- :n:`repeat @strategy := @strategy; any @strategy` -- :n:`bottomup @strategy := fix @ident. (choice (progress (subterms @ident)) @strategy) ; try @ident` -- :n:`topdown @strategy := fix @ident. (choice @strategy (progress (subterms @ident))) ; try @ident` -- :n:`innermost @strategy := fix @ident. (choice (subterm @ident) @strategy)` -- :n:`outermost @strategy := fix @ident. (choice @strategy (subterm @ident))` +- :n:`try @rewstrategy := choice @rewstrategy id` +- :n:`any @rewstrategy := fix @ident. try (@rewstrategy ; @ident)` +- :n:`repeat @rewstrategy := @rewstrategy; any @rewstrategy` +- :n:`bottomup @rewstrategy := fix @ident. (choice (progress (subterms @ident)) @rewstrategy) ; try @ident` +- :n:`topdown @rewstrategy := fix @ident. (choice @rewstrategy (progress (subterms @ident))) ; try @ident` +- :n:`innermost @rewstrategy := fix @ident. (choice (subterm @ident) @rewstrategy)` +- :n:`outermost @rewstrategy := fix @ident. (choice @rewstrategy (subterm @ident))` The basic control strategy semantics are straightforward: strategies are applied to subterms of the term to rewrite, starting from the root @@ -764,18 +835,18 @@ hand-side. Composition can be used to continue rewriting on the current subterm. The ``fail`` strategy always fails while the identity strategy succeeds without making progress. The reflexivity strategy succeeds, making progress using a reflexivity proof of rewriting. -``progress`` tests progress of the argument :token:`strategy` and fails if no +``progress`` tests progress of the argument :n:`@rewstrategy` and fails if no progress was made, while ``try`` always succeeds, catching failures. ``choice`` is left-biased: it will launch the first strategy and fall back on the second one in case of failure. One can iterate a strategy at least 1 time using ``repeat`` and at least 0 times using ``any``. -The ``subterm`` and ``subterms`` strategies apply their argument :token:`strategy` to +The ``subterm`` and ``subterms`` strategies apply their argument :n:`@rewstrategy` to respectively one or all subterms of the current term under consideration, left-to-right. ``subterm`` stops at the first subterm for -which :token:`strategy` made progress. The composite strategies ``innermost`` and ``outermost`` +which :n:`@rewstrategy` made progress. The composite strategies ``innermost`` and ``outermost`` perform a single innermost or outermost rewrite using their argument -:token:`strategy`. Their counterparts ``bottomup`` and ``topdown`` perform as many +:n:`@rewstrategy`. Their counterparts ``bottomup`` and ``topdown`` perform as many rewritings as possible, starting from the bottom or the top of the term. @@ -793,7 +864,7 @@ Usage ~~~~~ -.. tacn:: rewrite_strat @strategy {? in @ident } +.. tacn:: rewrite_strat @rewstrategy {? in @ident } :name: rewrite_strat Rewrite using the strategy s in hypothesis ident or the conclusion. diff --git a/doc/sphinx/addendum/implicit-coercions.rst b/doc/sphinx/addendum/implicit-coercions.rst index b007509b2e..1f33775a01 100644 --- a/doc/sphinx/addendum/implicit-coercions.rst +++ b/doc/sphinx/addendum/implicit-coercions.rst @@ -37,12 +37,13 @@ In addition to these user-defined classes, we have two built-in classes: * ``Funclass``, the class of functions; its objects are all the terms with a functional type, i.e. of form :g:`forall x:A,B`. -Formally, the syntax of classes is defined as: + .. insertprodn class class + + .. prodn:: + class ::= Funclass + | Sortclass + | @smart_qualid -.. productionlist:: - class: `qualid` - : Sortclass - : Funclass Coercions @@ -186,37 +187,12 @@ Declaring Coercions This defines :token:`ident` just like :n:`Let @ident := @term {? @type }`, and then declares :token:`ident` as a coercion between it source and its target. -Assumptions can be declared as coercions at declaration time. -This extends the grammar of assumptions from -Figure :ref:`vernacular` as follows: - -.. - FIXME: - \comindex{Variable \mbox{\rm (and coercions)}} - \comindex{Axiom \mbox{\rm (and coercions)}} - \comindex{Parameter \mbox{\rm (and coercions)}} - \comindex{Hypothesis \mbox{\rm (and coercions)}} - -.. productionlist:: - assumption : `assumption_token` `assums` . - assums : `simple_assums` - : (`simple_assums`) ... (`simple_assums`) - simple_assums : `ident` ... `ident` :[>] `term` - -If the extra ``>`` is present before the type of some assumptions, these -assumptions are declared as coercions. - -Similarly, constructors of inductive types can be declared as coercions at -definition time of the inductive type. This extends and modifies the -grammar of inductive types from Figure :ref:`vernacular` as follows: - -.. - FIXME: - \comindex{Inductive \mbox{\rm (and coercions)}} - \comindex{CoInductive \mbox{\rm (and coercions)}} - -Especially, if the extra ``>`` is present in a constructor -declaration, this constructor is declared as a coercion. +Some objects can be declared as coercions when they are defined. +This applies to :ref:`assumptions<gallina-assumptions>` and +constructors of :ref:`inductive types and record fields<gallina-inductive-definitions>`. +Use :n:`:>` instead of :n:`:` before the +:n:`@type` of the assumption to do so. See :n:`@of_type`. + .. cmd:: Identity Coercion @ident : @class >-> @class diff --git a/doc/sphinx/addendum/ring.rst b/doc/sphinx/addendum/ring.rst index 1098aa75da..76174e32b5 100644 --- a/doc/sphinx/addendum/ring.rst +++ b/doc/sphinx/addendum/ring.rst @@ -300,70 +300,79 @@ following property: The syntax for adding a new ring is -.. cmd:: Add Ring @ident : @term {? ( @ring_mod {* , @ring_mod } )} - - The :token:`ident` is not relevant. It is used just for error messages. The - :token:`term` is a proof that the ring signature satisfies the (semi-)ring +.. cmd:: Add Ring @ident : @one_term {? ( {+, @ring_mod } ) } + + .. insertprodn ring_mod ring_mod + + .. prodn:: + ring_mod ::= decidable @one_term + | abstract + | morphism @one_term + | constants [ @ltac_expr ] + | preprocess [ @ltac_expr ] + | postprocess [ @ltac_expr ] + | setoid @one_term @one_term + | sign @one_term + | power @one_term [ {+ @qualid } ] + | power_tac @one_term [ @ltac_expr ] + | div @one_term + | closed [ {+ @qualid } ] + + The :n:`@ident` is used only for error messages. The + :n:`@one_term` is a proof that the ring signature satisfies the (semi-)ring axioms. The optional list of modifiers is used to tailor the behavior - of the tactic. The following list describes their syntax and effects: - - .. productionlist:: coq - ring_mod : abstract | decidable `term` | morphism `term` - : setoid `term` `term` - : constants [ `tactic` ] - : preprocess [ `tactic` ] - : postprocess [ `tactic` ] - : power_tac `term` [ `tactic` ] - : sign `term` - : div `term` - - abstract + of the tactic. Here are their effects: + + :n:`abstract` declares the ring as abstract. This is the default. - decidable :n:`@term` + :n:`decidable @one_term` declares the ring as computational. The expression - :n:`@term` is the correctness proof of an equality test ``?=!`` + :n:`@one_term` is the correctness proof of an equality test ``?=!`` (which should be evaluable). Its type should be of the form ``forall x y, x ?=! y = true → x == y``. - morphism :n:`@term` + :n:`morphism @one_term` declares the ring as a customized one. The expression - :n:`@term` is a proof that there exists a morphism between a set of + :n:`@one_term` is a proof that there exists a morphism between a set of coefficient and the ring carrier (see ``Ring_theory.ring_morph`` and ``Ring_theory.semi_morph``). - setoid :n:`@term` :n:`@term` + :n:`setoid @one_term @one_term` forces the use of given setoid. The first - :n:`@term` is a proof that the equality is indeed a setoid (see - ``Setoid.Setoid_Theory``), and the second :n:`@term` a proof that the + :n:`@one_term` is a proof that the equality is indeed a setoid (see + ``Setoid.Setoid_Theory``), and the second a proof that the ring operations are morphisms (see ``Ring_theory.ring_eq_ext`` and ``Ring_theory.sring_eq_ext``). This modifier needs not be used if the setoid and morphisms have been declared. - constants [ :n:`@tactic` ] - specifies a tactic expression :n:`@tactic` that, given a + :n:`constants [ @ltac_expr ]` + specifies a tactic expression :n:`@ltac_expr` that, given a term, returns either an object of the coefficient set that is mapped to the expression via the morphism, or returns ``InitialRing.NotConstant``. The default behavior is to map only 0 and 1 to their counterpart in the coefficient set. This is generally not desirable for non trivial computational rings. - preprocess [ :n:`@tactic` ] - specifies a tactic :n:`@tactic` that is applied as a + :n:`preprocess [ @ltac_expr ]` + specifies a tactic :n:`@ltac_expr` that is applied as a preliminary step for :tacn:`ring` and :tacn:`ring_simplify`. It can be used to transform a goal so that it is better recognized. For instance, ``S n`` can be changed to ``plus 1 n``. - postprocess [ :n:`@tactic` ] - specifies a tactic :n:`@tactic` that is applied as a final + :n:`postprocess [ @ltac_expr ]` + specifies a tactic :n:`@ltac_expr` that is applied as a final step for :tacn:`ring_simplify`. For instance, it can be used to undo modifications of the preprocessor. - power_tac :n:`@term` [ :n:`@tactic` ] + :n:`power @one_term [ {+ @qualid } ]` + to be documented + + :n:`power_tac @one_term @ltac_expr ]` allows :tacn:`ring` and :tacn:`ring_simplify` to recognize power expressions with a constant positive integer exponent (example: - :math:`x^2` ). The term :n:`@term` is a proof that a given power function satisfies + :math:`x^2` ). The term :n:`@one_term` is a proof that a given power function satisfies the specification of a power function (term has to be a proof of ``Ring_theory.power_theory``) and :n:`@tactic` specifies a tactic expression that, given a term, “abstracts” it into an object of type |N| whose @@ -374,22 +383,25 @@ The syntax for adding a new ring is and ``plugins/setoid_ring/RealField.v`` for examples. By default the tactic does not recognize power expressions as ring expressions. - sign :n:`@term` + :n:`sign @one_term` allows :tacn:`ring_simplify` to use a minus operation when outputting its normal form, i.e writing ``x − y`` instead of ``x + (− y)``. The term :token:`term` is a proof that a given sign function indicates expressions that are signed (:token:`term` has to be a proof of ``Ring_theory.get_sign``). See ``plugins/setoid_ring/InitialRing.v`` for examples of sign function. - div :n:`@term` + :n:`div @one_term` allows :tacn:`ring` and :tacn:`ring_simplify` to use monomials with - coefficients other than 1 in the rewriting. The term :n:`@term` is a proof + coefficients other than 1 in the rewriting. The term :n:`@one_term` is a proof that a given division function satisfies the specification of an - euclidean division function (:n:`@term` has to be a proof of + euclidean division function (:n:`@one_term` has to be a proof of ``Ring_theory.div_theory``). For example, this function is called when trying to rewrite :math:`7x` by :math:`2x = z` to tell that :math:`7 = 3 \times 2 + 1`. See ``plugins/setoid_ring/InitialRing.v`` for examples of div function. + :n:`closed [ {+ @qualid } ]` + to be documented + Error messages: .. exn:: Bad ring structure. @@ -653,24 +665,27 @@ zero for the correctness of the algorithm. The syntax for adding a new field is -.. cmd:: Add Field @ident : @term {? ( @field_mod {* , @field_mod } )} +.. cmd:: Add Field @ident : @one_term {? ( {+, @field_mod } ) } - The :n:`@ident` is not relevant. It is used just for error - messages. :n:`@term` is a proof that the field signature satisfies the + .. insertprodn field_mod field_mod + + .. prodn:: + field_mod ::= @ring_mod + | completeness @one_term + + The :n:`@ident` is used only for error + messages. :n:`@one_term` is a proof that the field signature satisfies the (semi-)field axioms. The optional list of modifiers is used to tailor the behavior of the tactic. - .. productionlist:: coq - field_mod : `ring_mod` | completeness `term` - Since field tactics are built upon ``ring`` - tactics, all modifiers of the ``Add Ring`` apply. There is only one + tactics, all modifiers of :cmd:`Add Ring` apply. There is only one specific modifier: - completeness :n:`@term` + completeness :n:`@one_term` allows the field tactic to prove automatically that the image of nonzero coefficients are mapped to nonzero - elements of the field. :n:`@term` is a proof of + elements of the field. :n:`@one_term` is a proof of :g:`forall x y, [x] == [y] -> x ?=! y = true`, which is the completeness of equality on coefficients w.r.t. the field equality. diff --git a/doc/sphinx/addendum/type-classes.rst b/doc/sphinx/addendum/type-classes.rst index af4e9051bb..7abeca7815 100644 --- a/doc/sphinx/addendum/type-classes.rst +++ b/doc/sphinx/addendum/type-classes.rst @@ -385,8 +385,10 @@ few other commands related to typeclasses. .. tacn:: typeclasses eauto :name: typeclasses eauto - This tactic uses a different resolution engine than :tacn:`eauto` and - :tacn:`auto`. The main differences are the following: + This proof search tactic implements the resolution engine that is run + implicitly during type-checking. This tactic uses a different resolution + engine than :tacn:`eauto` and :tacn:`auto`. The main differences are the + following: + Contrary to :tacn:`eauto` and :tacn:`auto`, the resolution is done entirely in the new proof engine (as of Coq 8.6), meaning that backtracking is @@ -422,6 +424,17 @@ few other commands related to typeclasses. resolution with the local hypotheses use full conversion during unification. + + The mode hints (see :cmd:`Hint Mode`) associated to a class are + taken into account by :tacn:`typeclasses eauto`. When a goal + does not match any of the declared modes for its head (if any), + instead of failing like :tacn:`eauto`, the goal is suspended and + resolution proceeds on the remaining goals. + If after one run of resolution, there remains suspended goals, + resolution is launched against on them, until it reaches a fixed + point when the set of remaining suspended goals does not change. + Using `solve [typeclasses eauto]` can be used to ensure that + no suspended goals remain. + + When considering local hypotheses, we use the union of all the modes declared in the given databases. diff --git a/doc/sphinx/addendum/universe-polymorphism.rst b/doc/sphinx/addendum/universe-polymorphism.rst index c069782add..0e326f45d2 100644 --- a/doc/sphinx/addendum/universe-polymorphism.rst +++ b/doc/sphinx/addendum/universe-polymorphism.rst @@ -372,16 +372,11 @@ to universes and explicitly instantiate polymorphic definitions. universe quantification will be discharged on each section definition independently. -.. cmd:: Constraint @universe_constraint - Polymorphic Constraint @universe_constraint +.. cmd:: Constraint @univ_constraint + Polymorphic Constraint @univ_constraint This command declares a new constraint between named universes. - .. productionlist:: coq - universe_constraint : `qualid` < `qualid` - : `qualid` <= `qualid` - : `qualid` = `qualid` - If consistent, the constraint is then enforced in the global environment. Like :cmd:`Universe`, it can be used with the ``Polymorphic`` prefix in sections only to declare constraints diff --git a/doc/sphinx/conf.py b/doc/sphinx/conf.py index 22102aa3ab..d864f8549d 100755 --- a/doc/sphinx/conf.py +++ b/doc/sphinx/conf.py @@ -183,9 +183,9 @@ todo_include_todos = False nitpicky = True nitpick_ignore = [ ('token', token) for token in [ + 'assums', 'binders', 'collection', - 'command', 'definition', 'dirpath', 'inductive', @@ -194,7 +194,6 @@ nitpick_ignore = [ ('token', token) for token in [ 'module', 'simple_tactic', 'symbol', - 'tactic', 'term_pattern', 'term_pattern_string', 'toplevel_selector', diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index 6c1d83b3b8..b9e181dd94 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -24,7 +24,7 @@ expressions. In this sense, the :cmd:`Record` construction allows defining record : `record_keyword` `record_body` with … with `record_body` record_keyword : Record | Inductive | CoInductive record_body : `ident` [ `binders` ] [: `sort` ] := [ `ident` ] { [ `field` ; … ; `field` ] }. - field : `ident` [ `binders` ] : `type` [ where `notation` ] + field : `ident` [ `binders` ] : `type` [ `decl_notations` ] : `ident` [ `binders` ] [: `type` ] := `term` .. cmd:: {| Record | Structure } @inductive_definition {* with @inductive_definition } @@ -35,8 +35,10 @@ expressions. In this sense, the :cmd:`Record` construction allows defining the default name :n:`Build_@ident`, where :token:`ident` is the record name, is used. If :token:`sort` is omitted, the default sort is :math:`\Type`. The identifiers inside the brackets are the names of fields. For a given field :token:`ident`, its type is :n:`forall {* @binder }, @type`. - Remark that the type of a particular identifier may depend on a previously-given identifier. Thus the - order of the fields is important. Finally, :token:`binders` are parameters of the record. + Notice that the type of a particular identifier may depend on a previously-given identifier. Thus the + order of the fields is important. The record can depend as a whole on parameters :token:`binders` + and each field can also depend on its own :token:`binders`. Finally, notations can be attached to + fields using the :n:`decl_notations` annotation. :cmd:`Record` and :cmd:`Structure` are synonyms. diff --git a/doc/sphinx/language/gallina-specification-language.rst b/doc/sphinx/language/gallina-specification-language.rst index e12ff1ba98..4f0cf5f815 100644 --- a/doc/sphinx/language/gallina-specification-language.rst +++ b/doc/sphinx/language/gallina-specification-language.rst @@ -158,6 +158,8 @@ is described in Chapter :ref:`syntaxextensionsandinterpretationscopes`. | @term1 arg ::= ( @ident := @term ) | @term1 + one_term ::= @term1 + | @ @qualid {? @univ_annot } term1 ::= @term_projection | @term0 % @ident | @term0 @@ -175,6 +177,13 @@ is described in Chapter :ref:`syntaxextensionsandinterpretationscopes`. | ltac : ( @ltac_expr ) field_def ::= @qualid {* @binder } := @term +.. note:: + + Many commands and tactics use :n:`@one_term` rather than :n:`@term`. + The former need to be enclosed in parentheses unless they're very + simple, such as a single identifier. This avoids confusing a space-separated + list of terms with a :n:`@term1` applied to a list of arguments. + .. _types: Types @@ -591,17 +600,15 @@ Sections :ref:`if-then-else` and :ref:`irrefutable-patterns`). Recursive and co-recursive functions: fix and cofix --------------------------------------------------- -.. insertprodn term_fix term1_extended +.. insertprodn term_fix fixannot .. prodn:: term_fix ::= let fix @fix_body in @term | fix @fix_body {? {+ with @fix_body } for @ident } fix_body ::= @ident {* @binder } {? @fixannot } {? : @type } := @term fixannot ::= %{ struct @ident %} - | %{ wf @term1_extended @ident %} - | %{ measure @term1_extended {? @ident } {? @term1_extended } %} - term1_extended ::= @term1 - | @ @qualid {? @univ_annot } + | %{ wf @one_term @ident %} + | %{ measure @one_term {? @ident } {? @one_term } %} The expression ":n:`fix @ident__1 @binder__1 : @type__1 := @term__1 with … with @ident__n @binder__n : @type__n := @term__n for @ident__i`" denotes the @@ -1472,11 +1479,11 @@ Computations | vm_compute {? @ref_or_pattern_occ } | native_compute {? @ref_or_pattern_occ } | unfold {+, @unfold_occ } - | fold {+ @term1_extended } + | fold {+ @one_term } | pattern {+, @pattern_occ } | @ident - delta_flag ::= {? - } [ {+ @smart_global } ] - smart_global ::= @qualid + delta_flag ::= {? - } [ {+ @smart_qualid } ] + smart_qualid ::= @qualid | @by_notation by_notation ::= @string {? % @ident } strategy_flag ::= {+ @red_flags } @@ -1488,16 +1495,16 @@ Computations | cofix | zeta | delta {? @delta_flag } - ref_or_pattern_occ ::= @smart_global {? at @occs_nums } - | @term1_extended {? at @occs_nums } + ref_or_pattern_occ ::= @smart_qualid {? at @occs_nums } + | @one_term {? at @occs_nums } occs_nums ::= {+ @num_or_var } | - @num_or_var {* @int_or_var } num_or_var ::= @num | @ident int_or_var ::= @int | @ident - unfold_occ ::= @smart_global {? at @occs_nums } - pattern_occ ::= @term1_extended {? at @occs_nums } + unfold_occ ::= @smart_qualid {? at @occs_nums } + pattern_occ ::= @one_term {? at @occs_nums } See :ref:`Conversion-rules`. diff --git a/doc/sphinx/practical-tools/utilities.rst b/doc/sphinx/practical-tools/utilities.rst index 179dff9959..514353e39b 100644 --- a/doc/sphinx/practical-tools/utilities.rst +++ b/doc/sphinx/practical-tools/utilities.rst @@ -505,34 +505,41 @@ Building a |Coq| project with Dune .. note:: + Dune's Coq support is still experimental; we strongly recommend + using Dune 2.3 or later. + +.. note:: + The canonical documentation for the Coq Dune extension is maintained upstream; please refer to the `Dune manual - <https://dune.readthedocs.io/>`_ for up-to-date information. + <https://dune.readthedocs.io/>`_ for up-to-date information. This + documentation is up to date for Dune 2.3. Building a Coq project with Dune requires setting up a Dune project for your files. This involves adding a ``dune-project`` and -``pkg.opam`` file to the root (``pkg.opam`` can be empty), and then -providing ``dune`` files in the directories your ``.v`` files are -placed. For the experimental version "0.1" of the Coq Dune language, -|Coq| library stanzas look like: +``pkg.opam`` file to the root (``pkg.opam`` can be empty or generated +by Dune itself), and then providing ``dune`` files in the directories +your ``.v`` files are placed. For the experimental version "0.1" of +the Coq Dune language, |Coq| library stanzas look like: .. code:: scheme - (coqlib + (coq.theory (name <module_prefix>) - (public_name <package.lib_name>) + (package <opam_package>) (synopsis <text>) (modules <ordered_set_lang>) (libraries <ocaml_libraries>) (flags <coq_flags>)) This stanza will build all `.v` files in the given directory, wrapping -the library under ``<module_prefix>``. If you declare a -``<package.lib_name>`` a ``.install`` file for the library will be -generated; the optional ``<modules>`` field allows you to filter -the list of modules, and ``<libraries>`` allows to depend on ML -plugins. For the moment, Dune relies on Coq's standard mechanisms -(such as ``COQPATH``) to locate installed Coq libraries. +the library under ``<module_prefix>``. If you declare an +``<opam_package>``, an ``.install`` file for the library will be +generated; the optional ``(modules <ordered_set_lang>)`` field allows +you to filter the list of modules, and ``(libraries +<ocaml_libraries>)`` allows the Coq theory depend on ML plugins. For +the moment, Dune relies on Coq's standard mechanisms (such as +``COQPATH``) to locate installed Coq libraries. By default Dune will skip ``.v`` files present in subdirectories. In order to enable the usual recursive organization of Coq projects add @@ -565,9 +572,9 @@ of your project. .. code:: scheme - (coqlib + (coq.theory (name Equations) ; -R flag - (public_name equations.Equations) + (package equations) (synopsis "Equations Plugin") (libraries coq.plugins.extraction equations.plugin) (modules :standard \ IdDec NoCycle)) ; exclude some modules that don't build diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 6a0ce20c79..4f2f74aae4 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -72,7 +72,7 @@ specified, the default selector is used. .. _bindingslist: Bindings list -~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~ Tactics that take a term as an argument may also support a bindings list to instantiate some parameters of the term by name or position. @@ -1452,6 +1452,19 @@ Controlling the proof flow While :tacn:`pose proof` expects that no existential variables are generated by the tactic, :tacn:`epose proof` removes this constraint. +.. tacv:: pose proof (@ident := @term) + + This is an alternative syntax for :n:`assert (@ident := @term)` and + :n:`pose proof @term as @ident`, following the model of :n:`pose + (@ident := @term)` but dropping the value of :token:`ident`. + +.. tacv:: epose proof (@ident := @term) + + This is an alternative syntax for :n:`eassert (@ident := @term)` + and :n:`epose proof @term as @ident`, following the model of + :n:`epose (@ident := @term)` but dropping the value of + :token:`ident`. + .. tacv:: enough (@ident : @type) :name: enough @@ -3761,18 +3774,18 @@ automatically created. Local is useless since hints do not survive anyway to the closure of sections. - .. cmdv:: Hint Resolve @term {? | {? @num} {? @pattern}} : @ident + .. cmdv:: Hint Resolve @qualid {? | {? @num} {? @pattern}} : @ident :name: Hint Resolve - This command adds :n:`simple apply @term` to the hint list with the head - symbol of the type of :n:`@term`. The cost of that hint is the number of - subgoals generated by :n:`simple apply @term` or :n:`@num` if specified. The + This command adds :n:`simple apply @qualid` to the hint list with the head + symbol of the type of :n:`@qualid`. The cost of that hint is the number of + subgoals generated by :n:`simple apply @qualid` or :n:`@num` if specified. The associated :n:`@pattern` is inferred from the conclusion of the type of - :n:`@term` or the given :n:`@pattern` if specified. In case the inferred type - of :n:`@term` does not start with a product the tactic added in the hint list - is :n:`exact @term`. In case this type can however be reduced to a type - starting with a product, the tactic :n:`simple apply @term` is also stored in - the hints list. If the inferred type of :n:`@term` contains a dependent + :n:`@qualid` or the given :n:`@pattern` if specified. In case the inferred type + of :n:`@qualid` does not start with a product the tactic added in the hint list + is :n:`exact @qualid`. In case this type can however be reduced to a type + starting with a product, the tactic :n:`simple apply @qualid` is also stored in + the hints list. If the inferred type of :n:`@qualid` contains a dependent quantification on a variable which occurs only in the premisses of the type and not in its conclusion, no instance could be inferred for the variable by unification with the goal. In this case, the hint is added to the hint list @@ -3780,32 +3793,32 @@ automatically created. typical example of a hint that is used only by :tacn:`eauto` is a transitivity lemma. - .. exn:: @term cannot be used as a hint + .. exn:: @qualid cannot be used as a hint - The head symbol of the type of :n:`@term` is a bound variable + The head symbol of the type of :n:`@qualid` is a bound variable such that this tactic cannot be associated to a constant. - .. cmdv:: Hint Resolve {+ @term} : @ident + .. cmdv:: Hint Resolve {+ @qualid} : @ident - Adds each :n:`Hint Resolve @term`. + Adds each :n:`Hint Resolve @qualid`. - .. cmdv:: Hint Resolve -> @term : @ident + .. cmdv:: Hint Resolve -> @qualid : @ident Adds the left-to-right implication of an equivalence as a hint (informally - the hint will be used as :n:`apply <- @term`, although as mentioned + the hint will be used as :n:`apply <- @qualid`, although as mentioned before, the tactic actually used is a restricted version of :tacn:`apply`). - .. cmdv:: Hint Resolve <- @term + .. cmdv:: Hint Resolve <- @qualid Adds the right-to-left implication of an equivalence as a hint. - .. cmdv:: Hint Immediate @term : @ident + .. cmdv:: Hint Immediate @qualid : @ident :name: Hint Immediate - This command adds :n:`simple apply @term; trivial` to the hint list associated + This command adds :n:`simple apply @qualid; trivial` to the hint list associated with the head symbol of the type of :n:`@ident` in the given database. This - tactic will fail if all the subgoals generated by :n:`simple apply @term` are + tactic will fail if all the subgoals generated by :n:`simple apply @qualid` are not solved immediately by the :tacn:`trivial` tactic (which only tries tactics with cost 0).This command is useful for theorems such as the symmetry of equality or :g:`n+1=m+1 -> n=m` that we may like to introduce with a limited @@ -3813,12 +3826,12 @@ automatically created. never generates subgoals) is always 1, so that it is not used by :tacn:`trivial` itself. - .. exn:: @term cannot be used as a hint + .. exn:: @qualid cannot be used as a hint :undocumented: - .. cmdv:: Hint Immediate {+ @term} : @ident + .. cmdv:: Hint Immediate {+ @qualid} : @ident - Adds each :n:`Hint Immediate @term`. + Adds each :n:`Hint Immediate @qualid`. .. cmdv:: Hint Constructors @qualid : @ident :name: Hint Constructors diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index a38c26c2b3..d1f3dcc309 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -745,11 +745,6 @@ the toplevel, and using them in source files is discouraged. :n:`-Q @string @dirpath`. It adds the physical directory string to the current |Coq| loadpath and maps it to the logical directory dirpath. - .. cmdv:: Add LoadPath @string - - Performs as :n:`Add LoadPath @string @dirpath` but - for the empty directory path. - .. cmd:: Add Rec LoadPath @string as @dirpath @@ -757,11 +752,6 @@ the toplevel, and using them in source files is discouraged. :n:`-R @string @dirpath`. It adds the physical directory string and all its subdirectories to the current |Coq| loadpath. - .. cmdv:: Add Rec LoadPath @string - - Works as :n:`Add Rec LoadPath @string as @dirpath` but for the empty - logical directory path. - .. cmd:: Remove LoadPath @string @@ -784,12 +774,6 @@ the toplevel, and using them in source files is discouraged. loadpath (see the command `Declare ML Module`` in Section :ref:`compiled-files`). -.. cmd:: Add Rec ML Path @string - - This command adds the directory :n:`@string` and all its subdirectories to - the current OCaml loadpath (see the command :cmd:`Declare ML Module`). - - .. cmd:: Print ML Path @string This command displays the current OCaml loadpath. This diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index 9b4d7cf5fa..669975ba7e 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -909,10 +909,10 @@ notations are given below. The optional :production:`scope` is described in notation : [Local] Notation `string` := `term` [(`modifiers`)] [: `scope`]. : [Local] Infix `string` := `qualid` [(`modifiers`)] [: `scope`]. : [Local] Reserved Notation `string` [(`modifiers`)] . - : Inductive `ind_body` [`decl_notation`] with … with `ind_body` [`decl_notation`]. - : CoInductive `ind_body` [`decl_notation`] with … with `ind_body` [`decl_notation`]. - : Fixpoint `fix_body` [`decl_notation`] with … with `fix_body` [`decl_notation`]. - : CoFixpoint `fix_body` [`decl_notation`] with … with `fix_body` [`decl_notation`]. + : Inductive `ind_body` [`decl_notations`] with … with `ind_body` [`decl_notations`]. + : CoInductive `ind_body` [`decl_notations`] with … with `ind_body` [`decl_notations`]. + : Fixpoint `fix_body` [`decl_notations`] with … with `fix_body` [`decl_notations`]. + : CoFixpoint `fix_body` [`decl_notations`] with … with `fix_body` [`decl_notations`]. : [Local] Declare Custom Entry `ident`. modifiers : `modifier`, … , `modifier` modifier : at level `num` @@ -947,7 +947,7 @@ notations are given below. The optional :production:`scope` is described in .. prodn:: decl_notations ::= where @decl_notation {* and @decl_notation } - decl_notation ::= @string := @term1_extended {? : @ident } + decl_notation ::= @string := @one_term {? ( only parsing ) } {? : @ident } .. note:: No typing of the denoted expression is performed at definition time. Type checking is done only at the time of use of the notation. @@ -1194,7 +1194,7 @@ Binding arguments of a constant to an interpretation scope Binding types of arguments to an interpretation scope +++++++++++++++++++++++++++++++++++++++++++++++++++++ -.. cmd:: Bind Scope @scope with @qualid +.. cmd:: Bind Scope @ident with {+ @class } When an interpretation scope is naturally associated to a type (e.g. the scope of operations on the natural numbers), it may be convenient to bind it diff --git a/doc/tools/coqrst/coqdomain.py b/doc/tools/coqrst/coqdomain.py index d6ecf311f1..4d5c837e5c 100644 --- a/doc/tools/coqrst/coqdomain.py +++ b/doc/tools/coqrst/coqdomain.py @@ -294,7 +294,7 @@ class VernacObject(NotationObject): Example:: - .. cmd:: Infix @string := @term1_extended {? ( {+, @syntax_modifier } ) } {? : @ident } + .. cmd:: Infix @string := @one_term {? ( {+, @syntax_modifier } ) } {? : @ident } This command is equivalent to :n:`…`. """ diff --git a/doc/tools/docgram/README.md b/doc/tools/docgram/README.md index fc6d0ace0d..8f325f957a 100644 --- a/doc/tools/docgram/README.md +++ b/doc/tools/docgram/README.md @@ -1,12 +1,13 @@ # Grammar extraction tool for documentation -`doc_grammar` extracts Coq's grammar from `.mlg` files, edits it and inserts it in -chunks into `.rst` files. The tool currently inserts Sphinx -`productionlist` constructs. It also generates a file with `prodn` constructs -for the entire grammar, but updates to `tacn` and `cmd` constructs must be done -manually since the grammar doesn't have names for them as it does for -nonterminals. There is an option to report which `tacn` and `cmd` were not -found in the `.rst` files. `tacv` and `cmdv` constructs are not processed at all. +`doc_grammar` extracts Coq's grammar from `.mlg` files, edits it and +inserts it in chunks into `.rst` files. The tool currently inserts +Sphinx `productionlist` and `prodn` constructs (`productionlist` are +gradually being replaced by `prodn` in the manual). Updates to `tacn` +and `cmd` constructs must be done manually since the grammar doesn't +have names for them as it does for nonterminals. There is an option +to report which `tacn` and `cmd` were not found in the `.rst` files. +`tacv` and `cmdv` constructs are not processed at all. The mlg grammars present several challenges to generating an accurate grammar for documentation purposes: diff --git a/doc/tools/docgram/common.edit_mlg b/doc/tools/docgram/common.edit_mlg index 3524d77380..7a165988a6 100644 --- a/doc/tools/docgram/common.edit_mlg +++ b/doc/tools/docgram/common.edit_mlg @@ -57,14 +57,15 @@ DELETE: [ | check_for_coloneq | local_test_lpar_id_colon | lookup_at_as_comma -| only_starredidentrefs +| test_only_starredidentrefs | test_bracket_ident | test_lpar_id_colon | test_lpar_id_coloneq (* todo: grammar seems incorrect, repeats the "(" IDENT ":=" *) | test_lpar_id_rpar | test_lpar_idnum_coloneq -| test_nospace_pipe_closedcurly | test_show_goal +| test_name_colon +| test_pipe_closedcurly | ensure_fixannot (* SSR *) @@ -332,8 +333,8 @@ typeclass_constraint: [ | EDIT ADD_OPT "!" operconstr200 | REPLACE "{" name "}" ":" [ "!" | ] operconstr200 | WITH "{" name "}" ":" OPT "!" operconstr200 -| REPLACE name_colon [ "!" | ] operconstr200 -| WITH name_colon OPT "!" operconstr200 +| REPLACE name ":" [ "!" | ] operconstr200 +| WITH name ":" OPT "!" operconstr200 ] (* ?? From the grammar, Prim.name seems to be only "_" but ident is also accepted "*) @@ -409,19 +410,6 @@ DELETE: [ | cumulativity_token ] -opt_coercion: [ -| OPTINREF -] - -opt_constructors_or_fields: [ -| OPTINREF -] - -SPLICE: [ -| opt_coercion -| opt_constructors_or_fields -] - constructor_list_or_record_decl: [ | OPTINREF ] @@ -433,11 +421,6 @@ record_fields: [ | DELETE (* empty *) ] -decl_notation: [ -| REPLACE "where" LIST1 one_decl_notation SEP decl_sep -| WITH "where" one_decl_notation LIST0 ( decl_sep one_decl_notation ) -] - assumptions_token: [ | DELETENT ] @@ -767,13 +750,13 @@ vernacular: [ ] rec_definition: [ -| REPLACE ident_decl binders_fixannot type_cstr OPT [ ":=" lconstr ] decl_notation -| WITH ident_decl binders_fixannot type_cstr OPT [ ":=" lconstr ] decl_notation +| REPLACE ident_decl binders_fixannot type_cstr OPT [ ":=" lconstr ] decl_notations +| WITH ident_decl binders_fixannot type_cstr OPT [ ":=" lconstr ] decl_notations ] corec_definition: [ -| REPLACE ident_decl binders type_cstr OPT [ ":=" lconstr ] decl_notation -| WITH ident_decl binders type_cstr OPT [ ":=" lconstr ] decl_notation +| REPLACE ident_decl binders type_cstr OPT [ ":=" lconstr ] decl_notations +| WITH ident_decl binders type_cstr OPT [ ":=" lconstr ] decl_notations ] type_cstr: [ @@ -782,13 +765,9 @@ type_cstr: [ | OPTINREF ] -decl_notation: [ -| OPTINREF -] - inductive_definition: [ -| REPLACE OPT ">" ident_decl binders OPT [ "|" binders ] OPT [ ":" lconstr ] OPT ( ":=" OPT constructor_list_or_record_decl ) OPT decl_notation -| WITH OPT ">" ident_decl binders OPT [ "|" binders ] OPT [ ":" type ] OPT ( ":=" OPT constructor_list_or_record_decl ) OPT decl_notation +| REPLACE opt_coercion ident_decl binders OPT [ "|" binders ] OPT [ ":" lconstr ] opt_constructors_or_fields decl_notations +| WITH opt_coercion ident_decl binders OPT [ "|" binders ] OPT [ ":" type ] opt_constructors_or_fields decl_notations ] constructor_list_or_record_decl: [ @@ -807,6 +786,31 @@ record_binder: [ | DELETE name ] +in_clause: [ +| DELETE in_clause' +| REPLACE LIST0 hypident_occ SEP "," "|-" concl_occ +| WITH LIST0 hypident_occ SEP "," OPT ( "|-" concl_occ ) +| DELETE LIST0 hypident_occ SEP "," +] + +concl_occ: [ +| OPTINREF +] + +opt_coercion: [ +| OPTINREF +] + +opt_constructors_or_fields: [ +| OPTINREF +] + +decl_notations: [ +| REPLACE "where" LIST1 decl_notation SEP decl_sep +| WITH "where" decl_notation LIST0 (decl_sep decl_notation ) +| OPTINREF +] + SPLICE: [ | noedit_mode | command_entry @@ -941,11 +945,12 @@ SPLICE: [ | record_fields | constructor_type | record_binder +| opt_coercion +| opt_constructors_or_fields ] (* end SPLICE *) RENAME: [ | clause clause_dft_concl -| in_clause' in_clause | tactic3 ltac_expr3 (* todo: can't figure out how this gets mapped by coqpp *) | tactic1 ltac_expr1 (* todo: can't figure out how this gets mapped by coqpp *) @@ -980,7 +985,7 @@ RENAME: [ | nat_or_var num_or_var | fix_decl fix_body | cofix_decl cofix_body -| constr term1_extended +| constr one_term | appl_arg arg | rec_definition fix_definition | corec_definition cofix_definition @@ -988,12 +993,12 @@ RENAME: [ | univ_instance univ_annot | simple_assum_coe assumpt | of_type_with_opt_coercion of_type -| decl_notation decl_notations -| one_decl_notation decl_notation | attribute attr | attribute_value attr_value | constructor_list_or_record_decl constructors_or_record | record_binder_body field_body +| class_rawexpr class +| smart_global smart_qualid ] diff --git a/doc/tools/docgram/doc_grammar.ml b/doc/tools/docgram/doc_grammar.ml index 5fcb56f5f2..366b70a1f7 100644 --- a/doc/tools/docgram/doc_grammar.ml +++ b/doc/tools/docgram/doc_grammar.ml @@ -1717,7 +1717,7 @@ let process_rst g file args seen tac_prods cmd_prods = else begin let line3 = getline() in if not (Str.string_match dir_regex line3 0) || (Str.matched_group 2 line3) <> "prodn::" then - error "%s line %d: expecting 'prodn' after 'insertprodn'\n" file !linenum + error "%s line %d: expecting '.. prodn::' after 'insertprodn'\n" file !linenum else begin let indent = Str.matched_group 1 line3 in let rec skip_to_end () = diff --git a/doc/tools/docgram/dune b/doc/tools/docgram/dune new file mode 100644 index 0000000000..3afa21f2cf --- /dev/null +++ b/doc/tools/docgram/dune @@ -0,0 +1,30 @@ +(executable + (name doc_grammar) + (libraries coq.clib coqpp)) + +(env (_ (binaries doc_grammar.exe))) + +(rule + (targets fullGrammar) + (deps + ; Main grammar + (glob_files %{project_root}/parsing/*.mlg) + (glob_files %{project_root}/toplevel/*.mlg) + (glob_files %{project_root}/vernac/*.mlg) + ; All plugins except SSReflect for now (mimicking what is done in Makefile.doc) + (glob_files %{project_root}/plugins/btauto/*.mlg) + (glob_files %{project_root}/plugins/cc/*.mlg) + (glob_files %{project_root}/plugins/derive/*.mlg) + (glob_files %{project_root}/plugins/extraction/*.mlg) + (glob_files %{project_root}/plugins/firstorder/*.mlg) + (glob_files %{project_root}/plugins/funind/*.mlg) + (glob_files %{project_root}/plugins/ltac/*.mlg) + (glob_files %{project_root}/plugins/micromega/*.mlg) + (glob_files %{project_root}/plugins/nsatz/*.mlg) + (glob_files %{project_root}/plugins/omega/*.mlg) + (glob_files %{project_root}/plugins/rtauto/*.mlg) + (glob_files %{project_root}/plugins/setoid_ring/*.mlg) + (glob_files %{project_root}/plugins/syntax/*.mlg)) + (action + (chdir %{project_root} (run doc_grammar -short -no-warn %{deps}))) + (mode promote)) diff --git a/doc/tools/docgram/fullGrammar b/doc/tools/docgram/fullGrammar index 529d81e424..6897437457 100644 --- a/doc/tools/docgram/fullGrammar +++ b/doc/tools/docgram/fullGrammar @@ -152,7 +152,7 @@ binder_constr: [ ] appl_arg: [ -| lpar_id_coloneq lconstr ")" +| test_lpar_id_coloneq "(" ident ":=" lconstr ")" | operconstr9 ] @@ -335,7 +335,7 @@ closed_binder: [ typeclass_constraint: [ | "!" operconstr200 | "{" name "}" ":" [ "!" | ] operconstr200 -| name_colon [ "!" | ] operconstr200 +| test_name_colon name ":" [ "!" | ] operconstr200 | operconstr200 ] @@ -449,7 +449,7 @@ bigint: [ ] bar_cbrace: [ -| test_nospace_pipe_closedcurly "|" "}" +| test_pipe_closedcurly "|" "}" ] vernac_toplevel: [ @@ -511,8 +511,8 @@ command: [ | "Load" [ "Verbose" | ] [ ne_string | IDENT ] | "Declare" "ML" "Module" LIST1 ne_string | "Locate" locatable -| "Add" "LoadPath" ne_string as_dirpath -| "Add" "Rec" "LoadPath" ne_string as_dirpath +| "Add" "LoadPath" ne_string "as" dirpath +| "Add" "Rec" "LoadPath" ne_string "as" dirpath | "Remove" "LoadPath" ne_string | "Type" lconstr | "Print" printable @@ -522,7 +522,6 @@ command: [ | "Print" "Namespace" dirpath | "Inspect" natural | "Add" "ML" "Path" ne_string -| "Add" "Rec" "ML" "Path" ne_string | "Set" option_table option_setting | "Unset" option_table | "Print" "Table" option_table @@ -655,6 +654,7 @@ command: [ | "Add" "CstOp" constr (* micromega plugin *) | "Add" "BinRel" constr (* micromega plugin *) | "Add" "PropOp" constr (* micromega plugin *) +| "Add" "PropBinOp" constr (* micromega plugin *) | "Add" "PropUOp" constr (* micromega plugin *) | "Add" "Spec" constr (* micromega plugin *) | "Add" "BinOpSpec" constr (* micromega plugin *) @@ -924,16 +924,16 @@ reduce: [ | ] -one_decl_notation: [ -| ne_lstring ":=" constr OPT [ ":" IDENT ] +decl_notation: [ +| ne_lstring ":=" constr only_parsing OPT [ ":" IDENT ] ] decl_sep: [ | "and" ] -decl_notation: [ -| "where" LIST1 one_decl_notation SEP decl_sep +decl_notations: [ +| "where" LIST1 decl_notation SEP decl_sep | ] @@ -943,7 +943,7 @@ opt_constructors_or_fields: [ ] inductive_definition: [ -| opt_coercion ident_decl binders OPT [ "|" binders ] OPT [ ":" lconstr ] opt_constructors_or_fields decl_notation +| opt_coercion ident_decl binders OPT [ "|" binders ] OPT [ ":" lconstr ] opt_constructors_or_fields decl_notations ] constructor_list_or_record_decl: [ @@ -961,11 +961,11 @@ opt_coercion: [ ] rec_definition: [ -| ident_decl binders_fixannot type_cstr OPT [ ":=" lconstr ] decl_notation +| ident_decl binders_fixannot type_cstr OPT [ ":=" lconstr ] decl_notations ] corec_definition: [ -| ident_decl binders type_cstr OPT [ ":=" lconstr ] decl_notation +| ident_decl binders type_cstr OPT [ ":=" lconstr ] decl_notations ] scheme: [ @@ -982,7 +982,7 @@ scheme_kind: [ ] record_field: [ -| LIST0 quoted_attributes record_binder OPT [ "|" natural ] decl_notation +| LIST0 quoted_attributes record_binder OPT [ "|" natural ] decl_notations ] record_fields: [ @@ -1148,7 +1148,7 @@ module_type: [ ] section_subset_expr: [ -| only_starredidentrefs LIST0 starredidentref +| test_only_starredidentrefs LIST0 starredidentref | ssexpr35 ] @@ -1172,8 +1172,8 @@ ssexpr50: [ ssexpr0: [ | starredidentref -| "(" only_starredidentrefs LIST0 starredidentref ")" -| "(" only_starredidentrefs LIST0 starredidentref ")" "*" +| "(" test_only_starredidentrefs LIST0 starredidentref ")" +| "(" test_only_starredidentrefs LIST0 starredidentref ")" "*" | "(" ssexpr35 ")" | "(" ssexpr35 ")" "*" ] @@ -1331,10 +1331,6 @@ option_table: [ | LIST1 IDENT ] -as_dirpath: [ -| OPT [ "as" dirpath ] -] - ne_in_or_out_modules: [ | "inside" LIST1 global | "outside" LIST1 global @@ -1684,6 +1680,8 @@ simple_tactic: [ | "eenough" test_lpar_id_colon "(" identref ":" lconstr ")" by_tactic | "assert" constr as_ipat by_tactic | "eassert" constr as_ipat by_tactic +| "pose" "proof" test_lpar_id_coloneq "(" identref ":=" lconstr ")" +| "epose" "proof" test_lpar_id_coloneq "(" identref ":=" lconstr ")" | "pose" "proof" lconstr as_ipat | "epose" "proof" lconstr as_ipat | "enough" constr as_ipat by_tactic @@ -1740,10 +1738,11 @@ simple_tactic: [ | "psatz_R" tactic (* micromega plugin *) | "psatz_Q" int_or_var tactic (* micromega plugin *) | "psatz_Q" tactic (* micromega plugin *) -| "zify_iter_specs" tactic (* micromega plugin *) +| "zify_iter_specs" (* micromega plugin *) | "zify_op" (* micromega plugin *) | "zify_saturate" (* micromega plugin *) | "zify_iter_let" tactic (* micromega plugin *) +| "zify_elim_let" (* micromega plugin *) | "nsatz_compute" constr (* nsatz plugin *) | "omega" (* omega plugin *) | "rtauto" diff --git a/doc/tools/docgram/orderedGrammar b/doc/tools/docgram/orderedGrammar index 908e3ccd51..f26a174722 100644 --- a/doc/tools/docgram/orderedGrammar +++ b/doc/tools/docgram/orderedGrammar @@ -58,6 +58,11 @@ arg: [ | term1 ] +one_term: [ +| term1 +| "@" qualid OPT univ_annot +] + term1: [ | term_projection | term0 "%" ident @@ -238,13 +243,8 @@ fix_body: [ fixannot: [ | "{" "struct" ident "}" -| "{" "wf" term1_extended ident "}" -| "{" "measure" term1_extended OPT ident OPT term1_extended "}" -] - -term1_extended: [ -| term1 -| "@" qualid OPT univ_annot +| "{" "wf" one_term ident "}" +| "{" "measure" one_term OPT ident OPT one_term "}" ] term_cofix: [ @@ -400,7 +400,7 @@ decl_notations: [ ] decl_notation: [ -| string ":=" term1_extended OPT [ ":" ident ] +| string ":=" one_term OPT ( "(" "only" "parsing" ")" ) OPT [ ":" ident ] ] register_token: [ @@ -484,16 +484,16 @@ red_expr: [ | "vm_compute" OPT ref_or_pattern_occ | "native_compute" OPT ref_or_pattern_occ | "unfold" LIST1 unfold_occ SEP "," -| "fold" LIST1 term1_extended +| "fold" LIST1 one_term | "pattern" LIST1 pattern_occ SEP "," | ident ] delta_flag: [ -| OPT "-" "[" LIST1 smart_global "]" +| OPT "-" "[" LIST1 smart_qualid "]" ] -smart_global: [ +smart_qualid: [ | qualid | by_notation ] @@ -518,8 +518,8 @@ red_flags: [ ] ref_or_pattern_occ: [ -| smart_global OPT ( "at" occs_nums ) -| term1_extended OPT ( "at" occs_nums ) +| smart_qualid OPT ( "at" occs_nums ) +| one_term OPT ( "at" occs_nums ) ] occs_nums: [ @@ -538,11 +538,11 @@ int_or_var: [ ] unfold_occ: [ -| smart_global OPT ( "at" occs_nums ) +| smart_qualid OPT ( "at" occs_nums ) ] pattern_occ: [ -| term1_extended OPT ( "at" occs_nums ) +| one_term OPT ( "at" occs_nums ) ] finite_token: [ @@ -587,11 +587,11 @@ scheme: [ ] scheme_kind: [ -| "Induction" "for" smart_global "Sort" sort_family -| "Minimality" "for" smart_global "Sort" sort_family -| "Elimination" "for" smart_global "Sort" sort_family -| "Case" "for" smart_global "Sort" sort_family -| "Equality" "for" smart_global +| "Induction" "for" smart_qualid "Sort" sort_family +| "Minimality" "for" smart_qualid "Sort" sort_family +| "Elimination" "for" smart_qualid "Sort" sort_family +| "Case" "for" smart_qualid "Sort" sort_family +| "Equality" "for" smart_qualid ] sort_family: [ @@ -615,21 +615,21 @@ gallina_ext: [ | "Export" LIST1 qualid | "Include" module_type_inl LIST0 ( "<+" module_expr_inl ) | "Include" "Type" module_type_inl LIST0 ( "<+" module_type_inl ) -| "Transparent" LIST1 smart_global -| "Opaque" LIST1 smart_global -| "Strategy" LIST1 [ strategy_level "[" LIST1 smart_global "]" ] +| "Transparent" LIST1 smart_qualid +| "Opaque" LIST1 smart_qualid +| "Strategy" LIST1 [ strategy_level "[" LIST1 smart_qualid "]" ] | "Canonical" OPT "Structure" qualid OPT [ OPT univ_decl def_body ] | "Canonical" OPT "Structure" by_notation | "Coercion" qualid OPT univ_decl def_body -| "Identity" "Coercion" ident ":" class_rawexpr ">->" class_rawexpr -| "Coercion" qualid ":" class_rawexpr ">->" class_rawexpr -| "Coercion" by_notation ":" class_rawexpr ">->" class_rawexpr +| "Identity" "Coercion" ident ":" class ">->" class +| "Coercion" qualid ":" class ">->" class +| "Coercion" by_notation ":" class ">->" class | "Context" LIST1 binder | "Instance" instance_name ":" term hint_info [ ":=" "{" [ LIST1 field_def SEP ";" | ] "}" | ":=" term | ] | "Existing" "Instance" qualid hint_info | "Existing" "Instances" LIST1 qualid OPT [ "|" num ] | "Existing" "Class" qualid -| "Arguments" smart_global LIST0 argument_spec_block LIST0 [ "," LIST0 more_implicits_block ] OPT [ ":" LIST1 arguments_modifier SEP "," ] +| "Arguments" smart_qualid LIST0 argument_spec_block LIST0 [ "," LIST0 more_implicits_block ] OPT [ ":" LIST1 arguments_modifier SEP "," ] | "Implicit" "Type" reserv_list | "Implicit" "Types" reserv_list | "Generalizable" [ "All" "Variables" | "No" "Variables" | [ "Variable" | "Variables" ] LIST1 ident ] @@ -643,14 +643,8 @@ option_setting: [ | string ] -class_rawexpr: [ -| "Funclass" -| "Sortclass" -| smart_global -] - hint_info: [ -| "|" OPT num OPT term1_extended +| "|" OPT num OPT one_term | ] @@ -780,11 +774,11 @@ command: [ | "Load" [ "Verbose" | ] [ string | ident ] | "Declare" "ML" "Module" LIST1 string | "Locate" locatable -| "Add" "LoadPath" string as_dirpath -| "Add" "Rec" "LoadPath" string as_dirpath +| "Add" "LoadPath" string "as" dirpath +| "Add" "Rec" "LoadPath" string "as" dirpath | "Remove" "LoadPath" string | "Type" term -| "Print" "Term" smart_global OPT ( "@{" LIST0 name "}" ) +| "Print" "Term" smart_qualid OPT ( "@{" LIST0 name "}" ) | "Print" "All" | "Print" "Section" qualid | "Print" "Grammar" ident @@ -798,36 +792,35 @@ command: [ | "Print" "Graph" | "Print" "Classes" | "Print" "TypeClasses" -| "Print" "Instances" smart_global +| "Print" "Instances" smart_qualid | "Print" "Coercions" -| "Print" "Coercion" "Paths" class_rawexpr class_rawexpr -| "Print" "Canonical" "Projections" LIST0 smart_global +| "Print" "Coercion" "Paths" class class +| "Print" "Canonical" "Projections" LIST0 smart_qualid | "Print" "Typing" "Flags" | "Print" "Tables" | "Print" "Options" | "Print" "Hint" -| "Print" "Hint" smart_global +| "Print" "Hint" smart_qualid | "Print" "Hint" "*" | "Print" "HintDb" ident | "Print" "Scopes" | "Print" "Scope" ident | "Print" "Visibility" OPT ident -| "Print" "Implicit" smart_global +| "Print" "Implicit" smart_qualid | "Print" OPT "Sorted" "Universes" OPT ( "Subgraph" "(" LIST0 qualid ")" ) OPT string -| "Print" "Assumptions" smart_global -| "Print" "Opaque" "Dependencies" smart_global -| "Print" "Transparent" "Dependencies" smart_global -| "Print" "All" "Dependencies" smart_global -| "Print" "Strategy" smart_global +| "Print" "Assumptions" smart_qualid +| "Print" "Opaque" "Dependencies" smart_qualid +| "Print" "Transparent" "Dependencies" smart_qualid +| "Print" "All" "Dependencies" smart_qualid +| "Print" "Strategy" smart_qualid | "Print" "Strategies" | "Print" "Registered" -| "Print" smart_global OPT ( "@{" LIST0 name "}" ) +| "Print" smart_qualid OPT ( "@{" LIST0 name "}" ) | "Print" "Module" "Type" qualid | "Print" "Module" qualid | "Print" "Namespace" dirpath | "Inspect" num | "Add" "ML" "Path" string -| "Add" "Rec" "ML" "Path" string | "Set" LIST1 ident option_setting | "Unset" LIST1 ident | "Print" "Table" LIST1 ident @@ -849,7 +842,7 @@ command: [ | "Debug" "Off" | "Declare" "Reduction" ident ":=" red_expr | "Declare" "Custom" "Entry" ident -| "Derive" ident "SuchThat" term1_extended "As" ident (* derive plugin *) +| "Derive" ident "SuchThat" one_term "As" ident (* derive plugin *) | "Proof" | "Proof" "Mode" string | "Proof" term @@ -907,31 +900,31 @@ command: [ | "Obligations" | "Preterm" "of" ident | "Preterm" -| "Add" "Relation" term1_extended term1_extended "reflexivity" "proved" "by" term1_extended "symmetry" "proved" "by" term1_extended "as" ident -| "Add" "Relation" term1_extended term1_extended "reflexivity" "proved" "by" term1_extended "as" ident -| "Add" "Relation" term1_extended term1_extended "as" ident -| "Add" "Relation" term1_extended term1_extended "symmetry" "proved" "by" term1_extended "as" ident -| "Add" "Relation" term1_extended term1_extended "symmetry" "proved" "by" term1_extended "transitivity" "proved" "by" term1_extended "as" ident -| "Add" "Relation" term1_extended term1_extended "reflexivity" "proved" "by" term1_extended "transitivity" "proved" "by" term1_extended "as" ident -| "Add" "Relation" term1_extended term1_extended "reflexivity" "proved" "by" term1_extended "symmetry" "proved" "by" term1_extended "transitivity" "proved" "by" term1_extended "as" ident -| "Add" "Relation" term1_extended term1_extended "transitivity" "proved" "by" term1_extended "as" ident -| "Add" "Parametric" "Relation" LIST0 binder ":" term1_extended term1_extended "reflexivity" "proved" "by" term1_extended "symmetry" "proved" "by" term1_extended "as" ident -| "Add" "Parametric" "Relation" LIST0 binder ":" term1_extended term1_extended "reflexivity" "proved" "by" term1_extended "as" ident -| "Add" "Parametric" "Relation" LIST0 binder ":" term1_extended term1_extended "as" ident -| "Add" "Parametric" "Relation" LIST0 binder ":" term1_extended term1_extended "symmetry" "proved" "by" term1_extended "as" ident -| "Add" "Parametric" "Relation" LIST0 binder ":" term1_extended term1_extended "symmetry" "proved" "by" term1_extended "transitivity" "proved" "by" term1_extended "as" ident -| "Add" "Parametric" "Relation" LIST0 binder ":" term1_extended term1_extended "reflexivity" "proved" "by" term1_extended "transitivity" "proved" "by" term1_extended "as" ident -| "Add" "Parametric" "Relation" LIST0 binder ":" term1_extended term1_extended "reflexivity" "proved" "by" term1_extended "symmetry" "proved" "by" term1_extended "transitivity" "proved" "by" term1_extended "as" ident -| "Add" "Parametric" "Relation" LIST0 binder ":" term1_extended term1_extended "transitivity" "proved" "by" term1_extended "as" ident -| "Add" "Setoid" term1_extended term1_extended term1_extended "as" ident -| "Add" "Parametric" "Setoid" LIST0 binder ":" term1_extended term1_extended term1_extended "as" ident -| "Add" "Morphism" term1_extended ":" ident -| "Declare" "Morphism" term1_extended ":" ident -| "Add" "Morphism" term1_extended "with" "signature" term "as" ident -| "Add" "Parametric" "Morphism" LIST0 binder ":" term1_extended "with" "signature" term "as" ident +| "Add" "Relation" one_term one_term "reflexivity" "proved" "by" one_term "symmetry" "proved" "by" one_term "as" ident +| "Add" "Relation" one_term one_term "reflexivity" "proved" "by" one_term "as" ident +| "Add" "Relation" one_term one_term "as" ident +| "Add" "Relation" one_term one_term "symmetry" "proved" "by" one_term "as" ident +| "Add" "Relation" one_term one_term "symmetry" "proved" "by" one_term "transitivity" "proved" "by" one_term "as" ident +| "Add" "Relation" one_term one_term "reflexivity" "proved" "by" one_term "transitivity" "proved" "by" one_term "as" ident +| "Add" "Relation" one_term one_term "reflexivity" "proved" "by" one_term "symmetry" "proved" "by" one_term "transitivity" "proved" "by" one_term "as" ident +| "Add" "Relation" one_term one_term "transitivity" "proved" "by" one_term "as" ident +| "Add" "Parametric" "Relation" LIST0 binder ":" one_term one_term "reflexivity" "proved" "by" one_term "symmetry" "proved" "by" one_term "as" ident +| "Add" "Parametric" "Relation" LIST0 binder ":" one_term one_term "reflexivity" "proved" "by" one_term "as" ident +| "Add" "Parametric" "Relation" LIST0 binder ":" one_term one_term "as" ident +| "Add" "Parametric" "Relation" LIST0 binder ":" one_term one_term "symmetry" "proved" "by" one_term "as" ident +| "Add" "Parametric" "Relation" LIST0 binder ":" one_term one_term "symmetry" "proved" "by" one_term "transitivity" "proved" "by" one_term "as" ident +| "Add" "Parametric" "Relation" LIST0 binder ":" one_term one_term "reflexivity" "proved" "by" one_term "transitivity" "proved" "by" one_term "as" ident +| "Add" "Parametric" "Relation" LIST0 binder ":" one_term one_term "reflexivity" "proved" "by" one_term "symmetry" "proved" "by" one_term "transitivity" "proved" "by" one_term "as" ident +| "Add" "Parametric" "Relation" LIST0 binder ":" one_term one_term "transitivity" "proved" "by" one_term "as" ident +| "Add" "Setoid" one_term one_term one_term "as" ident +| "Add" "Parametric" "Setoid" LIST0 binder ":" one_term one_term one_term "as" ident +| "Add" "Morphism" one_term ":" ident +| "Declare" "Morphism" one_term ":" ident +| "Add" "Morphism" one_term "with" "signature" term "as" ident +| "Add" "Parametric" "Morphism" LIST0 binder ":" one_term "with" "signature" term "as" ident | "Grab" "Existential" "Variables" | "Unshelve" -| "Declare" "Equivalent" "Keys" term1_extended term1_extended +| "Declare" "Equivalent" "Keys" one_term one_term | "Print" "Equivalent" "Keys" | "Optimize" "Proof" | "Optimize" "Heap" @@ -940,24 +933,25 @@ command: [ | "Show" "Ltac" "Profile" "CutOff" int | "Show" "Ltac" "Profile" string | "Show" "Lia" "Profile" (* micromega plugin *) -| "Add" "InjTyp" term1_extended (* micromega plugin *) -| "Add" "BinOp" term1_extended (* micromega plugin *) -| "Add" "UnOp" term1_extended (* micromega plugin *) -| "Add" "CstOp" term1_extended (* micromega plugin *) -| "Add" "BinRel" term1_extended (* micromega plugin *) -| "Add" "PropOp" term1_extended (* micromega plugin *) -| "Add" "PropUOp" term1_extended (* micromega plugin *) -| "Add" "Spec" term1_extended (* micromega plugin *) -| "Add" "BinOpSpec" term1_extended (* micromega plugin *) -| "Add" "UnOpSpec" term1_extended (* micromega plugin *) -| "Add" "Saturate" term1_extended (* micromega plugin *) +| "Add" "InjTyp" one_term (* micromega plugin *) +| "Add" "BinOp" one_term (* micromega plugin *) +| "Add" "UnOp" one_term (* micromega plugin *) +| "Add" "CstOp" one_term (* micromega plugin *) +| "Add" "BinRel" one_term (* micromega plugin *) +| "Add" "PropOp" one_term (* micromega plugin *) +| "Add" "PropBinOp" one_term (* micromega plugin *) +| "Add" "PropUOp" one_term (* micromega plugin *) +| "Add" "Spec" one_term (* micromega plugin *) +| "Add" "BinOpSpec" one_term (* micromega plugin *) +| "Add" "UnOpSpec" one_term (* micromega plugin *) +| "Add" "Saturate" one_term (* micromega plugin *) | "Show" "Zify" "InjTyp" (* micromega plugin *) | "Show" "Zify" "BinOp" (* micromega plugin *) | "Show" "Zify" "UnOp" (* micromega plugin *) | "Show" "Zify" "CstOp" (* micromega plugin *) | "Show" "Zify" "BinRel" (* micromega plugin *) | "Show" "Zify" "Spec" (* micromega plugin *) -| "Add" "Ring" ident ":" term1_extended OPT ( "(" LIST1 ring_mod SEP "," ")" ) (* setoid_ring plugin *) +| "Add" "Ring" ident ":" one_term OPT ( "(" LIST1 ring_mod SEP "," ")" ) (* setoid_ring plugin *) | "Hint" "Cut" "[" hints_path "]" opthints | "Typeclasses" "Transparent" LIST0 qualid | "Typeclasses" "Opaque" LIST0 qualid @@ -996,20 +990,20 @@ command: [ | "Show" "Extraction" (* extraction plugin *) | "Functional" "Case" fun_scheme_arg (* funind plugin *) | "Generate" "graph" "for" qualid (* funind plugin *) -| "Hint" "Rewrite" orient LIST1 term1_extended ":" LIST0 ident -| "Hint" "Rewrite" orient LIST1 term1_extended "using" ltac_expr ":" LIST0 ident -| "Hint" "Rewrite" orient LIST1 term1_extended -| "Hint" "Rewrite" orient LIST1 term1_extended "using" ltac_expr -| "Derive" "Inversion_clear" ident "with" term1_extended "Sort" sort_family -| "Derive" "Inversion_clear" ident "with" term1_extended -| "Derive" "Inversion" ident "with" term1_extended "Sort" sort_family -| "Derive" "Inversion" ident "with" term1_extended -| "Derive" "Dependent" "Inversion" ident "with" term1_extended "Sort" sort_family -| "Derive" "Dependent" "Inversion_clear" ident "with" term1_extended "Sort" sort_family -| "Declare" "Left" "Step" term1_extended -| "Declare" "Right" "Step" term1_extended +| "Hint" "Rewrite" orient LIST1 one_term ":" LIST0 ident +| "Hint" "Rewrite" orient LIST1 one_term "using" ltac_expr ":" LIST0 ident +| "Hint" "Rewrite" orient LIST1 one_term +| "Hint" "Rewrite" orient LIST1 one_term "using" ltac_expr +| "Derive" "Inversion_clear" ident "with" one_term "Sort" sort_family +| "Derive" "Inversion_clear" ident "with" one_term +| "Derive" "Inversion" ident "with" one_term "Sort" sort_family +| "Derive" "Inversion" ident "with" one_term +| "Derive" "Dependent" "Inversion" ident "with" one_term "Sort" sort_family +| "Derive" "Dependent" "Inversion_clear" ident "with" one_term "Sort" sort_family +| "Declare" "Left" "Step" one_term +| "Declare" "Right" "Step" one_term | "Print" "Rings" (* setoid_ring plugin *) -| "Add" "Field" ident ":" term1_extended OPT ( "(" LIST1 field_mod SEP "," ")" ) (* setoid_ring plugin *) +| "Add" "Field" ident ":" one_term OPT ( "(" LIST1 field_mod SEP "," ")" ) (* setoid_ring plugin *) | "Print" "Fields" (* setoid_ring plugin *) | "Numeral" "Notation" qualid qualid qualid ":" ident OPT numnotoption | "String" "Notation" qualid qualid qualid ":" ident @@ -1059,8 +1053,8 @@ dirpath: [ ] locatable: [ -| smart_global -| "Term" smart_global +| smart_qualid +| "Term" smart_qualid | "File" string | "Library" qualid | "Module" qualid @@ -1071,19 +1065,15 @@ option_ref_value: [ | string ] -as_dirpath: [ -| OPT [ "as" dirpath ] -] - comment: [ -| term1_extended +| one_term | string | num ] reference_or_constr: [ | qualid -| term1_extended +| one_term ] hint: [ @@ -1100,7 +1090,7 @@ hint: [ | "Mode" qualid LIST1 [ "+" | "!" | "-" ] | "Unfold" LIST1 qualid | "Constructors" LIST1 qualid -| "Extern" num OPT term1_extended "=>" ltac_expr +| "Extern" num OPT one_term "=>" ltac_expr ] constr_body: [ @@ -1157,23 +1147,23 @@ fun_scheme_arg: [ ] ring_mod: [ -| "decidable" term1_extended (* setoid_ring plugin *) +| "decidable" one_term (* setoid_ring plugin *) | "abstract" (* setoid_ring plugin *) -| "morphism" term1_extended (* setoid_ring plugin *) +| "morphism" one_term (* setoid_ring plugin *) | "constants" "[" ltac_expr "]" (* setoid_ring plugin *) -| "closed" "[" LIST1 qualid "]" (* setoid_ring plugin *) | "preprocess" "[" ltac_expr "]" (* setoid_ring plugin *) | "postprocess" "[" ltac_expr "]" (* setoid_ring plugin *) -| "setoid" term1_extended term1_extended (* setoid_ring plugin *) -| "sign" term1_extended (* setoid_ring plugin *) -| "power" term1_extended "[" LIST1 qualid "]" (* setoid_ring plugin *) -| "power_tac" term1_extended "[" ltac_expr "]" (* setoid_ring plugin *) -| "div" term1_extended (* setoid_ring plugin *) +| "setoid" one_term one_term (* setoid_ring plugin *) +| "sign" one_term (* setoid_ring plugin *) +| "power" one_term "[" LIST1 qualid "]" (* setoid_ring plugin *) +| "power_tac" one_term "[" ltac_expr "]" (* setoid_ring plugin *) +| "div" one_term (* setoid_ring plugin *) +| "closed" "[" LIST1 qualid "]" (* setoid_ring plugin *) ] field_mod: [ | ring_mod (* setoid_ring plugin *) -| "completeness" term1_extended (* setoid_ring plugin *) +| "completeness" one_term (* setoid_ring plugin *) ] debug: [ @@ -1216,15 +1206,21 @@ query_command: [ | "Eval" red_expr "in" term "." | "Compute" term "." | "Check" term "." -| "About" smart_global OPT ( "@{" LIST0 name "}" ) "." -| "SearchHead" term1_extended in_or_out_modules "." -| "SearchPattern" term1_extended in_or_out_modules "." -| "SearchRewrite" term1_extended in_or_out_modules "." +| "About" smart_qualid OPT ( "@{" LIST0 name "}" ) "." +| "SearchHead" one_term in_or_out_modules "." +| "SearchPattern" one_term in_or_out_modules "." +| "SearchRewrite" one_term in_or_out_modules "." | "Search" searchabout_query searchabout_queries "." | "SearchAbout" searchabout_query searchabout_queries "." | "SearchAbout" "[" LIST1 searchabout_query "]" in_or_out_modules "." ] +class: [ +| "Funclass" +| "Sortclass" +| smart_qualid +] + ne_in_or_out_modules: [ | "inside" LIST1 qualid | "outside" LIST1 qualid @@ -1242,7 +1238,7 @@ positive_search_mark: [ searchabout_query: [ | positive_search_mark string OPT ( "%" ident ) -| positive_search_mark term1_extended +| positive_search_mark one_term ] searchabout_queries: [ @@ -1256,10 +1252,10 @@ syntax: [ | "Close" "Scope" ident | "Delimit" "Scope" ident "with" ident | "Undelimit" "Scope" ident -| "Bind" "Scope" ident "with" LIST1 class_rawexpr -| "Infix" string ":=" term1_extended OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] OPT [ ":" ident ] -| "Notation" ident LIST0 ident ":=" term1_extended OPT ( "(" "only" "parsing" ")" ) -| "Notation" string ":=" term1_extended OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] OPT [ ":" ident ] +| "Bind" "Scope" ident "with" LIST1 class +| "Infix" string ":=" one_term OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] OPT [ ":" ident ] +| "Notation" ident LIST0 ident ":=" one_term OPT ( "(" "only" "parsing" ")" ) +| "Notation" string ":=" one_term OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] OPT [ ":" ident ] | "Format" "Notation" string string string | "Reserved" "Infix" string OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] | "Reserved" "Notation" string OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] @@ -1314,17 +1310,17 @@ at_level_opt: [ simple_tactic: [ | "reflexivity" -| "exact" term1_extended +| "exact" one_term | "assumption" | "etransitivity" -| "cut" term1_extended -| "exact_no_check" term1_extended -| "vm_cast_no_check" term1_extended -| "native_cast_no_check" term1_extended -| "casetype" term1_extended -| "elimtype" term1_extended -| "lapply" term1_extended -| "transitivity" term1_extended +| "cut" one_term +| "exact_no_check" one_term +| "vm_cast_no_check" one_term +| "native_cast_no_check" one_term +| "casetype" one_term +| "elimtype" one_term +| "lapply" one_term +| "transitivity" one_term | "left" | "eleft" | "left" "with" bindings @@ -1377,11 +1373,11 @@ simple_tactic: [ | "clear" LIST0 ident | "clear" "-" LIST1 ident | "clearbody" LIST1 ident -| "generalize" "dependent" term1_extended -| "replace" term1_extended "with" term1_extended clause_dft_concl by_arg_tac -| "replace" "->" term1_extended clause_dft_concl -| "replace" "<-" term1_extended clause_dft_concl -| "replace" term1_extended clause_dft_concl +| "generalize" "dependent" one_term +| "replace" one_term "with" one_term clause_dft_concl by_arg_tac +| "replace" "->" one_term clause_dft_concl +| "replace" "<-" one_term clause_dft_concl +| "replace" one_term clause_dft_concl | "simplify_eq" | "simplify_eq" destruction_arg | "esimplify_eq" @@ -1400,64 +1396,64 @@ simple_tactic: [ | "einjection" destruction_arg "as" LIST0 simple_intropattern | "simple" "injection" | "simple" "injection" destruction_arg -| "dependent" "rewrite" orient term1_extended -| "dependent" "rewrite" orient term1_extended "in" ident -| "cutrewrite" orient term1_extended -| "cutrewrite" orient term1_extended "in" ident -| "decompose" "sum" term1_extended -| "decompose" "record" term1_extended -| "absurd" term1_extended +| "dependent" "rewrite" orient one_term +| "dependent" "rewrite" orient one_term "in" ident +| "cutrewrite" orient one_term +| "cutrewrite" orient one_term "in" ident +| "decompose" "sum" one_term +| "decompose" "record" one_term +| "absurd" one_term | "contradiction" OPT constr_with_bindings | "autorewrite" "with" LIST1 ident clause_dft_concl | "autorewrite" "with" LIST1 ident clause_dft_concl "using" ltac_expr | "autorewrite" "*" "with" LIST1 ident clause_dft_concl | "autorewrite" "*" "with" LIST1 ident clause_dft_concl "using" ltac_expr -| "rewrite" "*" orient term1_extended "in" ident "at" occurrences by_arg_tac -| "rewrite" "*" orient term1_extended "at" occurrences "in" ident by_arg_tac -| "rewrite" "*" orient term1_extended "in" ident by_arg_tac -| "rewrite" "*" orient term1_extended "at" occurrences by_arg_tac -| "rewrite" "*" orient term1_extended by_arg_tac -| "refine" term1_extended -| "simple" "refine" term1_extended -| "notypeclasses" "refine" term1_extended -| "simple" "notypeclasses" "refine" term1_extended +| "rewrite" "*" orient one_term "in" ident "at" occurrences by_arg_tac +| "rewrite" "*" orient one_term "at" occurrences "in" ident by_arg_tac +| "rewrite" "*" orient one_term "in" ident by_arg_tac +| "rewrite" "*" orient one_term "at" occurrences by_arg_tac +| "rewrite" "*" orient one_term by_arg_tac +| "refine" one_term +| "simple" "refine" one_term +| "notypeclasses" "refine" one_term +| "simple" "notypeclasses" "refine" one_term | "solve_constraints" | "subst" LIST1 ident | "subst" | "simple" "subst" | "evar" "(" ident ":" term ")" -| "evar" term1_extended +| "evar" one_term | "instantiate" "(" ident ":=" term ")" | "instantiate" "(" int ":=" term ")" hloc | "instantiate" -| "stepl" term1_extended "by" ltac_expr -| "stepl" term1_extended -| "stepr" term1_extended "by" ltac_expr -| "stepr" term1_extended +| "stepl" one_term "by" ltac_expr +| "stepl" one_term +| "stepr" one_term "by" ltac_expr +| "stepr" one_term | "generalize_eqs" ident | "dependent" "generalize_eqs" ident | "generalize_eqs_vars" ident | "dependent" "generalize_eqs_vars" ident | "specialize_eqs" ident -| "hresolve_core" "(" ident ":=" term1_extended ")" "at" int_or_var "in" term1_extended -| "hresolve_core" "(" ident ":=" term1_extended ")" "in" term1_extended +| "hresolve_core" "(" ident ":=" one_term ")" "at" int_or_var "in" one_term +| "hresolve_core" "(" ident ":=" one_term ")" "in" one_term | "hget_evar" int_or_var | "destauto" | "destauto" "in" ident | "transparent_abstract" ltac_expr3 | "transparent_abstract" ltac_expr3 "using" ident -| "constr_eq" term1_extended term1_extended -| "constr_eq_strict" term1_extended term1_extended -| "constr_eq_nounivs" term1_extended term1_extended -| "is_evar" term1_extended -| "has_evar" term1_extended -| "is_var" term1_extended -| "is_fix" term1_extended -| "is_cofix" term1_extended -| "is_ind" term1_extended -| "is_constructor" term1_extended -| "is_proj" term1_extended -| "is_const" term1_extended +| "constr_eq" one_term one_term +| "constr_eq_strict" one_term one_term +| "constr_eq_nounivs" one_term one_term +| "is_evar" one_term +| "has_evar" one_term +| "is_var" one_term +| "is_fix" one_term +| "is_cofix" one_term +| "is_ind" one_term +| "is_constructor" one_term +| "is_proj" one_term +| "is_const" one_term | "shelve" | "shelve_unifiable" | "unshelve" ltac_expr1 @@ -1466,7 +1462,7 @@ simple_tactic: [ | "swap" int_or_var int_or_var | "revgoals" | "guard" int_or_var comparison int_or_var -| "decompose" "[" LIST1 term1_extended "]" term1_extended +| "decompose" "[" LIST1 one_term "]" one_term | "optimize_heap" | "start" "ltac" "profiling" | "stop" "ltac" "profiling" @@ -1478,14 +1474,14 @@ simple_tactic: [ | "finish_timing" OPT string | "finish_timing" "(" string ")" OPT string | "eassumption" -| "eexact" term1_extended +| "eexact" one_term | "trivial" auto_using hintbases | "info_trivial" auto_using hintbases | "debug" "trivial" auto_using hintbases | "auto" OPT int_or_var auto_using hintbases | "info_auto" OPT int_or_var auto_using hintbases | "debug" "auto" OPT int_or_var auto_using hintbases -| "prolog" "[" LIST0 term1_extended "]" int_or_var +| "prolog" "[" LIST0 one_term "]" int_or_var | "eauto" OPT int_or_var OPT int_or_var auto_using hintbases | "new" "auto" OPT int_or_var auto_using hintbases | "debug" "eauto" OPT int_or_var OPT int_or_var auto_using hintbases @@ -1494,17 +1490,17 @@ simple_tactic: [ | "autounfold" hintbases clause_dft_concl | "autounfold_one" hintbases "in" ident | "autounfold_one" hintbases -| "unify" term1_extended term1_extended -| "unify" term1_extended term1_extended "with" ident -| "convert_concl_no_check" term1_extended +| "unify" one_term one_term +| "unify" one_term one_term "with" ident +| "convert_concl_no_check" one_term | "typeclasses" "eauto" "bfs" OPT int_or_var "with" LIST1 ident | "typeclasses" "eauto" OPT int_or_var "with" LIST1 ident | "typeclasses" "eauto" OPT int_or_var -| "head_of_constr" ident term1_extended -| "not_evar" term1_extended -| "is_ground" term1_extended -| "autoapply" term1_extended "using" ident -| "autoapply" term1_extended "with" ident +| "head_of_constr" ident one_term +| "not_evar" one_term +| "is_ground" one_term +| "autoapply" one_term "using" ident +| "autoapply" one_term "with" ident | "progress_evars" ltac_expr | "rewrite_strat" rewstrategy | "rewrite_db" ident "in" ident @@ -1518,10 +1514,10 @@ simple_tactic: [ | "setoid_symmetry" | "setoid_symmetry" "in" ident | "setoid_reflexivity" -| "setoid_transitivity" term1_extended +| "setoid_transitivity" one_term | "setoid_etransitivity" | "decide" "equality" -| "compare" term1_extended term1_extended +| "compare" one_term one_term | "rewrite_strat" rewstrategy "in" ident | "intros" intropattern_list_opt | "eintros" intropattern_list_opt @@ -1536,41 +1532,43 @@ simple_tactic: [ | "fix" ident num "with" LIST1 fixdecl | "cofix" ident "with" LIST1 cofixdecl | "pose" bindings_with_parameters -| "pose" term1_extended as_name +| "pose" one_term as_name | "epose" bindings_with_parameters -| "epose" term1_extended as_name +| "epose" one_term as_name | "set" bindings_with_parameters clause_dft_concl -| "set" term1_extended as_name clause_dft_concl +| "set" one_term as_name clause_dft_concl | "eset" bindings_with_parameters clause_dft_concl -| "eset" term1_extended as_name clause_dft_concl -| "remember" term1_extended as_name eqn_ipat clause_dft_all -| "eremember" term1_extended as_name eqn_ipat clause_dft_all +| "eset" one_term as_name clause_dft_concl +| "remember" one_term as_name eqn_ipat clause_dft_all +| "eremember" one_term as_name eqn_ipat clause_dft_all | "assert" "(" ident ":=" term ")" | "eassert" "(" ident ":=" term ")" | "assert" "(" ident ":" term ")" by_tactic | "eassert" "(" ident ":" term ")" by_tactic | "enough" "(" ident ":" term ")" by_tactic | "eenough" "(" ident ":" term ")" by_tactic -| "assert" term1_extended as_ipat by_tactic -| "eassert" term1_extended as_ipat by_tactic +| "assert" one_term as_ipat by_tactic +| "eassert" one_term as_ipat by_tactic +| "pose" "proof" "(" ident ":=" term ")" +| "epose" "proof" "(" ident ":=" term ")" | "pose" "proof" term as_ipat | "epose" "proof" term as_ipat -| "enough" term1_extended as_ipat by_tactic -| "eenough" term1_extended as_ipat by_tactic -| "generalize" term1_extended -| "generalize" term1_extended LIST1 term1_extended -| "generalize" term1_extended OPT ( "at" occs_nums ) as_name LIST0 [ "," pattern_occ as_name ] +| "enough" one_term as_ipat by_tactic +| "eenough" one_term as_ipat by_tactic +| "generalize" one_term +| "generalize" one_term LIST1 one_term +| "generalize" one_term OPT ( "at" occs_nums ) as_name LIST0 [ "," pattern_occ as_name ] | "induction" induction_clause_list | "einduction" induction_clause_list | "destruct" induction_clause_list | "edestruct" induction_clause_list | "rewrite" LIST1 oriented_rewriter SEP "," clause_dft_concl by_tactic | "erewrite" LIST1 oriented_rewriter SEP "," clause_dft_concl by_tactic -| "dependent" [ "simple" "inversion" | "inversion" | "inversion_clear" ] quantified_hypothesis as_or_and_ipat OPT [ "with" term1_extended ] +| "dependent" [ "simple" "inversion" | "inversion" | "inversion_clear" ] quantified_hypothesis as_or_and_ipat OPT [ "with" one_term ] | "simple" "inversion" quantified_hypothesis as_or_and_ipat in_hyp_list | "inversion" quantified_hypothesis as_or_and_ipat in_hyp_list | "inversion_clear" quantified_hypothesis as_or_and_ipat in_hyp_list -| "inversion" quantified_hypothesis "using" term1_extended in_hyp_list +| "inversion" quantified_hypothesis "using" one_term in_hyp_list | "red" clause_dft_concl | "hnf" clause_dft_concl | "simpl" OPT delta_flag OPT ref_or_pattern_occ clause_dft_concl @@ -1581,7 +1579,7 @@ simple_tactic: [ | "vm_compute" OPT ref_or_pattern_occ clause_dft_concl | "native_compute" OPT ref_or_pattern_occ clause_dft_concl | "unfold" LIST1 unfold_occ SEP "," clause_dft_concl -| "fold" LIST1 term1_extended clause_dft_concl +| "fold" LIST1 one_term clause_dft_concl | "pattern" LIST1 pattern_occ SEP "," clause_dft_concl | "change" conversion clause_dft_concl | "change_no_check" conversion clause_dft_concl @@ -1589,16 +1587,16 @@ simple_tactic: [ | "rtauto" | "congruence" | "congruence" int -| "congruence" "with" LIST1 term1_extended -| "congruence" int "with" LIST1 term1_extended +| "congruence" "with" LIST1 one_term +| "congruence" int "with" LIST1 one_term | "f_equal" | "firstorder" OPT ltac_expr firstorder_using | "firstorder" OPT ltac_expr "with" LIST1 ident | "firstorder" OPT ltac_expr firstorder_using "with" LIST1 ident | "gintuition" OPT ltac_expr | "functional" "inversion" quantified_hypothesis OPT qualid (* funind plugin *) -| "functional" "induction" LIST1 term1_extended fun_ind_using with_names (* funind plugin *) -| "soft" "functional" "induction" LIST1 term1_extended fun_ind_using with_names (* funind plugin *) +| "functional" "induction" LIST1 one_term fun_ind_using with_names (* funind plugin *) +| "soft" "functional" "induction" LIST1 one_term fun_ind_using with_names (* funind plugin *) | "psatz_Z" int_or_var ltac_expr (* micromega plugin *) | "psatz_Z" ltac_expr (* micromega plugin *) | "xlia" ltac_expr (* micromega plugin *) @@ -1614,16 +1612,17 @@ simple_tactic: [ | "psatz_R" ltac_expr (* micromega plugin *) | "psatz_Q" int_or_var ltac_expr (* micromega plugin *) | "psatz_Q" ltac_expr (* micromega plugin *) -| "zify_iter_specs" ltac_expr (* micromega plugin *) +| "zify_iter_specs" (* micromega plugin *) | "zify_op" (* micromega plugin *) | "zify_saturate" (* micromega plugin *) | "zify_iter_let" ltac_expr (* micromega plugin *) -| "nsatz_compute" term1_extended (* nsatz plugin *) +| "zify_elim_let" (* micromega plugin *) +| "nsatz_compute" one_term (* nsatz plugin *) | "omega" (* omega plugin *) | "protect_fv" string "in" ident (* setoid_ring plugin *) | "protect_fv" string (* setoid_ring plugin *) -| "ring_lookup" ltac_expr0 "[" LIST0 term1_extended "]" LIST1 term1_extended (* setoid_ring plugin *) -| "field_lookup" ltac_expr "[" LIST0 term1_extended "]" LIST1 term1_extended (* setoid_ring plugin *) +| "ring_lookup" ltac_expr0 "[" LIST0 one_term "]" LIST1 one_term (* setoid_ring plugin *) +| "field_lookup" ltac_expr "[" LIST0 one_term "]" LIST1 one_term (* setoid_ring plugin *) ] hloc: [ @@ -1646,11 +1645,23 @@ by_arg_tac: [ ] in_clause: [ -| in_clause +| LIST0 hypident_occ SEP "," OPT ( "|-" OPT concl_occ ) +| "*" "|-" OPT concl_occ | "*" OPT ( "at" occs_nums ) -| "*" "|-" concl_occ -| LIST0 hypident_occ SEP "," "|-" concl_occ -| LIST0 hypident_occ SEP "," +] + +concl_occ: [ +| "*" OPT ( "at" occs_nums ) +] + +hypident_occ: [ +| hypident OPT ( "at" occs_nums ) +] + +hypident: [ +| ident +| "(" "type" "of" ident ")" +| "(" "value" "of" ident ")" ] as_ipat: [ @@ -1707,7 +1718,7 @@ induction_clause_list: [ ] auto_using: [ -| "using" LIST1 term1_extended SEP "," +| "using" LIST1 one_term SEP "," | ] @@ -1762,7 +1773,7 @@ simple_binding: [ bindings: [ | LIST1 simple_binding -| LIST1 term1_extended +| LIST1 one_term ] comparison: [ @@ -1783,16 +1794,6 @@ bindings_with_parameters: [ | "(" ident LIST0 simple_binder ":=" term ")" ] -hypident: [ -| ident -| "(" "type" "of" ident ")" -| "(" "value" "of" ident ")" -] - -hypident_occ: [ -| hypident OPT ( "at" occs_nums ) -] - clause_dft_concl: [ | "in" in_clause | OPT ( "at" occs_nums ) @@ -1810,11 +1811,6 @@ opt_clause: [ | ] -concl_occ: [ -| "*" OPT ( "at" occs_nums ) -| -] - in_hyp_list: [ | "in" LIST1 ident | @@ -1844,7 +1840,7 @@ cofixdecl: [ ] constr_with_bindings: [ -| term1_extended with_bindings +| one_term with_bindings ] with_bindings: [ @@ -1869,9 +1865,9 @@ quantified_hypothesis: [ ] conversion: [ -| term1_extended -| term1_extended "with" term1_extended -| term1_extended "at" occs_nums "with" term1_extended +| one_term +| one_term "with" one_term +| one_term "at" occs_nums "with" one_term ] firstorder_using: [ @@ -1897,29 +1893,29 @@ occurrences: [ ] rewstrategy: [ -| term1_extended -| "<-" term1_extended -| "subterms" rewstrategy -| "subterm" rewstrategy -| "innermost" rewstrategy -| "outermost" rewstrategy -| "bottomup" rewstrategy -| "topdown" rewstrategy -| "id" +| one_term +| "<-" one_term | "fail" +| "id" | "refl" | "progress" rewstrategy | "try" rewstrategy -| "any" rewstrategy -| "repeat" rewstrategy | rewstrategy ";" rewstrategy -| "(" rewstrategy ")" | "choice" rewstrategy rewstrategy -| "old_hints" ident +| "repeat" rewstrategy +| "any" rewstrategy +| "subterm" rewstrategy +| "subterms" rewstrategy +| "innermost" rewstrategy +| "outermost" rewstrategy +| "bottomup" rewstrategy +| "topdown" rewstrategy | "hints" ident -| "terms" LIST0 term1_extended +| "terms" LIST0 one_term | "eval" red_expr -| "fold" term1_extended +| "fold" one_term +| "(" rewstrategy ")" +| "old_hints" ident ] ltac_expr: [ @@ -2037,7 +2033,7 @@ tactic_arg: [ | "context" ident "[" term "]" | "type" "of" term | "fresh" LIST0 fresh_id -| "type_term" term1_extended +| "type_term" one_term | "numgoals" ] @@ -2,7 +2,7 @@ (env (dev (flags :standard -rectypes -w -9-27+40+60 \ -short-paths)) (release (flags :standard -rectypes) - (ocamlopt_flags -O3 -unbox-closures)) + (ocamlopt_flags :standard -O3 -unbox-closures)) (ireport (flags :standard -rectypes -w -9-27-40+60) (ocamlopt_flags :standard -O3 -unbox-closures -inlining-report))) diff --git a/engine/logic_monad.ml b/engine/logic_monad.ml index 1caf2c2722..76d98c5ddd 100644 --- a/engine/logic_monad.ml +++ b/engine/logic_monad.ml @@ -89,12 +89,12 @@ struct let catch = fun s h -> (); fun () -> try s () with Exception e as src -> - let (src, info) = CErrors.push src in + let (src, info) = Exninfo.capture src in h (e, info) () let read_line = fun () -> try read_line () with e -> - let (e, info) = CErrors.push e in - raise (e, info) () + let (e, info) = Exninfo.capture e in + raise (e,info) () let print_char = fun c -> (); fun () -> print_char c @@ -104,8 +104,8 @@ struct let make f = (); fun () -> try f () with e when CErrors.noncritical e -> - let (e, info) = CErrors.push e in - Util.iraise (Exception e, info) + let (e, info) = Exninfo.capture e in + Exninfo.iraise (Exception e, info) (** Use the current logger. The buffer is also flushed. *) let print_debug s = make (fun _ -> Feedback.msg_debug s) @@ -115,8 +115,8 @@ struct let run = fun x -> try x () with Exception e as src -> - let (src, info) = CErrors.push src in - Util.iraise (e, info) + let (src, info) = Exninfo.capture src in + Exninfo.iraise (e, info) end (** {6 Logical layer} *) diff --git a/engine/namegen.ml b/engine/namegen.ml index bcc8c34a4d..d2c37fb716 100644 --- a/engine/namegen.ml +++ b/engine/namegen.ml @@ -259,15 +259,17 @@ let visible_ids sigma (nenv, c) = let (gseen, vseen, ids) = !accu in let g = global_of_constr c in if not (GlobRef.Set_env.mem g gseen) then - begin - try let gseen = GlobRef.Set_env.add g gseen in - let short = Nametab.shortest_qualid_of_global Id.Set.empty g in - let dir, id = repr_qualid short in - let ids = if DirPath.is_empty dir then Id.Set.add id ids else ids in + let ids = match Nametab.shortest_qualid_of_global Id.Set.empty g with + | short -> + let dir, id = repr_qualid short in + if DirPath.is_empty dir then Id.Set.add id ids else ids + | exception Not_found -> + (* This may happen if given pathological terms or when manipulating + open modules *) + ids + in accu := (gseen, vseen, ids) - with Not_found when !Flags.in_debugger || !Flags.in_toplevel -> () - end | Rel p -> let (gseen, vseen, ids) = !accu in if p > n && not (Int.Set.mem p vseen) then diff --git a/engine/proofview.ml b/engine/proofview.ml index a26ce71141..6a4e490408 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -228,7 +228,7 @@ let apply ~name ~poly env t sp = let ans = Proof.repr (Proof.run t P.{trace=false; name; poly} (sp,env)) in let ans = Logic_monad.NonLogical.run ans in match ans with - | Nil (e, info) -> iraise (TacticFailure e, info) + | Nil (e, info) -> Exninfo.iraise (TacticFailure e, info) | Cons ((r, (state, _), status, info), _) -> let (status, gaveup) = status in let status = (status, state.shelf, gaveup) in @@ -328,8 +328,8 @@ let tclEXACTLY_ONCE e t = (** [tclCASE t] wraps the {!Proofview_monad.Logical.split} primitive. *) type 'a case = -| Fail of iexn -| Next of 'a * (iexn -> 'a tactic) +| Fail of Exninfo.iexn +| Next of 'a * (Exninfo.iexn -> 'a tactic) let tclCASE t = let open Logic_monad in let map = function @@ -1096,7 +1096,7 @@ module Goal = struct let (gl, sigma) = nf_gmake env sigma goal in tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) (f gl)) with e when catchable_exception e -> - let (e, info) = CErrors.push e in + let (e, info) = Exninfo.capture e in tclZERO ~info e end end @@ -1114,7 +1114,7 @@ module Goal = struct tclEVARMAP >>= fun sigma -> try f (gmake env sigma goal) with e when catchable_exception e -> - let (e, info) = CErrors.push e in + let (e, info) = Exninfo.capture e in tclZERO ~info e end end @@ -1127,7 +1127,7 @@ module Goal = struct tclEVARMAP >>= fun sigma -> try f (gmake env sigma goal) with e when catchable_exception e -> - let (e, info) = CErrors.push e in + let (e, info) = Exninfo.capture e in tclZERO ~info e end | _ -> @@ -1218,7 +1218,7 @@ module V82 = struct InfoL.leaf (Info.Tactic (fun _ _ -> Pp.str"<unknown>")) >> Pv.set { ps with solution = evd; comb = sgs; } with e when catchable_exception e -> - let (e, info) = CErrors.push e in + let (e, info) = Exninfo.capture e in tclZERO ~info e @@ -1261,8 +1261,8 @@ module V82 = struct let (_,final,_,_) = apply ~name ~poly (goal_env env gls.Evd.sigma gls.Evd.it) t init in { Evd.sigma = final.solution ; it = CList.map drop_state final.comb } with Logic_monad.TacticFailure e as src -> - let (_, info) = CErrors.push src in - iraise (e, info) + let (_, info) = Exninfo.capture src in + Exninfo.iraise (e, info) let put_status = Status.put @@ -1271,7 +1271,7 @@ module V82 = struct let wrap_exceptions f = try f () with e when catchable_exception e -> - let (e, info) = CErrors.push e in tclZERO ~info e + let (e, info) = Exninfo.capture e in tclZERO ~info e end diff --git a/engine/proofview.mli b/engine/proofview.mli index a92179ab5b..5bfbc6a649 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -14,7 +14,6 @@ ['a tactic] is the (abstract) type of tactics modifying the proof state and returning a value of type ['a]. *) -open Util open EConstr (** Main state of tactics *) @@ -194,18 +193,18 @@ val tclZERO : ?info:Exninfo.info -> exn -> 'a tactic the successes of [t1] have been depleted and it failed with [e], then it behaves as [t2 e]. In other words, [tclOR] inserts a backtracking point. *) -val tclOR : 'a tactic -> (iexn -> 'a tactic) -> 'a tactic +val tclOR : 'a tactic -> (Exninfo.iexn -> 'a tactic) -> 'a tactic (** [tclORELSE t1 t2] is equal to [t1] if [t1] has at least one success or [t2 e] if [t1] fails with [e]. It is analogous to [try/with] handler of exception in that it is not a backtracking point. *) -val tclORELSE : 'a tactic -> (iexn -> 'a tactic) -> 'a tactic +val tclORELSE : 'a tactic -> (Exninfo.iexn -> 'a tactic) -> 'a tactic (** [tclIFCATCH a s f] is a generalisation of {!tclORELSE}: if [a] succeeds at least once then it behaves as [tclBIND a s] otherwise, if [a] fails with [e], then it behaves as [f e]. *) -val tclIFCATCH : 'a tactic -> ('a -> 'b tactic) -> (iexn -> 'b tactic) -> 'b tactic +val tclIFCATCH : 'a tactic -> ('a -> 'b tactic) -> (Exninfo.iexn -> 'b tactic) -> 'b tactic (** [tclONCE t] behave like [t] except it has at most one success: [tclONCE t] stops after the first success of [t]. If [t] fails @@ -227,8 +226,8 @@ val tclEXACTLY_ONCE : exn -> 'a tactic -> 'a tactic continuation. It is the most general primitive to control backtracking. *) type 'a case = - | Fail of iexn - | Next of 'a * (iexn -> 'a tactic) + | Fail of Exninfo.iexn + | Next of 'a * (Exninfo.iexn -> 'a tactic) val tclCASE : 'a tactic -> 'a case tactic (** [tclBREAK p t] is a generalization of [tclONCE t]. Instead of @@ -236,7 +235,7 @@ val tclCASE : 'a tactic -> 'a case tactic failure with an exception [e] such that [p e = Some e'] is raised. At which point it drops the remaining successes, failing with [e']. [tclONCE t] is equivalent to [tclBREAK (fun e -> Some e) t]. *) -val tclBREAK : (iexn -> iexn option) -> 'a tactic -> 'a tactic +val tclBREAK : (Exninfo.iexn -> Exninfo.iexn option) -> 'a tactic -> 'a tactic (** {7 Focusing tactics} *) @@ -508,8 +507,8 @@ end module UnsafeRepr : sig type state = Proofview_monad.Logical.Unsafe.state - val repr : 'a tactic -> ('a, state, state, iexn) Logic_monad.BackState.t - val make : ('a, state, state, iexn) Logic_monad.BackState.t -> 'a tactic + val repr : 'a tactic -> ('a, state, state, Exninfo.iexn) Logic_monad.BackState.t + val make : ('a, state, state, Exninfo.iexn) Logic_monad.BackState.t -> 'a tactic end (** {6 Goal-dependent tactics} *) diff --git a/gramlib/grammar.ml b/gramlib/grammar.ml index e1b9c6b7cb..0024d70466 100644 --- a/gramlib/grammar.ml +++ b/gramlib/grammar.ml @@ -10,70 +10,88 @@ open Util module type GLexerType = Plexing.Lexer -type ty_norec = TyNoRec -type ty_mayrec = TyMayRec +type norec +type mayrec -module type S = +module type S = sig + type te + type 'c pattern + + module Parsable : sig + type t + val make : ?loc:Loc.t -> char Stream.t -> t + end + + val tokens : string -> (string option * int) list + + module Entry : sig + type 'a t + val make : string -> 'a t + val parse : 'a t -> Parsable.t -> 'a + val name : 'a t -> string + val of_parser : string -> (Plexing.location_function -> te Stream.t -> 'a) -> 'a t + val parse_token_stream : 'a t -> te Stream.t -> 'a + val print : Format.formatter -> 'a t -> unit + end + + module rec Symbol : sig + + type ('self, 'trec, 'a) t + val nterm : 'a Entry.t -> ('self, norec, 'a) t + val nterml : 'a Entry.t -> string -> ('self, norec, 'a) t + val list0 : ('self, 'trec, 'a) t -> ('self, 'trec, 'a list) t + val list0sep : + ('self, 'trec, 'a) t -> ('self, norec, 'b) t -> bool -> + ('self, 'trec, 'a list) t + val list1 : ('self, 'trec, 'a) t -> ('self, 'trec, 'a list) t + val list1sep : + ('self, 'trec, 'a) t -> ('self, norec, 'b) t -> bool -> + ('self, 'trec, 'a list) t + val opt : ('self, 'trec, 'a) t -> ('self, 'trec, 'a option) t + val self : ('self, mayrec, 'self) t + val next : ('self, mayrec, 'self) t + val token : 'c pattern -> ('self, norec, 'c) t + val rules : warning:(string -> unit) option -> 'a Rules.t list -> ('self, norec, 'a) t + + end and Rule : sig + + type ('self, 'trec, 'f, 'r) t + + val stop : ('self, norec, 'r, 'r) t + val next : + ('self, _, 'a, 'r) t -> ('self, _, 'b) Symbol.t -> + ('self, mayrec, 'b -> 'a, 'r) t + val next_norec : + ('self, norec, 'a, 'r) Rule.t -> ('self, norec, 'b) Symbol.t -> + ('self, norec, 'b -> 'a, 'r) t + + end and Rules : sig + + type 'a t + val make : (_, norec, 'f, Loc.t -> 'a) Rule.t -> 'f -> 'a t + + end + + module Production : sig + type 'a t + val make : ('a, _, 'f, Loc.t -> 'a) Rule.t -> 'f -> 'a t + end + + module Unsafe : sig - type te - type 'c pattern - type parsable - val parsable : ?loc:Loc.t -> char Stream.t -> parsable - val tokens : string -> (string option * int) list - module Entry : - sig - type 'a e - val create : string -> 'a e - val parse : 'a e -> parsable -> 'a - val name : 'a e -> string - val of_parser : string -> (Plexing.location_function -> te Stream.t -> 'a) -> 'a e - val parse_token_stream : 'a e -> te Stream.t -> 'a - val print : Format.formatter -> 'a e -> unit - end - type ('self, 'trec, 'a) ty_symbol - type ('self, 'trec, 'f, 'r) ty_rule - type 'a ty_rules - type 'a ty_production - val s_nterm : 'a Entry.e -> ('self, ty_norec, 'a) ty_symbol - val s_nterml : 'a Entry.e -> string -> ('self, ty_norec, 'a) ty_symbol - val s_list0 : ('self, 'trec, 'a) ty_symbol -> ('self, 'trec, 'a list) ty_symbol - val s_list0sep : - ('self, 'trec, 'a) ty_symbol -> ('self, ty_norec, 'b) ty_symbol -> bool -> - ('self, 'trec, 'a list) ty_symbol - val s_list1 : ('self, 'trec, 'a) ty_symbol -> ('self, 'trec, 'a list) ty_symbol - val s_list1sep : - ('self, 'trec, 'a) ty_symbol -> ('self, ty_norec, 'b) ty_symbol -> bool -> - ('self, 'trec, 'a list) ty_symbol - val s_opt : ('self, 'trec, 'a) ty_symbol -> ('self, 'trec, 'a option) ty_symbol - val s_self : ('self, ty_mayrec, 'self) ty_symbol - val s_next : ('self, ty_mayrec, 'self) ty_symbol - val s_token : 'c pattern -> ('self, ty_norec, 'c) ty_symbol - val s_rules : warning:(string -> unit) option -> 'a ty_rules list -> ('self, ty_norec, 'a) ty_symbol - val r_stop : ('self, ty_norec, 'r, 'r) ty_rule - val r_next : - ('self, _, 'a, 'r) ty_rule -> ('self, _, 'b) ty_symbol -> - ('self, ty_mayrec, 'b -> 'a, 'r) ty_rule - val r_next_norec : - ('self, ty_norec, 'a, 'r) ty_rule -> ('self, ty_norec, 'b) ty_symbol -> - ('self, ty_norec, 'b -> 'a, 'r) ty_rule - val rules : (_, ty_norec, 'f, Loc.t -> 'a) ty_rule * 'f -> 'a ty_rules - val production : ('a, _, 'f, Loc.t -> 'a) ty_rule * 'f -> 'a ty_production - module Unsafe : - sig - val clear_entry : 'a Entry.e -> unit - end - val safe_extend : warning:(string -> unit) option -> - 'a Entry.e -> Gramext.position option -> - (string option * Gramext.g_assoc option * 'a ty_production list) - list -> - unit - val safe_delete_rule : 'a Entry.e -> ('a, _, 'r, 'f) ty_rule -> unit + val clear_entry : 'a Entry.t -> unit end + val safe_extend : warning:(string -> unit) option -> + 'a Entry.t -> Gramext.position option -> + (string option * Gramext.g_assoc option * 'a Production.t list) + list -> + unit + val safe_delete_rule : 'a Entry.t -> ('a, _, 'f, 'r) Rule.t -> unit +end (* Implementation *) -module GMake (L : GLexerType) = -struct +module GMake (L : GLexerType) = struct type te = L.te type 'c pattern = 'c L.pattern @@ -84,7 +102,7 @@ type grammar = { gtokens : (string * string option, int ref) Hashtbl.t } let egram = - {gtokens = Hashtbl.create 301 } + { gtokens = Hashtbl.create 301 } let tokens con = let list = ref [] in @@ -94,12 +112,12 @@ let tokens con = !list type ('a, 'b, 'c) ty_and_rec = -| NoRec2 : (ty_norec, ty_norec, ty_norec) ty_and_rec -| MayRec2 : ('a, 'b, ty_mayrec) ty_and_rec +| NoRec2 : (norec, norec, norec) ty_and_rec +| MayRec2 : ('a, 'b, mayrec) ty_and_rec type ('a, 'b, 'c, 'd) ty_and_rec3 = -| NoRec3 : (ty_norec, ty_norec, ty_norec, ty_norec) ty_and_rec3 -| MayRec3 : ('a, 'b, 'c, ty_mayrec) ty_and_rec3 +| NoRec3 : (norec, norec, norec, norec) ty_and_rec3 +| MayRec3 : ('a, 'b, 'c, mayrec) ty_and_rec3 type 'a ty_entry = { ename : string; @@ -122,26 +140,26 @@ and ('trecs, 'trecp, 'a) ty_rec_level = { } and ('self, 'trec, 'a) ty_symbol = -| Stoken : 'c pattern -> ('self, ty_norec, 'c) ty_symbol +| Stoken : 'c pattern -> ('self, norec, 'c) ty_symbol | Slist1 : ('self, 'trec, 'a) ty_symbol -> ('self, 'trec, 'a list) ty_symbol -| Slist1sep : ('self, 'trec, 'a) ty_symbol * ('self, ty_norec, _) ty_symbol * bool -> ('self, 'trec, 'a list) ty_symbol +| Slist1sep : ('self, 'trec, 'a) ty_symbol * ('self, norec, _) ty_symbol * bool -> ('self, 'trec, 'a list) ty_symbol | Slist0 : ('self, 'trec, 'a) ty_symbol -> ('self, 'trec, 'a list) ty_symbol -| Slist0sep : ('self, 'trec, 'a) ty_symbol * ('self, ty_norec, _) ty_symbol * bool -> ('self, 'trec, 'a list) ty_symbol +| Slist0sep : ('self, 'trec, 'a) ty_symbol * ('self, norec, _) ty_symbol * bool -> ('self, 'trec, 'a list) ty_symbol | Sopt : ('self, 'trec, 'a) ty_symbol -> ('self, 'trec, 'a option) ty_symbol -| Sself : ('self, ty_mayrec, 'self) ty_symbol -| Snext : ('self, ty_mayrec, 'self) ty_symbol -| Snterm : 'a ty_entry -> ('self, ty_norec, 'a) ty_symbol -| Snterml : 'a ty_entry * string -> ('self, ty_norec, 'a) ty_symbol +| Sself : ('self, mayrec, 'self) ty_symbol +| Snext : ('self, mayrec, 'self) ty_symbol +| Snterm : 'a ty_entry -> ('self, norec, 'a) ty_symbol +| Snterml : 'a ty_entry * string -> ('self, norec, 'a) ty_symbol | Stree : ('self, 'trec, Loc.t -> 'a) ty_tree -> ('self, 'trec, 'a) ty_symbol and ('self, _, _, 'r) ty_rule = -| TStop : ('self, ty_norec, 'r, 'r) ty_rule +| TStop : ('self, norec, 'r, 'r) ty_rule | TNext : ('trr, 'trs, 'tr) ty_and_rec * ('self, 'trr, 'a, 'r) ty_rule * ('self, 'trs, 'b) ty_symbol -> ('self, 'tr, 'b -> 'a, 'r) ty_rule and ('self, 'trec, 'a) ty_tree = | Node : ('trn, 'trs, 'trb, 'tr) ty_and_rec3 * ('self, 'trn, 'trs, 'trb, 'b, 'a) ty_node -> ('self, 'tr, 'a) ty_tree -| LocAct : 'k * 'k list -> ('self, ty_norec, 'k) ty_tree -| DeadEnd : ('self, ty_norec, 'k) ty_tree +| LocAct : 'k * 'k list -> ('self, norec, 'k) ty_tree +| DeadEnd : ('self, norec, 'k) ty_tree and ('self, 'trec, 'trecs, 'trecb, 'a, 'r) ty_node = { node : ('self, 'trec, 'a) ty_symbol; @@ -150,7 +168,7 @@ and ('self, 'trec, 'trecs, 'trecb, 'a, 'r) ty_node = { } type 'a ty_rules = -| TRules : (_, ty_norec, 'act, Loc.t -> 'a) ty_rule * 'act -> 'a ty_rules +| TRules : (_, norec, 'act, Loc.t -> 'a) ty_rule * 'act -> 'a ty_rules type 'a ty_production = | TProd : ('a, _, 'act, Loc.t -> 'a) ty_rule * 'act -> 'a ty_production @@ -222,13 +240,13 @@ let is_before : type s1 s2 r1 r2 a1 a2. (s1, r1, a1) ty_symbol -> (s2, r2, a2) t (** Ancillary datatypes *) -type 'a ty_rec = MayRec : ty_mayrec ty_rec | NoRec : ty_norec ty_rec +type 'a ty_rec = MayRec : mayrec ty_rec | NoRec : norec ty_rec type ('a, 'b, 'c) ty_and_ex = -| NR00 : (ty_mayrec, ty_mayrec, ty_mayrec) ty_and_ex -| NR01 : (ty_mayrec, ty_norec, ty_mayrec) ty_and_ex -| NR10 : (ty_norec, ty_mayrec, ty_mayrec) ty_and_ex -| NR11 : (ty_norec, ty_norec, ty_norec) ty_and_ex +| NR00 : (mayrec, mayrec, mayrec) ty_and_ex +| NR01 : (mayrec, norec, mayrec) ty_and_ex +| NR10 : (norec, mayrec, mayrec) ty_and_ex +| NR11 : (norec, norec, norec) ty_and_ex type ('a, 'b) ty_mayrec_and_ex = | MayRecNR : ('a, 'b, _) ty_and_ex -> ('a, 'b) ty_mayrec_and_ex @@ -243,7 +261,7 @@ type ('s, 'a, 'r) ty_mayrec_rule = | MayRecRule : ('s, _, 'a, 'r) ty_rule -> ('s, 'a, 'r) ty_mayrec_rule type ('self, 'trec, _) ty_symbols = -| TNil : ('self, ty_norec, unit) ty_symbols +| TNil : ('self, norec, unit) ty_symbols | TCns : ('trh, 'trt, 'tr) ty_and_rec * ('self, 'trh, 'a) ty_symbol * ('self, 'trt, 'b) ty_symbols -> ('self, 'tr, 'a * 'b) ty_symbols (** ('i, 'p, 'f, 'r) rel_prod0 ~ @@ -313,7 +331,7 @@ let insert_tree (type s trs trt tr p k a) ~warning entry_name (ar : (trs, trt, t TCns (ars, s, sl), RelS pf -> insert_in_tree ar ars s sl pf tree action | TNil, Rel0 -> let node (type tb) ({node = s; son = son; brother = bro} : (_, _, _, tb, _, _) ty_node) = - let ar : (ty_norec, tb, tb) ty_and_ex = + let ar : (norec, tb, tb) ty_and_ex = match get_rec_tree bro with MayRec -> NR10 | NoRec -> NR11 in {node = s; son = son; brother = insert ar TNil Rel0 bro action} in match ar, tree with @@ -387,21 +405,21 @@ let insert_tree (type s trs trt tr p k a) ~warning entry_name (ar : (trs, trt, t in insert ar gsymbols pf tree action -let insert_tree_norec (type s p k a) ~warning entry_name (gsymbols : (s, ty_norec, p) ty_symbols) (pf : (p, k, a) rel_prod) (action : k) (tree : (s, ty_norec, a) ty_tree) : (s, ty_norec, a) ty_tree = +let insert_tree_norec (type s p k a) ~warning entry_name (gsymbols : (s, norec, p) ty_symbols) (pf : (p, k, a) rel_prod) (action : k) (tree : (s, norec, a) ty_tree) : (s, norec, a) ty_tree = insert_tree ~warning entry_name NR11 gsymbols pf action tree let insert_tree (type s trs trt p k a) ~warning entry_name (gsymbols : (s, trs, p) ty_symbols) (pf : (p, k, a) rel_prod) (action : k) (tree : (s, trt, a) ty_tree) : (s, a) ty_mayrec_tree = let MayRecNR ar = and_symbols_tree gsymbols tree in MayRecTree (insert_tree ~warning entry_name ar gsymbols pf action tree) -let srules (type self a) ~warning (rl : a ty_rules list) : (self, ty_norec, a) ty_symbol = - let rec retype_tree : type s a. (s, ty_norec, a) ty_tree -> (self, ty_norec, a) ty_tree = +let srules (type self a) ~warning (rl : a ty_rules list) : (self, norec, a) ty_symbol = + let rec retype_tree : type s a. (s, norec, a) ty_tree -> (self, norec, a) ty_tree = function | Node (NoRec3, {node = s; son = son; brother = bro}) -> Node (NoRec3, {node = retype_symbol s; son = retype_tree son; brother = retype_tree bro}) | LocAct (k, kl) -> LocAct (k, kl) | DeadEnd -> DeadEnd - and retype_symbol : type s a. (s, ty_norec, a) ty_symbol -> (self, ty_norec, a) ty_symbol = + and retype_symbol : type s a. (s, norec, a) ty_symbol -> (self, norec, a) ty_symbol = function | Stoken p -> Stoken p | Slist1 s -> Slist1 (retype_symbol s) @@ -412,7 +430,7 @@ let srules (type self a) ~warning (rl : a ty_rules list) : (self, ty_norec, a) t | Snterm e -> Snterm e | Snterml (e, l) -> Snterml (e, l) | Stree t -> Stree (retype_tree t) in - let rec retype_rule : type s k r. (s, ty_norec, k, r) ty_rule -> (self, ty_norec, k, r) ty_rule = + let rec retype_rule : type s k r. (s, norec, k, r) ty_rule -> (self, norec, k, r) ty_rule = function | TStop -> TStop | TNext (NoRec2, r, s) -> TNext (NoRec2, retype_rule r, retype_symbol s) in @@ -1037,7 +1055,7 @@ let level_number entry lab = Dlevels elev -> lookup 0 elev | Dparser _ -> raise Not_found -let rec top_symb : type s tr a. s ty_entry -> (s, tr, a) ty_symbol -> (s, ty_norec, a) ty_symbol = +let rec top_symb : type s tr a. s ty_entry -> (s, tr, a) ty_symbol -> (s, norec, a) ty_symbol = fun entry -> function Sself -> Snterm entry @@ -1484,105 +1502,168 @@ let delete_rule entry sl = (* Normal interface *) -type parsable = - { pa_chr_strm : char Stream.t; - pa_tok_strm : L.te Stream.t; - pa_loc_func : Plexing.location_function } - -let parse_parsable entry p = - let efun = entry.estart 0 in - let ts = p.pa_tok_strm in - let cs = p.pa_chr_strm in - let fun_loc = p.pa_loc_func in - let restore = - let old_floc = !floc in - let old_tc = !token_count in - fun () -> floc := old_floc; token_count := old_tc - in - let get_loc () = - try - let cnt = Stream.count ts in - (* Ensure that the token at location cnt has been peeked so that - the location function knows about it *) - let _ = Stream.peek ts in - let loc = fun_loc cnt in - if !token_count - 1 <= cnt then loc - else Loc.merge loc (fun_loc (!token_count - 1)) - with Failure _ -> Ploc.make_unlined (Stream.count cs, Stream.count cs + 1) - in - floc := fun_loc; - token_count := 0; - try let r = efun ts in restore (); r with - Stream.Failure -> +module Parsable = struct + + type t = + { pa_chr_strm : char Stream.t + ; pa_tok_strm : L.te Stream.t + ; pa_loc_func : Plexing.location_function + } + + let parse_parsable entry p = + let efun = entry.estart 0 in + let ts = p.pa_tok_strm in + let cs = p.pa_chr_strm in + let fun_loc = p.pa_loc_func in + let restore = + let old_floc = !floc in + let old_tc = !token_count in + fun () -> floc := old_floc; token_count := old_tc + in + let get_loc () = + try + let cnt = Stream.count ts in + (* Ensure that the token at location cnt has been peeked so that + the location function knows about it *) + let _ = Stream.peek ts in + let loc = fun_loc cnt in + if !token_count - 1 <= cnt then loc + else Loc.merge loc (fun_loc (!token_count - 1)) + with Failure _ -> Ploc.make_unlined (Stream.count cs, Stream.count cs + 1) + in + floc := fun_loc; + token_count := 0; + try let r = efun ts in restore (); r with + Stream.Failure -> let loc = get_loc () in restore (); Ploc.raise loc (Stream.Error ("illegal begin of " ^ entry.ename)) - | Stream.Error _ as exc -> + | Stream.Error _ as exc -> let loc = get_loc () in restore (); Ploc.raise loc exc - | exc -> + | exc -> let loc = Stream.count cs, Stream.count cs + 1 in restore (); Ploc.raise (Ploc.make_unlined loc) exc -(* Unsafe *) + let make ?loc cs = + let (ts, lf) = L.tok_func ?loc cs in + {pa_chr_strm = cs; pa_tok_strm = ts; pa_loc_func = lf} -let clear_entry e = - e.estart <- (fun _ (strm__ : _ Stream.t) -> raise Stream.Failure); - e.econtinue <- (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure); - match e.edesc with - Dlevels _ -> e.edesc <- Dlevels [] - | Dparser _ -> () +end - let parsable ?loc cs = - let (ts, lf) = L.tok_func ?loc cs in - {pa_chr_strm = cs; pa_tok_strm = ts; pa_loc_func = lf} - module Entry = - struct - type 'a e = 'a ty_entry - let create n = - { ename = n; estart = empty_entry n; - econtinue = - (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure); - edesc = Dlevels []} - let parse (e : 'a e) p : 'a = - parse_parsable e p - let parse_token_stream (e : 'a e) ts : 'a = - e.estart 0 ts - let name e = e.ename - let of_parser n (p : Plexing.location_function -> te Stream.t -> 'a) : 'a e = - { ename = n; - estart = (fun _ -> p !floc); - econtinue = - (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure); - edesc = Dparser p} - let print ppf e = fprintf ppf "%a@." print_entry e - end - let s_nterm e = Snterm e - let s_nterml e l = Snterml (e, l) - let s_list0 s = Slist0 s - let s_list0sep s sep b = Slist0sep (s, sep, b) - let s_list1 s = Slist1 s - let s_list1sep s sep b = Slist1sep (s, sep, b) - let s_opt s = Sopt s - let s_self = Sself - let s_next = Snext - let s_token tok = Stoken tok - let s_rules ~warning (t : 'a ty_rules list) = srules ~warning t - let r_stop = TStop - let r_next r s = TNext (MayRec2, r, s) - let r_next_norec r s = TNext (NoRec2, r, s) - let rules (p, act) = TRules (p, act) - let production (p, act) = TProd (p, act) - module Unsafe = - struct - let clear_entry = clear_entry - end - let safe_extend ~warning (e : 'a Entry.e) pos - (r : - (string option * Gramext.g_assoc option * 'a ty_production list) - list) = - extend_entry ~warning e pos r - let safe_delete_rule e r = - let AnyS (symbols, _) = get_symbols r in - delete_rule e symbols +module Entry = struct + type 'a t = 'a ty_entry + let make n = + { ename = n; estart = empty_entry n; + econtinue = + (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure); + edesc = Dlevels []} + let parse (e : 'a t) p : 'a = + Parsable.parse_parsable e p + let parse_token_stream (e : 'a t) ts : 'a = + e.estart 0 ts + let name e = e.ename + let of_parser n (p : Plexing.location_function -> te Stream.t -> 'a) : 'a t = + { ename = n; + estart = (fun _ -> p !floc); + econtinue = + (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure); + edesc = Dparser p} + let print ppf e = fprintf ppf "%a@." print_entry e +end + +module rec Symbol : sig + + type ('self, 'trec, 'a) t = ('self, 'trec, 'a) ty_symbol + + val nterm : 'a Entry.t -> ('self, norec, 'a) t + val nterml : 'a Entry.t -> string -> ('self, norec, 'a) t + val list0 : ('self, 'trec, 'a) t -> ('self, 'trec, 'a list) t + val list0sep : + ('self, 'trec, 'a) t -> ('self, norec, 'b) t -> bool -> + ('self, 'trec, 'a list) t + val list1 : ('self, 'trec, 'a) t -> ('self, 'trec, 'a list) t + val list1sep : + ('self, 'trec, 'a) t -> ('self, norec, 'b) t -> bool -> + ('self, 'trec, 'a list) t + val opt : ('self, 'trec, 'a) t -> ('self, 'trec, 'a option) t + val self : ('self, mayrec, 'self) t + val next : ('self, mayrec, 'self) t + val token : 'c pattern -> ('self, norec, 'c) t + val rules : warning:(string -> unit) option -> 'a Rules.t list -> ('self, norec, 'a) t + +end = struct + + type ('self, 'trec, 'a) t = ('self, 'trec, 'a) ty_symbol + let nterm e = Snterm e + let nterml e l = Snterml (e, l) + let list0 s = Slist0 s + let list0sep s sep b = Slist0sep (s, sep, b) + let list1 s = Slist1 s + let list1sep s sep b = Slist1sep (s, sep, b) + let opt s = Sopt s + let self = Sself + let next = Snext + let token tok = Stoken tok + let rules ~warning (t : 'a Rules.t list) = srules ~warning t + +end and Rule : sig + + type ('self, 'trec, 'f, 'r) t = ('self, 'trec, 'f, 'r) ty_rule + + val stop : ('self, norec, 'r, 'r) t + val next : + ('self, _, 'a, 'r) t -> ('self, _, 'b) Symbol.t -> + ('self, mayrec, 'b -> 'a, 'r) t + val next_norec : + ('self, norec, 'a, 'r) Rule.t -> ('self, norec, 'b) Symbol.t -> + ('self, norec, 'b -> 'a, 'r) t + +end = struct + + type ('self, 'trec, 'f, 'r) t = ('self, 'trec, 'f, 'r) ty_rule + + let stop = TStop + let next r s = TNext (MayRec2, r, s) + let next_norec r s = TNext (NoRec2, r, s) + +end and Rules : sig + + type 'a t = 'a ty_rules + val make : (_, norec, 'f, Loc.t -> 'a) Rule.t -> 'f -> 'a t + +end = struct + + type 'a t = 'a ty_rules + let make p act = TRules (p, act) + +end + +module Production = struct + + type 'a t = 'a ty_production + let make p act = TProd (p, act) + +end + +module Unsafe = struct + + let clear_entry e = + e.estart <- (fun _ (strm__ : _ Stream.t) -> raise Stream.Failure); + e.econtinue <- (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure); + match e.edesc with + Dlevels _ -> e.edesc <- Dlevels [] + | Dparser _ -> () + +end + +let safe_extend ~warning (e : 'a Entry.t) pos + (r : + (string option * Gramext.g_assoc option * 'a ty_production list) + list) = + extend_entry ~warning e pos r + +let safe_delete_rule e r = + let AnyS (symbols, _) = get_symbols r in + delete_rule e symbols end diff --git a/gramlib/grammar.mli b/gramlib/grammar.mli index 9e48460206..f0423a92af 100644 --- a/gramlib/grammar.mli +++ b/gramlib/grammar.mli @@ -19,76 +19,93 @@ module type GLexerType = Plexing.Lexer (** The input signature for the functor [Grammar.GMake]: [te] is the type of the tokens. *) -type ty_norec = TyNoRec -type ty_mayrec = TyMayRec +type norec +type mayrec -module type S = +module type S = sig + type te + type 'c pattern + + module Parsable : sig + type t + val make : ?loc:Loc.t -> char Stream.t -> t + end + + val tokens : string -> (string option * int) list + + module Entry : sig + type 'a t + val make : string -> 'a t + val parse : 'a t -> Parsable.t -> 'a + val name : 'a t -> string + val of_parser : string -> (Plexing.location_function -> te Stream.t -> 'a) -> 'a t + val parse_token_stream : 'a t -> te Stream.t -> 'a + val print : Format.formatter -> 'a t -> unit + end + + module rec Symbol : sig + + type ('self, 'trec, 'a) t + val nterm : 'a Entry.t -> ('self, norec, 'a) t + val nterml : 'a Entry.t -> string -> ('self, norec, 'a) t + val list0 : ('self, 'trec, 'a) t -> ('self, 'trec, 'a list) t + val list0sep : + ('self, 'trec, 'a) t -> ('self, norec, 'b) t -> bool -> + ('self, 'trec, 'a list) t + val list1 : ('self, 'trec, 'a) t -> ('self, 'trec, 'a list) t + val list1sep : + ('self, 'trec, 'a) t -> ('self, norec, 'b) t -> bool -> + ('self, 'trec, 'a list) t + val opt : ('self, 'trec, 'a) t -> ('self, 'trec, 'a option) t + val self : ('self, mayrec, 'self) t + val next : ('self, mayrec, 'self) t + val token : 'c pattern -> ('self, norec, 'c) t + val rules : warning:(string -> unit) option -> 'a Rules.t list -> ('self, norec, 'a) t + + end and Rule : sig + + type ('self, 'trec, 'f, 'r) t + + val stop : ('self, norec, 'r, 'r) t + val next : + ('self, _, 'a, 'r) t -> ('self, _, 'b) Symbol.t -> + ('self, mayrec, 'b -> 'a, 'r) t + val next_norec : + ('self, norec, 'a, 'r) Rule.t -> ('self, norec, 'b) Symbol.t -> + ('self, norec, 'b -> 'a, 'r) t + + end and Rules : sig + + type 'a t + val make : (_, norec, 'f, Loc.t -> 'a) Rule.t -> 'f -> 'a t + + end + + module Production : sig + type 'a t + val make : ('a, _, 'f, Loc.t -> 'a) Rule.t -> 'f -> 'a t + end + + module Unsafe : sig - type te - type 'c pattern - type parsable - val parsable : ?loc:Loc.t -> char Stream.t -> parsable - val tokens : string -> (string option * int) list - module Entry : - sig - type 'a e - val create : string -> 'a e - val parse : 'a e -> parsable -> 'a - val name : 'a e -> string - val of_parser : string -> (Plexing.location_function -> te Stream.t -> 'a) -> 'a e - val parse_token_stream : 'a e -> te Stream.t -> 'a - val print : Format.formatter -> 'a e -> unit - end - type ('self, 'trec, 'a) ty_symbol - type ('self, 'trec, 'f, 'r) ty_rule - type 'a ty_rules - type 'a ty_production - val s_nterm : 'a Entry.e -> ('self, ty_norec, 'a) ty_symbol - val s_nterml : 'a Entry.e -> string -> ('self, ty_norec, 'a) ty_symbol - val s_list0 : ('self, 'trec, 'a) ty_symbol -> ('self, 'trec, 'a list) ty_symbol - val s_list0sep : - ('self, 'trec, 'a) ty_symbol -> ('self, ty_norec, 'b) ty_symbol -> bool -> - ('self, 'trec, 'a list) ty_symbol - val s_list1 : ('self, 'trec, 'a) ty_symbol -> ('self, 'trec, 'a list) ty_symbol - val s_list1sep : - ('self, 'trec, 'a) ty_symbol -> ('self, ty_norec, 'b) ty_symbol -> bool -> - ('self, 'trec, 'a list) ty_symbol - val s_opt : ('self, 'trec, 'a) ty_symbol -> ('self, 'trec, 'a option) ty_symbol - val s_self : ('self, ty_mayrec, 'self) ty_symbol - val s_next : ('self, ty_mayrec, 'self) ty_symbol - val s_token : 'c pattern -> ('self, ty_norec, 'c) ty_symbol - val s_rules : warning:(string -> unit) option -> 'a ty_rules list -> ('self, ty_norec, 'a) ty_symbol - - val r_stop : ('self, ty_norec, 'r, 'r) ty_rule - val r_next : - ('self, _, 'a, 'r) ty_rule -> ('self, _, 'b) ty_symbol -> - ('self, ty_mayrec, 'b -> 'a, 'r) ty_rule - val r_next_norec : - ('self, ty_norec, 'a, 'r) ty_rule -> ('self, ty_norec, 'b) ty_symbol -> - ('self, ty_norec, 'b -> 'a, 'r) ty_rule - val rules : (_, ty_norec, 'f, Loc.t -> 'a) ty_rule * 'f -> 'a ty_rules - val production : ('a, _, 'f, Loc.t -> 'a) ty_rule * 'f -> 'a ty_production - - module Unsafe : - sig - val clear_entry : 'a Entry.e -> unit - end - val safe_extend : warning:(string -> unit) option -> - 'a Entry.e -> Gramext.position option -> - (string option * Gramext.g_assoc option * 'a ty_production list) - list -> - unit - val safe_delete_rule : 'a Entry.e -> ('a, _, 'f, 'r) ty_rule -> unit + val clear_entry : 'a Entry.t -> unit end - (** Signature type of the functor [Grammar.GMake]. The types and - functions are almost the same than in generic interface, but: -- Grammars are not values. Functions holding a grammar as parameter - do not have this parameter yet. -- The type [parsable] is used in function [parse] instead of - the char stream, avoiding the possible loss of tokens. -- The type of tokens (expressions and patterns) can be any - type (instead of (string * string)); the module parameter - must specify a way to show them as (string * string) *) + val safe_extend : warning:(string -> unit) option -> + 'a Entry.t -> Gramext.position option -> + (string option * Gramext.g_assoc option * 'a Production.t list) + list -> + unit + val safe_delete_rule : 'a Entry.t -> ('a, _, 'f, 'r) Rule.t -> unit +end +(** Signature type of the functor [Grammar.GMake]. The types and + functions are almost the same than in generic interface, but: + - Grammars are not values. Functions holding a grammar as parameter + do not have this parameter yet. + - The type [parsable] is used in function [parse] instead of + the char stream, avoiding the possible loss of tokens. + - The type of tokens (expressions and patterns) can be any + type (instead of (string * string)); the module parameter + must specify a way to show them as (string * string) *) module GMake (L : GLexerType) : S with type te = L.te and type 'c pattern = 'c L.pattern diff --git a/ide/coq_commands.ml b/ide/coq_commands.ml index 5b9ea17ba7..790b427e4c 100644 --- a/ide/coq_commands.ml +++ b/ide/coq_commands.ml @@ -21,7 +21,6 @@ let commands = [ "Add Printing Let"; "Add Printing Record"; "Add Rec LoadPath"; - "Add Rec ML Path"; "Add Ring A Aplus Amult Aone Azero Ainv Aeq T [ c1 ... cn ]. "; "Add Semi Ring A Aplus Amult Aone Azero Aeq T [ c1 ... cn ]."; "Add Relation"; diff --git a/ide/coqide.ml b/ide/coqide.ml index 61e95c21b1..553b834a37 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -244,6 +244,13 @@ let close_and_quit () = List.iter (fun sn -> Coq.close_coqtop sn.coqtop) notebook#pages; exit 0 +(* Work around a deadlock due to OCaml exit cleanup. The standard [exit] + function calls [flush_all], which can block if one of the opened channels is + not valid anymore. We do not register [at_exit] functions in CoqIDE, so + instead of flushing we simply die as gracefully as possible in the function + below. *) +external sys_exit : int -> 'a = "caml_sys_exit" + let crash_save exitcode = Minilib.log "Starting emergency save of buffers in .crashcoqide files"; let idx = @@ -263,7 +270,7 @@ let crash_save exitcode = in List.iter save_session notebook#pages; Minilib.log "End emergency save"; - exit exitcode + sys_exit exitcode end diff --git a/ide/fake_ide.ml b/ide/fake_ide.ml index dfc16d39f3..4292e91252 100644 --- a/ide/fake_ide.ml +++ b/ide/fake_ide.ml @@ -327,11 +327,7 @@ let main = { xml_printer = op; xml_parser = ip } in let init () = match base_eval_call ~print:false (Xmlprotocol.init None) coq with - | Interface.Good id -> - let dir = Filename.dirname input_file in - let phrase = Printf.sprintf "Add LoadPath \"%s\". " dir in - let eid, tip = add_sentence ~name:"initial" phrase in - after_add (base_eval_call (Xmlprotocol.add ((phrase,eid),(tip,true))) coq) + | Interface.Good id -> () | Interface.Fail _ -> error "init call failed" in let finish () = match base_eval_call (Xmlprotocol.status true) coq with diff --git a/ide/idetop.ml b/ide/idetop.ml index 9eb0b972b6..57e9792845 100644 --- a/ide/idetop.ml +++ b/ide/idetop.ml @@ -69,7 +69,7 @@ let ide_cmd_checks ~last_valid { CAst.loc; v } = let user_error s = try CErrors.user_err ?loc ~hdr:"IDE" (str s) with e -> - let (e, info) = CErrors.push e in + let (e, info) = Exninfo.capture e in let info = Stateid.add info ~valid:last_valid Stateid.dummy in Exninfo.iraise (e, info) in @@ -477,7 +477,7 @@ let print_xml = fun oc xml -> Mutex.lock m; try Control.protect_sigalrm (Xml_printer.print oc) xml; Mutex.unlock m - with e -> let e = CErrors.push e in Mutex.unlock m; iraise e + with e -> let e = Exninfo.capture e in Mutex.unlock m; Exninfo.iraise e let slave_feeder fmt xml_oc msg = let xml = Xmlprotocol.(of_feedback fmt msg) in diff --git a/ide/protocol/xmlprotocol.ml b/ide/protocol/xmlprotocol.ml index a2c80ea118..2e78642f2e 100644 --- a/ide/protocol/xmlprotocol.ml +++ b/ide/protocol/xmlprotocol.ml @@ -679,7 +679,7 @@ let abstract_eval_call : type a. _ -> a call -> a value = fun handler c -> | PrintAst x -> mkGood (handler.print_ast x) | Annotate x -> mkGood (handler.annotate x) with any -> - let any = CErrors.push any in + let any = Exninfo.capture any in Fail (handler.handle_exn any) (** brain dead code, edit if protocol messages are added/removed *) diff --git a/interp/impargs.ml b/interp/impargs.ml index 78c4b21920..1365b97d82 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -77,9 +77,9 @@ let with_implicit_protection f x = implicit_args := oflags; rslt with reraise -> - let reraise = CErrors.push reraise in + let reraise = Exninfo.capture reraise in let () = implicit_args := oflags in - iraise reraise + Exninfo.iraise reraise type on_trailing_implicit = Error | Info | Silent diff --git a/interp/notation.ml b/interp/notation.ml index 2086e08f79..b869cb2a36 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -1959,6 +1959,6 @@ let with_notation_protection f x = let fs = freeze ~marshallable:false in try let a = f x in unfreeze fs; a with reraise -> - let reraise = CErrors.push reraise in + let reraise = Exninfo.capture reraise in let () = unfreeze fs in - iraise reraise + Exninfo.iraise reraise diff --git a/kernel/constr.ml b/kernel/constr.ml index 84eacb196c..fde08743b6 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -1297,7 +1297,8 @@ let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = fun t -> fst (sh_rec t) (* Exported hashing fonction on constr, used mainly in plugins. - Appears to have slight differences from [snd (hash_term t)] above ? *) + Slight differences from [snd (hash_term t)] above: it ignores binders + and doesn't do [land 0x3FFFFFFF]. *) let rec hash t = match kind t with @@ -1336,7 +1337,7 @@ let rec hash t = | Float f -> combinesmall 19 (Float64.hash f) and hash_term_array t = - Array.fold_left (fun acc t -> combine (hash t) acc) 0 t + Array.fold_left (fun acc t -> combine acc (hash t)) 0 t module CaseinfoHash = struct diff --git a/kernel/cooking.ml b/kernel/cooking.ml index 31dd26d2ba..13ee353c6b 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -295,20 +295,14 @@ let abstract_projection ~params expmod hyps t = t let cook_one_ind ~ntypes - (section_decls,_ as hyps) expmod mip = + hyps expmod mip = let mind_arity = match mip.mind_arity with | RegularArity {mind_user_arity=arity;mind_sort=sort} -> let arity = abstract_as_type (expmod arity) hyps in let sort = destSort (expmod (mkSort sort)) in RegularArity {mind_user_arity=arity; mind_sort=sort} - | TemplateArity {template_param_levels=levels;template_level;template_context} -> - let sec_levels = CList.map_filter (fun d -> - if RelDecl.is_local_assum d then Some None - else None) - section_decls - in - let levels = List.rev_append sec_levels levels in - TemplateArity {template_param_levels=levels;template_level;template_context} + | TemplateArity {template_level} -> + TemplateArity {template_level} in let mind_arity_ctxt = let ctx = Context.Rel.map expmod mip.mind_arity_ctxt in @@ -386,6 +380,17 @@ let cook_inductive { Opaqueproof.modlist; abstract } mib = in Some (Array.append newvariance variance), Some sec_variance in + let mind_template = match mib.mind_template with + | None -> None + | Some {template_param_levels=levels; template_context} -> + let sec_levels = CList.map_filter (fun d -> + if RelDecl.is_local_assum d then Some None + else None) + section_decls + in + let levels = List.rev_append sec_levels levels in + Some {template_param_levels=levels; template_context} + in { mind_packets; mind_record; @@ -396,6 +401,7 @@ let cook_inductive { Opaqueproof.modlist; abstract } mib = mind_nparams_rec = mib.mind_nparams_rec + nnewparams; mind_params_ctxt; mind_universes; + mind_template; mind_variance; mind_sec_variance; mind_private = mib.mind_private; diff --git a/kernel/declarations.ml b/kernel/declarations.ml index ac130d018d..11a07ee5cf 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -30,8 +30,11 @@ type engagement = set_predicativity *) type template_arity = { - template_param_levels : Univ.Level.t option list; template_level : Univ.Universe.t; +} + +type template_universes = { + template_param_levels : Univ.Level.t option list; template_context : Univ.ContextSet.t; } @@ -218,6 +221,8 @@ type mutual_inductive_body = { mind_universes : universes; (** Information about monomorphic/polymorphic/cumulative inductives and their universes *) + mind_template : template_universes option; + mind_variance : Univ.Variance.t array option; (** Variance info, [None] when non-cumulative. *) mind_sec_variance : Univ.Variance.t array option; diff --git a/kernel/declareops.ml b/kernel/declareops.ml index a3adac7a11..a1122d1279 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -46,9 +46,10 @@ let map_decl_arity f g = function | TemplateArity a -> TemplateArity (g a) let hcons_template_arity ar = + { template_level = Univ.hcons_univ ar.template_level; } + +let hcons_template_universe ar = { template_param_levels = ar.template_param_levels; - (* List.Smart.map (Option.Smart.map Univ.hcons_univ_level) ar.template_param_levels; *) - template_level = Univ.hcons_univ ar.template_level; template_context = Univ.hcons_universe_context_set ar.template_context } let universes_context = function @@ -247,6 +248,7 @@ let subst_mind_body sub mib = Context.Rel.map (subst_mps sub) mib.mind_params_ctxt; mind_packets = Array.Smart.map (subst_mind_packet sub) mib.mind_packets ; mind_universes = mib.mind_universes; + mind_template = mib.mind_template; mind_variance = mib.mind_variance; mind_sec_variance = mib.mind_sec_variance; mind_private = mib.mind_private; @@ -323,6 +325,7 @@ let hcons_mind mib = { mib with mind_packets = Array.Smart.map hcons_mind_packet mib.mind_packets; mind_params_ctxt = hcons_rel_context mib.mind_params_ctxt; + mind_template = Option.Smart.map hcons_template_universe mib.mind_template; mind_universes = hcons_universes mib.mind_universes } (** Hashconsing of modules *) diff --git a/kernel/entries.ml b/kernel/entries.ml index 8d930b521c..983fa822e9 100644 --- a/kernel/entries.ml +++ b/kernel/entries.ml @@ -37,7 +37,6 @@ then, in i{^ th} block, [mind_entry_params] is [xn:Xn;...;x1:X1]; type one_inductive_entry = { mind_entry_typename : Id.t; mind_entry_arity : constr; - mind_entry_template : bool; (* Use template polymorphism *) mind_entry_consnames : Id.t list; mind_entry_lc : constr list } @@ -50,6 +49,7 @@ type mutual_inductive_entry = { mind_entry_params : Constr.rel_context; mind_entry_inds : one_inductive_entry list; mind_entry_universes : universes_entry; + mind_entry_template : bool; (* Use template polymorphism *) mind_entry_cumulative : bool; (* universe constraints and the constraints for subtyping of inductive types in the block. *) diff --git a/kernel/environ.ml b/kernel/environ.ml index 501ac99ff3..1b5a77cc96 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -590,11 +590,11 @@ let template_polymorphic_ind (mind,i) env = | TemplateArity _ -> true | RegularArity _ -> false -let template_polymorphic_variables (mind,i) env = - match (lookup_mind mind env).mind_packets.(i).mind_arity with - | TemplateArity { Declarations.template_param_levels = l; _ } -> +let template_polymorphic_variables (mind, _) env = + match (lookup_mind mind env).mind_template with + | Some { Declarations.template_param_levels = l; _ } -> List.map_filter (fun level -> level) l - | RegularArity _ -> [] + | None -> [] let template_polymorphic_pind (ind,u) env = if not (Univ.Instance.is_empty u) then false diff --git a/kernel/indTyping.ml b/kernel/indTyping.ml index cc15109f06..d5aadd0c02 100644 --- a/kernel/indTyping.ml +++ b/kernel/indTyping.ml @@ -101,10 +101,10 @@ let check_indices_matter env_params info indices = else check_context_univs ~ctor:false env_params info indices (* env_ar contains the inductives before the current ones in the block, and no parameters *) -let check_arity env_params env_ar ind = +let check_arity ~template env_params env_ar ind = let {utj_val=arity;utj_type=_} = Typeops.infer_type env_params ind.mind_entry_arity in let indices, ind_sort = Reduction.dest_arity env_params arity in - let ind_min_univ = if ind.mind_entry_template then Some Universe.type0m else None in + let ind_min_univ = if template then Some Universe.type0m else None in let univ_info = { ind_squashed=false; ind_has_relevant_arg=false; @@ -200,28 +200,88 @@ let unbounded_from_below u cstrs = let template_polymorphic_univs ~ctor_levels uctx paramsctxt concl = let check_level l = Univ.LSet.mem l (Univ.ContextSet.levels uctx) && + (let () = assert (not @@ Univ.Level.is_small l) in true) && unbounded_from_below l (Univ.ContextSet.constraints uctx) && not (Univ.LSet.mem l ctor_levels) in let univs = Univ.Universe.levels concl in - let univs = - Univ.LSet.filter (fun l -> check_level l || Univ.Level.is_prop l) univs - in + let univs = Univ.LSet.filter (fun l -> check_level l) univs in let fold acc = function | (LocalAssum (_, p)) -> (let c = Term.strip_prod_assum p in match kind c with | Sort (Type u) -> (match Univ.Universe.level u with - | Some l -> if Univ.LSet.mem l univs && not (Univ.Level.is_prop l) then Some l else None + | Some l -> if Univ.LSet.mem l univs then Some l else None | None -> None) | _ -> None) :: acc | LocalDef _ -> acc in let params = List.fold_left fold [] paramsctxt in - params, univs + if Universe.is_type0m concl then Some (univs, params) + else if not @@ Univ.LSet.is_empty univs then Some (univs, params) + else None + +let get_param_levels ctx params arity splayed_lc = + let min_univ = match arity with + | RegularArity _ -> + CErrors.user_err + Pp.(strbrk "Ill-formed template mutual inductive declaration: all types must be template.") + | TemplateArity ar -> ar.template_level + in + let ctor_levels = + let add_levels c levels = Univ.LSet.union levels (Vars.universes_of_constr c) in + let param_levels = + List.fold_left (fun levels d -> match d with + | LocalAssum _ -> levels + | LocalDef (_,b,t) -> add_levels b (add_levels t levels)) + Univ.LSet.empty params + in + Array.fold_left + (fun levels (d,c) -> + let levels = + List.fold_left (fun levels d -> + Context.Rel.Declaration.fold_constr add_levels d levels) + levels d + in + add_levels c levels) + param_levels + splayed_lc + in + match template_polymorphic_univs ~ctor_levels ctx params min_univ with + | None -> + CErrors.user_err + Pp.(strbrk "Ill-formed template inductive declaration: not polymorphic on any universe.") + | Some (_, param_levels) -> + param_levels + +let get_template univs params data = + let ctx = match univs with + | Monomorphic ctx -> ctx + | Polymorphic _ -> + CErrors.anomaly ~label:"polymorphic_template_ind" + Pp.(strbrk "Template polymorphism and full polymorphism are incompatible.") in + (* For each type in the block, compute potential template parameters *) + let params = List.map (fun ((arity, _), (_, splayed_lc), _) -> get_param_levels ctx params arity splayed_lc) data in + (* Pick the lower bound of template parameters. Note that in particular, if + one of the the inductive types from the block is Prop-valued, then no + parameters are template. *) + let fold min params = + let map u v = match u, v with + | (None, _) | (_, None) -> None + | Some u, Some v -> + let () = assert (Univ.Level.equal u v) in + Some u + in + List.map2 map min params + in + let params = match params with + | [] -> assert false + | hd :: rem -> List.fold_left fold hd rem + in + { template_param_levels = params; template_context = ctx } -let abstract_packets univs usubst params ((arity,lc),(indices,splayed_lc),univ_info) = +let abstract_packets usubst ((arity,lc),(indices,splayed_lc),univ_info) = if not (Universe.Set.is_empty univ_info.missing) then raise (InductiveError (MissingConstraints (univ_info.missing,univ_info.ind_univ))); let arity = Vars.subst_univs_level_constr usubst arity in @@ -237,40 +297,7 @@ let abstract_packets univs usubst params ((arity,lc),(indices,splayed_lc),univ_i let arity = match univ_info.ind_min_univ with | None -> RegularArity {mind_user_arity = arity; mind_sort = Sorts.sort_of_univ ind_univ} - | Some min_univ -> - let ctx = match univs with - | Monomorphic ctx -> ctx - | Polymorphic _ -> - CErrors.anomaly ~label:"polymorphic_template_ind" - Pp.(strbrk "Template polymorphism and full polymorphism are incompatible.") in - let ctor_levels = - let add_levels c levels = Univ.LSet.union levels (Vars.universes_of_constr c) in - let param_levels = - List.fold_left (fun levels d -> match d with - | LocalAssum _ -> levels - | LocalDef (_,b,t) -> add_levels b (add_levels t levels)) - Univ.LSet.empty params - in - Array.fold_left - (fun levels (d,c) -> - let levels = - List.fold_left (fun levels d -> - Context.Rel.Declaration.fold_constr add_levels d levels) - levels d - in - add_levels c levels) - param_levels - splayed_lc - in - let param_levels, concl_levels = - template_polymorphic_univs ~ctor_levels ctx params min_univ - in - if List.for_all (fun x -> Option.is_empty x) param_levels - && Univ.LSet.is_empty concl_levels then - CErrors.user_err - Pp.(strbrk "Ill-formed template inductive declaration: not polymorphic on any universe.") - else - TemplateArity {template_param_levels = param_levels; template_level = min_univ; template_context = ctx } + | Some min_univ -> TemplateArity { template_level = min_univ; } in let kelim = allowed_sorts univ_info in @@ -285,7 +312,7 @@ let typecheck_inductive env ~sec_univs (mie:mutual_inductive_entry) = mind_check_names mie; assert (List.is_empty (Environ.rel_context env)); - let has_template_poly = List.exists (fun oie -> oie.mind_entry_template) mie.mind_entry_inds in + let has_template_poly = mie.mind_entry_template in (* universes *) let env_univs = @@ -306,7 +333,7 @@ let typecheck_inductive env ~sec_univs (mie:mutual_inductive_entry) = let env_params, params = Typeops.check_context env_univs mie.mind_entry_params in (* Arities *) - let env_ar, data = List.fold_left_map (check_arity env_params) env_univs mie.mind_entry_inds in + let env_ar, data = List.fold_left_map (check_arity ~template:has_template_poly env_params) env_univs mie.mind_entry_inds in let env_ar_par = push_rel_context params env_ar in (* Constructors *) @@ -352,7 +379,14 @@ let typecheck_inductive env ~sec_univs (mie:mutual_inductive_entry) = (* Abstract universes *) let usubst, univs = Declareops.abstract_universes mie.mind_entry_universes in let params = Vars.subst_univs_level_context usubst params in - let data = List.map (abstract_packets univs usubst params) data in + let data = List.map (abstract_packets usubst) data in + let template = + let check ((arity, _), _, _) = match arity with + | TemplateArity _ -> true + | RegularArity _ -> false + in + if List.exists check data then Some (get_template univs params data) else None + in let env_ar_par = let ctx = Environ.rel_context env_ar_par in @@ -361,4 +395,4 @@ let typecheck_inductive env ~sec_univs (mie:mutual_inductive_entry) = Environ.push_rel_context ctx env in - env_ar_par, univs, variance, record, params, Array.of_list data + env_ar_par, univs, template, variance, record, params, Array.of_list data diff --git a/kernel/indTyping.mli b/kernel/indTyping.mli index 723ba5459e..babb82c39e 100644 --- a/kernel/indTyping.mli +++ b/kernel/indTyping.mli @@ -29,6 +29,7 @@ val typecheck_inductive : env -> sec_univs:Univ.Level.t array option -> mutual_inductive_entry -> env * universes + * template_universes option * Univ.Variance.t array option * Names.Id.t array option option * Constr.rel_context @@ -44,4 +45,4 @@ val template_polymorphic_univs : Univ.ContextSet.t -> Constr.rel_context -> Univ.Universe.t -> - Univ.Level.t option list * Univ.LSet.t + (Univ.LSet.t * Univ.Level.t option list) option diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index b6b8e5265c..c5a39262a4 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -102,7 +102,7 @@ let failwith_non_pos_list n ntypes l = (* Check the inductive type is called with the expected parameters *) (* [n] is the index of the last inductive type in [env] *) -let check_correct_par (env,n,ntypes,_) paramdecls ind_index args = +let check_correct_par ~chkpos (env,n,ntypes,_) paramdecls ind_index args = let nparams = Context.Rel.nhyps paramdecls in let args = Array.of_list args in if Array.length args < nparams then @@ -123,7 +123,7 @@ let check_correct_par (env,n,ntypes,_) paramdecls ind_index args = LocalNonPar (param_index+1, paramdecl_index_in_env, ind_index) in raise (IllFormedInd err) in check (nparams-1) (n-nparamdecls) paramdecls; - if not (Array.for_all (noccur_between n ntypes) realargs) then + if chkpos && not (Array.for_all (noccur_between n ntypes) realargs) then failwith_non_pos_vect n ntypes realargs (* Computes the maximum number of recursive parameters: @@ -325,7 +325,7 @@ let check_positivity_one ~chkpos recursive (env,_,ntypes,_ as ienv) paramsctxt ( if check_head then begin match hd with | Rel j when Int.equal j (n + ntypes - i - 1) -> - check_correct_par ienv paramsctxt (ntypes - i) largs + check_correct_par ~chkpos ienv paramsctxt (ntypes - i) largs | _ -> raise (IllFormedInd (LocalNotConstructor(paramsctxt,nnonrecargs))) end else @@ -466,7 +466,7 @@ let compute_projections (kn, i as ind) mib = Array.of_list (List.rev rs), Array.of_list (List.rev pbs) -let build_inductive env ~sec_univs names prv univs variance +let build_inductive env ~sec_univs names prv univs template variance paramsctxt kn isrecord isfinite inds nmr recargs = let ntypes = Array.length inds in (* Compute the set of used section variables *) @@ -538,6 +538,7 @@ let build_inductive env ~sec_univs names prv univs variance mind_params_ctxt = paramsctxt; mind_packets = packets; mind_universes = univs; + mind_template = template; mind_variance = variance; mind_sec_variance = sec_variance; mind_private = prv; @@ -562,7 +563,7 @@ let build_inductive env ~sec_univs names prv univs variance let check_inductive env ~sec_univs kn mie = (* First type-check the inductive definition *) - let (env_ar_par, univs, variance, record, paramsctxt, inds) = + let (env_ar_par, univs, template, variance, record, paramsctxt, inds) = IndTyping.typecheck_inductive env ~sec_univs mie in (* Then check positivity conditions *) @@ -575,6 +576,6 @@ let check_inductive env ~sec_univs kn mie = (Array.map (fun ((_,lc),(indices,_),_) -> Context.Rel.nhyps indices,lc) inds) in (* Build the inductive packets *) - build_inductive env ~sec_univs names mie.mind_entry_private univs variance + build_inductive env ~sec_univs names mie.mind_entry_private univs template variance paramsctxt kn record mie.mind_entry_finite inds nmr recargs diff --git a/kernel/inductive.ml b/kernel/inductive.ml index c6035f78ff..6325779675 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -185,8 +185,8 @@ let make_subst = exception SingletonInductiveBecomesProp of Id.t -let instantiate_universes ctx ar args = - let subst = make_subst (ctx,ar.template_param_levels,args) in +let instantiate_universes ctx (templ, ar) args = + let subst = make_subst (ctx,templ.template_param_levels,args) in let level = Univ.subst_univs_universe (Univ.make_subst subst) ar.template_level in let ty = (* Singleton type not containing types are interpretable in Prop *) @@ -215,8 +215,12 @@ let type_of_inductive_gen ?(polyprop=true) ((mib,mip),u) paramtyps = match mip.mind_arity with | RegularArity a -> subst_instance_constr u a.mind_user_arity | TemplateArity ar -> + let templ = match mib.mind_template with + | None -> assert false + | Some t -> t + in let ctx = List.rev mip.mind_arity_ctxt in - let ctx,s = instantiate_universes ctx ar paramtyps in + let ctx,s = instantiate_universes ctx (templ, ar) paramtyps in (* The Ocaml extraction cannot handle (yet?) "Prop-polymorphism", i.e. the situation where a non-Prop singleton inductive becomes Prop when applied to Prop params *) @@ -962,7 +966,7 @@ let check_one_fix renv recpos trees def = let stack_br = push_stack_args case_spec.(k) stack' in check_rec_call renv stack_br br') with (FixGuardError _ as exn) -> - let exn = CErrors.push exn in + let exn = Exninfo.capture exn in (* we try hard to reduce the match away by looking for a constructor in c_0 (we unfold definitions too) *) let c_0 = whd_all renv.env c_0 in @@ -1007,7 +1011,7 @@ let check_one_fix renv recpos trees def = check_nested_fix_body illformed renv' (decrArg+1) arg_sp body else check_rec_call renv' [] body) with (FixGuardError _ as exn) -> - let exn = CErrors.push exn in + let exn = Exninfo.capture exn in (* we try hard to reduce the fix away by looking for a constructor in l[decrArg] (we unfold definitions too) *) if List.length l <= decrArg then Exninfo.iraise exn; @@ -1055,7 +1059,7 @@ let check_one_fix renv recpos trees def = List.iter (check_rec_call renv []) l; check_rec_call renv [] c with (FixGuardError _ as exn) -> - let exn = CErrors.push exn in + let exn = Exninfo.capture exn in (* we try hard to reduce the proj away by looking for a constructor in c (we unfold definitions too) *) let c = whd_all renv.env c in diff --git a/kernel/inductive.mli b/kernel/inductive.mli index b690fe1157..90571844b9 100644 --- a/kernel/inductive.mli +++ b/kernel/inductive.mli @@ -123,9 +123,6 @@ exception SingletonInductiveBecomesProp of Id.t val max_inductive_sort : Sorts.t array -> Universe.t -val instantiate_universes : Constr.rel_context -> - template_arity -> param_univs -> Constr.rel_context * Sorts.t - (** {6 Debug} *) type size = Large | Strict diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml index 86eaaddc90..3f2e63b984 100644 --- a/kernel/nativelib.ml +++ b/kernel/nativelib.ml @@ -180,8 +180,8 @@ let call_linker ?(fatal=true) env ~prefix f upds = if Dynlink.is_native then Dynlink.loadfile f else !load_obj f; register_native_file prefix with Dynlink.Error _ as exn -> - let exn = CErrors.push exn in - if fatal then iraise exn + let exn = Exninfo.capture exn in + if fatal then Exninfo.iraise exn else if !Flags.debug then Feedback.msg_debug CErrors.(iprint exn)); match upds with Some upds -> update_locations upds | _ -> () diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 8db8a044a8..a37d04d82c 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -249,11 +249,52 @@ let check_engagement env expected_impredicative_set = (** {6 Stm machinery } *) +module Certificate : +sig + type t + + val make : safe_environment -> t + + val universes : t -> Univ.ContextSet.t + + (** Checks whether [dst] is a valid extension of [src] *) + val check : src:t -> dst:t -> bool +end = +struct + +type t = { + certif_struc : Declarations.structure_body; + certif_univs : Univ.ContextSet.t; +} + +let make senv = { + certif_struc = senv.revstruct; + certif_univs = senv.univ; +} + +let is_suffix l suf = match l with +| [] -> false +| _ :: l -> l == suf + +let is_subset (s1, cst1) (s2, cst2) = + Univ.LSet.subset s1 s2 && Univ.Constraint.subset cst1 cst2 + +let check ~src ~dst = + is_suffix dst.certif_struc src.certif_struc && + is_subset src.certif_univs dst.certif_univs + +let universes c = c.certif_univs + +end + type side_effect = { - from_env : Declarations.structure_body CEphemeron.key; + seff_certif : Certificate.t CEphemeron.key; seff_constant : Constant.t; seff_body : Constr.t Declarations.constant_body; } +(* Invariant: For any senv, if [Certificate.check senv seff_certif] then + senv where univs := Certificate.universes seff_certif] + + (c.seff_constant -> seff_body) is well-formed. *) module SideEffects : sig @@ -609,7 +650,7 @@ let inline_side_effects env body side_eff = let filter e = let cb = (e.seff_constant, e.seff_body) in if Environ.mem_constant e.seff_constant env then None - else Some (cb, e.from_env) + else Some (cb, e.seff_certif) in (* CAVEAT: we assure that most recent effects come first *) let side_eff = List.map_filter filter (SideEffects.repr side_eff) in @@ -678,28 +719,27 @@ let inline_private_constants env ((body, ctx), side_eff) = let ctx' = Univ.ContextSet.union ctx ctx' in (body, ctx') -let is_suffix l suf = match l with -| [] -> false -| _ :: l -> l == suf - (* Given the list of signatures of side effects, checks if they match. * I.e. if they are ordered descendants of the current revstruct. Returns the number of effects that can be trusted. *) -let check_signatures curmb sl = +let check_signatures senv sl = + let curmb = Certificate.make senv in let is_direct_ancestor accu mb = match accu with | None -> None - | Some (n, curmb) -> + | Some curmb -> try let mb = CEphemeron.get mb in - if is_suffix mb curmb - then Some (n + 1, mb) + if Certificate.check ~src:curmb ~dst:mb + then Some mb else None with CEphemeron.InvalidKey -> None in - let sl = List.fold_left is_direct_ancestor (Some (0, curmb)) sl in + let sl = List.fold_left is_direct_ancestor (Some curmb) sl in match sl with - | None -> 0 - | Some (n, _) -> n + | None -> None + | Some mb -> + let univs = Certificate.universes mb in + Some (Univ.ContextSet.diff univs senv.univ) type side_effect_declaration = | DefinitionEff : Entries.definition_entry -> side_effect_declaration @@ -759,13 +799,14 @@ let translate_direct_opaque env kn ce = let () = assert (is_empty_private u) in { cb with const_body = OpaqueDef c } -let export_side_effects mb env eff = +let export_side_effects senv eff = + let env = senv.env in let not_exists e = not (Environ.mem_constant e.seff_constant env) in let aux (acc,sl) e = if not (not_exists e) then acc, sl - else e :: acc, e.from_env :: sl in + else e :: acc, e.seff_certif :: sl in let seff, signatures = List.fold_left aux ([],[]) (SideEffects.repr eff) in - let trusted = check_signatures mb signatures in + let trusted = check_signatures senv signatures in let push_seff env eff = let { seff_constant = kn; seff_body = cb ; _ } = eff in let env = Environ.add_constant kn (lift_constant cb) env in @@ -774,31 +815,29 @@ let export_side_effects mb env eff = | Monomorphic ctx -> Environ.push_context_set ~strict:true ctx env in - let rec translate_seff sl seff acc env = - match seff with - | [] -> List.rev acc - | eff :: rest -> - if Int.equal sl 0 then - let env, cb = - let kn = eff.seff_constant in - let ce = constant_entry_of_side_effect eff in - let open Entries in - let cb = match ce with - | DefinitionEff ce -> - Term_typing.translate_constant env kn (DefinitionEntry ce) - | OpaqueEff ce -> - translate_direct_opaque env kn ce - in - let eff = { eff with seff_body = cb } in - (push_seff env eff, export_eff eff) - in - translate_seff 0 rest (cb :: acc) env - else - let env = push_seff env eff in - let ecb = export_eff eff in - translate_seff (sl - 1) rest (ecb :: acc) env - in - translate_seff trusted seff [] env + match trusted with + | Some univs -> + univs, List.map export_eff seff + | None -> + let rec recheck_seff seff acc env = match seff with + | [] -> List.rev acc + | eff :: rest -> + let env, cb = + let kn = eff.seff_constant in + let ce = constant_entry_of_side_effect eff in + let open Entries in + let cb = match ce with + | DefinitionEff ce -> + Term_typing.translate_constant env kn (DefinitionEntry ce) + | OpaqueEff ce -> + translate_direct_opaque env kn ce + in + let eff = { eff with seff_body = cb } in + (push_seff env eff, export_eff eff) + in + recheck_seff rest (cb :: acc) env + in + Univ.ContextSet.empty, recheck_seff seff [] env let push_opaque_proof pf senv = let o, otab = Opaqueproof.create (library_dp_of_senv senv) pf (Environ.opaque_tables senv.env) in @@ -806,7 +845,8 @@ let push_opaque_proof pf senv = senv, o let export_private_constants eff senv = - let exported = export_side_effects senv.revstruct senv.env eff in + let uctx, exported = export_side_effects senv eff in + let senv = push_context_set ~strict:true uctx senv in let map senv (kn, c) = match c.const_body with | OpaqueDef p -> let local = empty_private c.const_universes in @@ -828,7 +868,11 @@ let add_constant l decl senv = | OpaqueEntry ce -> let handle env body eff = let body, uctx, signatures = inline_side_effects env body eff in - let trusted = check_signatures senv.revstruct signatures in + let trusted = check_signatures senv signatures in + let trusted, uctx = match trusted with + | None -> 0, uctx + | Some univs -> List.length signatures, Univ.ContextSet.union univs uctx + in body, uctx, trusted in let cb, ctx = Term_typing.translate_opaque senv.env kn ce in @@ -890,9 +934,9 @@ let add_private_constant l decl senv : (Constant.t * private_constants) * safe_e in let senv = add_constant_aux senv (kn, dcb) in let eff = - let from_env = CEphemeron.create senv.revstruct in + let from_env = CEphemeron.create (Certificate.make senv) in let eff = { - from_env = from_env; + seff_certif = from_env; seff_constant = kn; seff_body = cb; } in @@ -1259,12 +1303,7 @@ let start_library dir senv = required = senv.required } let export ?except ~output_native_objects senv dir = - let senv = - try join_safe_environment ?except senv - with e -> - let e = CErrors.push e in - CErrors.user_err ~hdr:"export" (CErrors.iprint e) - in + let senv = join_safe_environment ?except senv in assert(senv.future_cst = []); let () = check_current_library dir senv in let mp = senv.modpath in diff --git a/lib/cErrors.ml b/lib/cErrors.ml index 323dc8c1a4..a23cf3aaf1 100644 --- a/lib/cErrors.ml +++ b/lib/cErrors.ml @@ -79,7 +79,7 @@ let is_anomaly = function (** 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) = +let register_additional_error_info (f : Exninfo.info -> (Pp.t Loc.located) option) = additional_error_info_handler := f :: !additional_error_info_handler (** [print_gen] is a general exception printer which tries successively @@ -93,18 +93,15 @@ let rec print_gen ~anomaly ~extra_msg stk e = | h::stk' -> match h e with | Some err_msg -> - Option.cata (fun msg -> msg ++ err_msg) err_msg extra_msg + extra_msg ++ err_msg | None -> print_gen ~anomaly ~extra_msg stk' e 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 = match extra_info with - | None -> None - | Some (loc, msg) -> msg + let extra_msg = + CList.map_filter (fun f -> f info) !additional_error_info_handler + (* Location info in the handler is ignored *) + |> List.map snd |> Pp.seq in try print_gen ~anomaly ~extra_msg !handle_stack e diff --git a/lib/cErrors.mli b/lib/cErrors.mli index 1660a00244..f9c84b001c 100644 --- a/lib/cErrors.mli +++ b/lib/cErrors.mli @@ -14,7 +14,7 @@ (** {6 Error handling} *) val push : exn -> Exninfo.iexn -(** Alias for [Backtrace.add_backtrace]. *) +[@@ocaml.deprecated "please use [Exninfo.capture]"] (** {6 Generic errors.} @@ -75,5 +75,5 @@ val noncritical : exn -> bool exceptions. This method is fragile and should be considered deprecated *) val register_additional_error_info - : (Exninfo.info -> (Pp.t option Loc.located) option) + : (Exninfo.info -> Pp.t Loc.located option) -> unit diff --git a/lib/control.ml b/lib/control.ml index e67e88ee95..1898eab89e 100644 --- a/lib/control.ml +++ b/lib/control.ml @@ -75,8 +75,8 @@ let windows_timeout n f x e = if not !exited then begin killed := true; raise Sys.Break end else raise e | e -> - let () = killed := true in let e = Exninfo.capture e in + let () = killed := true in Exninfo.iraise e type timeout = { timeout : 'a 'b. int -> ('a -> 'b) -> 'a -> exn -> 'b } diff --git a/lib/future.ml b/lib/future.ml index ddf841b7fc..e8d232ad96 100644 --- a/lib/future.ml +++ b/lib/future.ml @@ -131,7 +131,7 @@ let rec compute ck : 'a value = let data = f () in c := Val data; `Val data with e -> - let e = CErrors.push e in + let e = Exninfo.capture e in let e = fix_exn e in match e with | (NotReady _, _) -> `Exn e @@ -201,11 +201,7 @@ let pp_with ft pp = pp_cmd s; pp_close_tag ft () [@warning "-3"] in - try pp_cmd pp - with reraise -> - let reraise = Exninfo.capture reraise in - let () = Format.pp_print_flush ft () in - Exninfo.iraise reraise + pp_cmd pp (* If mixing some output and a goal display, please use msg_warning, so that interfaces (proofgeneral for example) can easily dispatch diff --git a/lib/system.ml b/lib/system.ml index 2d68fd2fdf..9089eda564 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -248,9 +248,9 @@ let extern_state magic filename val_0 = marshal_out channel val_0; close_out channel with reraise -> - let reraise = CErrors.push reraise in + let reraise = Exninfo.capture reraise in let () = try_remove filename in - iraise reraise + Exninfo.iraise reraise with Sys_error s -> CErrors.user_err ~hdr:"System.extern_state" (str "System error: " ++ str s) diff --git a/lib/util.ml b/lib/util.ml index e2447b005e..ae8119ced0 100644 --- a/lib/util.ml +++ b/lib/util.ml @@ -82,10 +82,6 @@ module Set = CSet module Map = CMap -(* Stacks *) - -module Stack = CStack - (* Matrices *) let matrix_transpose mat = diff --git a/lib/util.mli b/lib/util.mli index 2f1a03a19c..be0cc11763 100644 --- a/lib/util.mli +++ b/lib/util.mli @@ -76,10 +76,6 @@ module Set : module type of CSet module Map : module type of CMap -(** {6 Stacks.} *) - -module Stack : module type of CStack - (** {6 Streams. } *) val stream_nth : int -> 'a Stream.t -> 'a @@ -119,8 +115,10 @@ val delayed_force : 'a delayed -> 'a (** {6 Enriched exceptions} *) type iexn = Exninfo.iexn +[@@ocaml.deprecated "please use [Exninfo.iexn]"] -val iraise : iexn -> 'a +val iraise : Exninfo.iexn -> 'a +[@@ocaml.deprecated "please use [Exninfo.iraise]"] (** {6 Misc. } *) diff --git a/library/states.ml b/library/states.ml index 90303a2a5c..c656dfb952 100644 --- a/library/states.ml +++ b/library/states.ml @@ -8,8 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Util - type state = Lib.frozen * Summary.frozen let lib_of_state = fst @@ -31,5 +29,5 @@ let with_state_protection f x = try let a = f x in unfreeze st; a with reraise -> - let reraise = CErrors.push reraise in - (unfreeze st; iraise reraise) + let reraise = Exninfo.capture reraise in + (unfreeze st; Exninfo.iraise reraise) diff --git a/parsing/extend.ml b/parsing/extend.ml index 848861238a..c53c3f02a8 100644 --- a/parsing/extend.ml +++ b/parsing/extend.ml @@ -10,7 +10,7 @@ (** Entry keys for constr notations *) -type 'a entry = 'a Gramlib.Grammar.GMake(CLexer.Lexer).Entry.e +type 'a entry = 'a Gramlib.Grammar.GMake(CLexer.Lexer).Entry.t type side = Left | Right @@ -82,8 +82,8 @@ type ('a,'b,'c) ty_user_symbol = (* Should be merged with gramlib's implementation *) -type norec = Gramlib.Grammar.ty_norec -type mayrec = Gramlib.Grammar.ty_mayrec +type norec = Gramlib.Grammar.norec +type mayrec = Gramlib.Grammar.mayrec type ('self, 'trec, 'a) symbol = | Atoken : 'c Tok.p -> ('self, norec, 'c) symbol diff --git a/parsing/g_prim.mlg b/parsing/g_prim.mlg index 5f61b9a047..7e0360af72 100644 --- a/parsing/g_prim.mlg +++ b/parsing/g_prim.mlg @@ -37,6 +37,12 @@ let test_pipe_closedcurly = lk_kw "|" >> lk_kw "}" >> check_no_space end +let test_minus_nat = + let open Pcoq.Lookahead in + to_entry "test_minus_nat" begin + lk_kw "-" >> lk_nat >> check_no_space + end + } GRAMMAR EXTEND Gram @@ -122,7 +128,7 @@ GRAMMAR EXTEND Gram ; integer: [ [ i = NUMERAL -> { my_int_of_string loc (check_int loc i) } - | "-"; i = NUMERAL -> { - my_int_of_string loc (check_int loc i) } ] ] + | test_minus_nat; "-"; i = NUMERAL -> { - my_int_of_string loc (check_int loc i) } ] ] ; natural: [ [ i = NUMERAL -> { my_int_of_string loc (check_int loc i) } ] ] diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index d1a6e0eda2..398899aad4 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -65,20 +65,20 @@ module type S = val comment_state : coq_parsable -> ((int * int) * string) list -end with type 'a Entry.e = 'a Extend.entry = struct +end with type 'a Entry.t = 'a Extend.entry = struct include Grammar.GMake(CLexer.Lexer) - type coq_parsable = parsable * CLexer.lexer_state ref + type coq_parsable = Parsable.t * CLexer.lexer_state ref let coq_parsable ?loc c = let state = ref (CLexer.init_lexer_state ()) in CLexer.set_lexer_state !state; - let a = parsable ?loc c in + let a = Parsable.make ?loc c in state := CLexer.get_lexer_state (); (a,state) - let entry_create = Entry.create + let entry_create = Entry.make let entry_parse e (p,state) = CLexer.set_lexer_state !state; @@ -107,9 +107,9 @@ end module Entry = struct - type 'a t = 'a Grammar.GMake(CLexer.Lexer).Entry.e + type 'a t = 'a Grammar.GMake(CLexer.Lexer).Entry.t - let create = G.Entry.create + let create = G.Entry.make let parse = G.entry_parse let print = G.Entry.print let of_parser = G.Entry.of_parser @@ -189,53 +189,53 @@ end (** Binding general entry keys to symbol *) -let rec symbol_of_prod_entry_key : type s tr a. (s, tr, a) symbol -> (s, tr, a) G.ty_symbol = +let rec symbol_of_prod_entry_key : type s tr a. (s, tr, a) symbol -> (s, tr, a) G.Symbol.t = function -| Atoken t -> G.s_token t +| Atoken t -> G.Symbol.token t | Alist1 s -> let s = symbol_of_prod_entry_key s in - G.s_list1 s + G.Symbol.list1 s | Alist1sep (s,sep) -> let s = symbol_of_prod_entry_key s in let sep = symbol_of_prod_entry_key sep in - G.s_list1sep s sep false + G.Symbol.list1sep s sep false | Alist0 s -> let s = symbol_of_prod_entry_key s in - G.s_list0 s + G.Symbol.list0 s | Alist0sep (s,sep) -> let s = symbol_of_prod_entry_key s in let sep = symbol_of_prod_entry_key sep in - G.s_list0sep s sep false + G.Symbol.list0sep s sep false | Aopt s -> let s = symbol_of_prod_entry_key s in - G.s_opt s -| Aself -> G.s_self -| Anext -> G.s_next -| Aentry e -> G.s_nterm e -| Aentryl (e, n) -> G.s_nterml e n + G.Symbol.opt s +| Aself -> G.Symbol.self +| Anext -> G.Symbol.next +| Aentry e -> G.Symbol.nterm e +| Aentryl (e, n) -> G.Symbol.nterml e n | Arules rs -> let warning msg = Feedback.msg_warning Pp.(str msg) in - G.s_rules ~warning:(Some warning) (List.map symbol_of_rules rs) + G.Symbol.rules ~warning:(Some warning) (List.map symbol_of_rules rs) -and symbol_of_rule : type s tr a r. (s, tr, a, Loc.t -> r) Extend.rule -> (s, tr, a, Loc.t -> r) G.ty_rule = function +and symbol_of_rule : type s tr a r. (s, tr, a, Loc.t -> r) Extend.rule -> (s, tr, a, Loc.t -> r) G.Rule.t = function | Stop -> - G.r_stop + G.Rule.stop | Next (r, s) -> let r = symbol_of_rule r in let s = symbol_of_prod_entry_key s in - G.r_next r s + G.Rule.next r s | NextNoRec (r, s) -> let r = symbol_of_rule r in let s = symbol_of_prod_entry_key s in - G.r_next_norec r s + G.Rule.next_norec r s -and symbol_of_rules : type a. a Extend.rules -> a G.ty_rules = function +and symbol_of_rules : type a. a Extend.rules -> a G.Rules.t = function | Rules (r, act) -> let symb = symbol_of_rule r in - G.rules (symb,act) + G.Rules.make symb act (** FIXME: This is a hack around a deficient camlp5 API *) -type 'a any_production = AnyProduction : ('a, 'tr, 'f, Loc.t -> 'a) G.ty_rule * 'f -> 'a any_production +type 'a any_production = AnyProduction : ('a, 'tr, 'f, Loc.t -> 'a) G.Rule.t * 'f -> 'a any_production let of_coq_production_rule : type a. a Extend.production_rule -> a any_production = function | Rule (toks, act) -> @@ -249,7 +249,7 @@ let of_coq_extend_statement (pos, st) = let fix_extend_statement (pos, st) = let fix_single_extend_statement (lvl, assoc, rules) = - let fix_production_rule (AnyProduction (s, act)) = G.production (s, act) in + let fix_production_rule (AnyProduction (s, act)) = G.Production.make s act in (lvl, assoc, List.map fix_production_rule rules) in (pos, List.map fix_single_extend_statement st) @@ -274,13 +274,13 @@ type extend_rule = | ExtendRuleReinit : 'a Entry.t * gram_reinit * 'a extend_statement -> extend_rule module EntryCommand = Dyn.Make () -module EntryData = struct type _ t = Ex : 'b G.Entry.e String.Map.t -> ('a * 'b) t end +module EntryData = struct type _ t = Ex : 'b G.Entry.t String.Map.t -> ('a * 'b) t end module EntryDataMap = EntryCommand.Map(EntryData) type ext_kind = | ByGrammar of extend_rule | ByEXTEND of (unit -> unit) * (unit -> unit) - | ByEntry : ('a * 'b) EntryCommand.tag * string * 'b G.Entry.e -> ext_kind + | ByEntry : ('a * 'b) EntryCommand.tag * string * 'b G.Entry.t -> ext_kind (** The list of extensions *) @@ -374,18 +374,18 @@ let make_rule r = [None, None, r] let eoi_entry en = let e = Entry.create ((Gram.Entry.name en) ^ "_eoi") in - let symbs = G.r_next (G.r_next G.r_stop (G.s_nterm en)) (G.s_token Tok.PEOI) in + let symbs = G.Rule.next (G.Rule.next G.Rule.stop (G.Symbol.nterm en)) (G.Symbol.token Tok.PEOI) in let act = fun _ x loc -> x in let warning msg = Feedback.msg_warning Pp.(str msg) in - Gram.safe_extend ~warning:(Some warning) e None (make_rule [G.production (symbs, act)]); + Gram.safe_extend ~warning:(Some warning) e None (make_rule [G.Production.make symbs act]); e let map_entry f en = let e = Entry.create ((Gram.Entry.name en) ^ "_map") in - let symbs = G.r_next G.r_stop (G.s_nterm en) in + let symbs = G.Rule.next G.Rule.stop (G.Symbol.nterm en) in let act = fun x loc -> f x in let warning msg = Feedback.msg_warning Pp.(str msg) in - Gram.safe_extend ~warning:(Some warning) e None (make_rule [G.production (symbs, act)]); + Gram.safe_extend ~warning:(Some warning) e None (make_rule [G.Production.make symbs act]); e (* Parse a string, does NOT check if the entire string was read @@ -531,7 +531,7 @@ module Module = let epsilon_value (type s tr a) f (e : (s, tr, a) symbol) = let s = symbol_of_prod_entry_key e in - let r = G.production (G.r_next G.r_stop s, (fun x _ -> f x)) in + let r = G.Production.make (G.Rule.next G.Rule.stop s) (fun x _ -> f x) in let ext = [None, None, [r]] in let entry = Gram.entry_create "epsilon" in let warning msg = Feedback.msg_warning Pp.(str msg) in @@ -593,7 +593,7 @@ let extend_grammar_command tag g = let nb = List.length rules in grammar_stack := (GramExt (nb, GrammarCommand.Dyn (tag, g)), st) :: !grammar_stack -let extend_entry_command (type a) (type b) (tag : (a, b) entry_command) (g : a) : b Gram.Entry.e list = +let extend_entry_command (type a) (type b) (tag : (a, b) entry_command) (g : a) : b Gram.Entry.t list = let EntryInterp.Ex modify = EntryInterpMap.find tag !entry_interp in let grammar_state = match !grammar_stack with | [] -> GramState.empty @@ -626,7 +626,7 @@ let extend_dyn_grammar (e, _) = match e with (** Registering extra grammar *) -type any_entry = AnyEntry : 'a Gram.Entry.e -> any_entry +type any_entry = AnyEntry : 'a Gram.Entry.t -> any_entry let grammar_names : any_entry list String.Map.t ref = ref String.Map.empty @@ -685,9 +685,9 @@ let with_grammar_rule_protection f x = let fs = freeze ~marshallable:false in try let a = f x in unfreeze fs; a with reraise -> - let reraise = CErrors.push reraise in + let reraise = Exninfo.capture reraise in let () = unfreeze fs in - iraise reraise + Exninfo.iraise reraise (** Registering grammar of generic arguments *) diff --git a/plugins/cc/ccalgo.mli b/plugins/cc/ccalgo.mli index 3dc934b426..b0b74f4558 100644 --- a/plugins/cc/ccalgo.mli +++ b/plugins/cc/ccalgo.mli @@ -8,7 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Util open Constr open Names @@ -156,102 +155,6 @@ val subterms : forest -> int -> int * int val join_path : forest -> int -> int -> ((int * int) * equality) list * ((int * int) * equality) list -val make_fun_table : state -> Int.Set.t PafMap.t - -val do_match : state -> - (quant_eq * int array) list ref -> matching_problem Stack.t -> unit - -val init_pb_stack : state -> matching_problem Stack.t - -val paf_of_patt : int Termhash.t -> ccpattern -> pa_fun - -val find_instances : state -> (quant_eq * int array) list - val execute : bool -> state -> explanation option val pr_idx_term : Environ.env -> Evd.evar_map -> forest -> int -> Pp.t - -val empty_forest: unit -> forest - - - - - - - - - - -(*type pa_constructor - - -module PacMap:CSig.MapS with type key=pa_constructor - -type term = - Symb of Term.constr - | Eps - | Appli of term * term - | Constructor of Names.constructor*int*int - -type rule = - Congruence - | Axiom of Names.Id.t - | Injection of int*int*int*int - -type equality = - {lhs : int; - rhs : int; - rule : rule} - -module ST : -sig - type t - val empty : unit -> t - val enter : int -> int * int -> t -> unit - val query : int * int -> t -> int - val delete : int -> t -> unit - val delete_list : int list -> t -> unit -end - -module UF : -sig - type t - exception Discriminable of int * int * int * int * t - val empty : unit -> t - val find : t -> int -> int - val size : t -> int -> int - val get_constructor : t -> int -> Names.constructor - val pac_arity : t -> int -> int * int -> int - val mem_node_pac : t -> int -> int * int -> int - val add_pacs : t -> int -> pa_constructor PacMap.t -> - int list * equality list - val term : t -> int -> term - val subterms : t -> int -> int * int - val add : t -> term -> int - val union : t -> int -> int -> equality -> int list * equality list - val join_path : t -> int -> int -> - ((int*int)*equality) list* - ((int*int)*equality) list -end - - -val combine_rec : UF.t -> int list -> equality list -val process_rec : UF.t -> equality list -> int list - -val cc : UF.t -> unit - -val make_uf : - (Names.Id.t * (term * term)) list -> UF.t - -val add_one_diseq : UF.t -> (term * term) -> int * int - -val add_disaxioms : - UF.t -> (Names.Id.t * (term * term)) list -> - (Names.Id.t * (int * int)) list - -val check_equal : UF.t -> int * int -> bool - -val find_contradiction : UF.t -> - (Names.Id.t * (int * int)) list -> - (Names.Id.t * (int * int)) -*) diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index b2ee0f9370..7d87fc0220 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -92,18 +92,14 @@ let list_union_eq eq_fun l1 l2 = let list_add_set_eq eq_fun x l = if List.exists (eq_fun x) l then l else x::l -[@@@ocaml.warning "-3"] -let coq_constant s = - UnivGen.constr_of_monomorphic_global @@ - Coqlib.gen_reference_in_modules "RecursiveDefinition" - Coqlib.init_modules s;; +let coq_constant s = UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref s;; let find_reference sl s = let dp = Names.DirPath.make (List.rev_map Id.of_string sl) in Nametab.locate (make_qualid dp (Id.of_string s)) -let eq = lazy(EConstr.of_constr (coq_constant "eq")) -let refl_equal = lazy(EConstr.of_constr (coq_constant "eq_refl")) +let eq = lazy(EConstr.of_constr (coq_constant "core.eq.type")) +let refl_equal = lazy(EConstr.of_constr (coq_constant "core.eq.refl")) let with_full_print f a = let old_implicit_args = Impargs.is_implicit_args () @@ -369,10 +365,10 @@ let do_observe_tac s tac g = ignore(Stack.pop debug_queue); v with reraise -> - let reraise = CErrors.push reraise in + let reraise = Exninfo.capture reraise in if not (Stack.is_empty debug_queue) then print_debug_queue true (fst reraise); - Util.iraise reraise + Exninfo.iraise reraise let observe_tac s tac g = if do_observe () @@ -447,14 +443,11 @@ let h_intros l = let h_id = Id.of_string "h" let hrec_id = Id.of_string "hrec" -let well_founded = function () -> EConstr.of_constr (coq_constant "well_founded") -let acc_rel = function () -> EConstr.of_constr (coq_constant "Acc") -let acc_inv_id = function () -> EConstr.of_constr (coq_constant "Acc_inv") +let well_founded = function () -> EConstr.of_constr (coq_constant "core.wf.well_founded") +let acc_rel = function () -> EConstr.of_constr (coq_constant "core.wf.acc") +let acc_inv_id = function () -> EConstr.of_constr (coq_constant "core.wf.acc_inv") -[@@@ocaml.warning "-3"] -let well_founded_ltof () = EConstr.of_constr @@ UnivGen.constr_of_monomorphic_global @@ - Coqlib.find_reference "IndFun" ["Coq"; "Arith";"Wf_nat"] "well_founded_ltof" -[@@@ocaml.warning "+3"] +let well_founded_ltof () = EConstr.of_constr (coq_constant "num.nat.well_founded_ltof") let ltof_ref = function () -> (find_reference ["Coq";"Arith";"Wf_nat"] "ltof") @@ -520,7 +513,7 @@ let funind_purify f x = let st = Vernacstate.freeze_interp_state ~marshallable:false in try f x with e -> - let e = CErrors.push e in + let e = Exninfo.capture e in Vernacstate.unfreeze_interp_state st; Exninfo.iraise e diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index f7f8004998..9fa0ec8c08 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -47,18 +47,12 @@ open Context.Rel.Declaration (* Ugly things which should not be here *) -[@@@ocaml.warning "-3"] -let coq_constant m s = EConstr.of_constr @@ UnivGen.constr_of_monomorphic_global @@ - Coqlib.find_reference "RecursiveDefinition" m s - -let arith_Nat = ["Coq"; "Arith";"PeanoNat";"Nat"] -let arith_Lt = ["Coq"; "Arith";"Lt"] +let coq_constant s = EConstr.of_constr @@ UnivGen.constr_of_monomorphic_global @@ + Coqlib.lib_ref s let coq_init_constant s = - EConstr.of_constr ( - UnivGen.constr_of_monomorphic_global @@ - Coqlib.gen_reference_in_modules "RecursiveDefinition" Coqlib.init_modules s) -[@@@ocaml.warning "+3"] + EConstr.of_constr(UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref s) +;; let find_reference sl s = let dp = Names.DirPath.make (List.rev_map Id.of_string sl) in @@ -122,26 +116,26 @@ let v_id = Id.of_string "v" let def_id = Id.of_string "def" let p_id = Id.of_string "p" let rec_res_id = Id.of_string "rec_res";; -let lt = function () -> (coq_init_constant "lt") -[@@@ocaml.warning "-3"] -let le = function () -> (Coqlib.gen_reference_in_modules "RecursiveDefinition" Coqlib.init_modules "le") -let ex = function () -> (coq_init_constant "ex") -let nat = function () -> (coq_init_constant "nat") +let lt = function () -> (coq_init_constant "num.nat.lt") +let le = function () -> Coqlib.lib_ref "num.nat.le" + +let ex = function () -> (coq_init_constant "core.ex.type") +let nat = function () -> (coq_init_constant "num.nat.type") let iter_ref () = try find_reference ["Recdef"] "iter" with Not_found -> user_err Pp.(str "module Recdef not loaded") let iter_rd = function () -> (constr_of_monomorphic_global (delayed_force iter_ref)) -let eq = function () -> (coq_init_constant "eq") +let eq = function () -> (coq_init_constant "core.eq.type") let le_lt_SS = function () -> (constant ["Recdef"] "le_lt_SS") -let le_lt_n_Sm = function () -> (coq_constant arith_Lt "le_lt_n_Sm") -let le_trans = function () -> (coq_constant arith_Nat "le_trans") -let le_lt_trans = function () -> (coq_constant arith_Nat "le_lt_trans") -let lt_S_n = function () -> (coq_constant arith_Lt "lt_S_n") -let le_n = function () -> (coq_init_constant "le_n") +let le_lt_n_Sm = function () -> (coq_constant "num.nat.le_lt_n_Sm") +let le_trans = function () -> (coq_constant "num.nat.le_trans") +let le_lt_trans = function () -> (coq_constant "num.nat.le_lt_trans") +let lt_S_n = function () -> (coq_constant "num.nat.lt_S_n") +let le_n = function () -> (coq_init_constant "num.nat.le_n") let coq_sig_ref = function () -> (find_reference ["Coq";"Init";"Specif"] "sig") -let coq_O = function () -> (coq_init_constant "O") -let coq_S = function () -> (coq_init_constant "S") -let lt_n_O = function () -> (coq_constant arith_Nat "nlt_0_r") +let coq_O = function () -> (coq_init_constant "num.nat.O") +let coq_S = function () -> (coq_init_constant"num.nat.S") +let lt_n_O = function () -> (coq_constant "num.nat.nlt_0_r") let max_ref = function () -> (find_reference ["Recdef"] "max") let max_constr = function () -> EConstr.of_constr (constr_of_monomorphic_global (delayed_force max_ref)) @@ -817,7 +811,7 @@ let rec prove_le g = | App (c, [| x0 ; _ |]) -> EConstr.isVar sigma x0 && Id.equal (destVar sigma x0) (destVar sigma x) && - EConstr.is_global sigma (le ()) c + EConstr.isRefX sigma (le ()) c | _ -> false in let (h,t) = List.find (fun (_,t) -> matching_fun t) (pf_hyps_types g) in @@ -1194,7 +1188,7 @@ let get_current_subgoals_types pstate = exception EmptySubgoals let build_and_l sigma l = let and_constr = UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.and.type" in - let conj_constr = Coqlib.build_coq_conj () in + let conj_constr = Coqlib.lib_ref "core.and.conj" in let mk_and p1 p2 = mkApp(EConstr.of_constr and_constr,[|p1;p2|]) in let rec is_well_founded t = diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index 513f5ca77b..d0c94e7903 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -670,7 +670,7 @@ let hResolve id c occ t = Pretyping.understand env sigma t_hole with | Pretype_errors.PretypeError (_,_,Pretype_errors.UnsolvableImplicit _) as e -> - let (e, info) = CErrors.push e in + let (e, info) = Exninfo.capture e in let loc_begin = Option.cata (fun l -> fst (Loc.unloc l)) 0 (Loc.get_loc info) in resolve_hole (subst_hole_with_term loc_begin c_raw t_hole) in diff --git a/plugins/ltac/g_auto.mlg b/plugins/ltac/g_auto.mlg index 8344f9dae3..82c64a9857 100644 --- a/plugins/ltac/g_auto.mlg +++ b/plugins/ltac/g_auto.mlg @@ -114,7 +114,7 @@ END (** Eauto *) -TACTIC EXTEND prolog +TACTIC EXTEND prolog DEPRECATED { Deprecation.make ~note:"Use eauto instead" () } | [ "prolog" "[" uconstr_list(l) "]" int_or_var(n) ] -> { Eauto.prolog_tac (eval_uconstrs ist l) n } END @@ -253,4 +253,3 @@ VERNAC COMMAND EXTEND HintCut CLASSIFIED AS SIDEFF (match dbnames with None -> ["core"] | Some l -> l) entry; } END - diff --git a/plugins/ltac/g_tactic.mlg b/plugins/ltac/g_tactic.mlg index 3e4c7ba782..8e1e5559af 100644 --- a/plugins/ltac/g_tactic.mlg +++ b/plugins/ltac/g_tactic.mlg @@ -589,6 +589,16 @@ GRAMMAR EXTEND Gram { TacAtom (CAst.make ~loc @@ TacAssert (false,true,Some tac,ipat,c)) } | IDENT "eassert"; c = constr; ipat = as_ipat; tac = by_tactic -> { TacAtom (CAst.make ~loc @@ TacAssert (true,true,Some tac,ipat,c)) } + + (* Alternative syntax for "pose proof c as id by tac" *) + | IDENT "pose"; IDENT "proof"; test_lpar_id_coloneq; "("; lid = identref; ":="; + c = lconstr; ")" -> + { let { CAst.loc = loc; v = id } = lid in + TacAtom (CAst.make ?loc @@ TacAssert (false,true,None,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } + | IDENT "epose"; IDENT "proof"; test_lpar_id_coloneq; "("; lid = identref; ":="; + c = lconstr; ")" -> + { let { CAst.loc = loc; v = id } = lid in + TacAtom (CAst.make ?loc @@ TacAssert (true,true,None,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) } | IDENT "pose"; IDENT "proof"; c = lconstr; ipat = as_ipat -> { TacAtom (CAst.make ~loc @@ TacAssert (false,true,None,ipat,c)) } | IDENT "epose"; IDENT "proof"; c = lconstr; ipat = as_ipat -> diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 6e620b71db..1d7fe335d1 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -165,8 +165,8 @@ let catching_error call_trace fail (e, info) = let catch_error call_trace f x = try f x with e when CErrors.noncritical e -> - let e = CErrors.push e in - catching_error call_trace iraise e + let e = Exninfo.capture e in + catching_error call_trace Exninfo.iraise e let wrap_error tac k = if is_traced () then Proofview.tclORELSE tac k else tac @@ -717,13 +717,13 @@ let interp_may_eval f ist env sigma = function try f ist env sigma c with reraise -> - let reraise = CErrors.push reraise in + let reraise = Exninfo.capture reraise in (* spiwack: to avoid unnecessary modifications of tacinterp, as this function already use effect, I call [run] hoping it doesn't mess up with any assumption. *) Proofview.NonLogical.run (debugging_exception_step ist false (fst reraise) (fun () -> str"interpretation of term " ++ pr_glob_constr_env env (fst c))); - iraise reraise + Exninfo.iraise reraise (* Interprets a constr expression possibly to first evaluate *) let interp_constr_may_eval ist env sigma c = @@ -731,12 +731,12 @@ let interp_constr_may_eval ist env sigma c = try interp_may_eval interp_constr ist env sigma c with reraise -> - let reraise = CErrors.push reraise in + let reraise = Exninfo.capture reraise in (* spiwack: to avoid unnecessary modifications of tacinterp, as this function already use effect, I call [run] hoping it doesn't mess up with any assumption. *) Proofview.NonLogical.run (debugging_exception_step ist false (fst reraise) (fun () -> str"evaluation of term")); - iraise reraise + Exninfo.iraise reraise in begin (* spiwack: to avoid unnecessary modifications of tacinterp, as this diff --git a/plugins/ltac/tactic_debug.ml b/plugins/ltac/tactic_debug.ml index 392f9b2ffd..3512bb936d 100644 --- a/plugins/ltac/tactic_debug.ml +++ b/plugins/ltac/tactic_debug.ml @@ -418,7 +418,7 @@ let extract_ltac_trace ?loc trace = (* We entered a user-defined tactic, we display the trace with location of the call *) let msg = hov 0 (explain_ltac_call_trace c tail loc ++ fnl()) in - (if Loc.finer loc tloc then loc else tloc), Some msg + (if Loc.finer loc tloc then loc else tloc), msg else (* We entered a primitive tactic, we don't display trace but report on the finest location *) @@ -434,7 +434,7 @@ let extract_ltac_trace ?loc trace = aux best_loc tail | [] -> best_loc in aux loc trace in - best_loc, None + best_loc, mt () let get_ltac_trace info = let ltac_trace = Exninfo.get info ltac_trace_info in diff --git a/plugins/ltac/tactic_debug.mli b/plugins/ltac/tactic_debug.mli index e0126ad448..c76851a14c 100644 --- a/plugins/ltac/tactic_debug.mli +++ b/plugins/ltac/tactic_debug.mli @@ -79,4 +79,4 @@ val db_breakpoint : debug_info -> lident message_token list -> unit Proofview.NonLogical.t val extract_ltac_trace : - ?loc:Loc.t -> Tacexpr.ltac_trace -> Pp.t option Loc.located + ?loc:Loc.t -> Tacexpr.ltac_trace -> Pp.t Loc.located diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index 61234145e1..c788c7f147 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -19,12 +19,13 @@ let debug = false -open Big_int -open Num open Polynomial module Mc = Micromega module Ml2C = Mutils.CamlToCoq module C2Ml = Mutils.CoqToCaml +open NumCompat +open Q.Notations +open Mutils let use_simplex = ref true @@ -32,11 +33,9 @@ type ('prf, 'model) res = Prf of 'prf | Model of 'model | Unknown type zres = (Mc.zArithProof, int * Mc.z list) res type qres = (Mc.q Mc.psatz, int * Mc.q list) res -open Mutils - type 'a number_spec = - { bigint_to_number : big_int -> 'a - ; number_to_num : 'a -> num + { bigint_to_number : Z.t -> 'a + ; number_to_num : 'a -> Q.t ; zero : 'a ; unit : 'a ; mult : 'a -> 'a -> 'a @@ -44,7 +43,7 @@ type 'a number_spec = let z_spec = { bigint_to_number = Ml2C.bigint - ; number_to_num = (fun x -> Big_int (C2Ml.z_big_int x)) + ; number_to_num = (fun x -> Q.of_bigint (C2Ml.z_big_int x)) ; zero = Mc.Z0 ; unit = Mc.Zpos Mc.XH ; mult = Mc.Z.mul @@ -124,17 +123,16 @@ let constrain_variable v l = let coeffs = List.fold_left (fun acc p -> Vect.get v p.coeffs :: acc) [] l in { coeffs = Vect.from_list - (Big_int zero_big_int :: Big_int zero_big_int :: List.rev coeffs) + (Q.of_bigint Z.zero :: Q.of_bigint Z.zero :: List.rev coeffs) ; op = Eq - ; cst = Big_int zero_big_int } + ; cst = Q.of_bigint Z.zero } let constrain_constant l = - let coeffs = List.fold_left (fun acc p -> minus_num p.cst :: acc) [] l in + let coeffs = List.fold_left (fun acc p -> Q.neg p.cst :: acc) [] l in { coeffs = - Vect.from_list - (Big_int zero_big_int :: Big_int unit_big_int :: List.rev coeffs) + Vect.from_list (Q.of_bigint Z.zero :: Q.of_bigint Z.one :: List.rev coeffs) ; op = Eq - ; cst = Big_int zero_big_int } + ; cst = Q.of_bigint Z.zero } let positivity l = let rec xpositivity i l = @@ -144,16 +142,16 @@ let positivity l = match c.op with | Eq -> xpositivity (i + 1) l | _ -> - { coeffs = Vect.update (i + 1) (fun _ -> Int 1) Vect.null + { coeffs = Vect.update (i + 1) (fun _ -> Q.one) Vect.null ; op = Ge - ; cst = Int 0 } + ; cst = Q.zero } :: xpositivity (i + 1) l ) in xpositivity 1 l let cstr_of_poly (p, o) = let c, l = Vect.decomp_cst p in - {coeffs = l; op = o; cst = minus_num c} + {coeffs = l; op = o; cst = Q.neg c} let variables_of_cstr c = Vect.variables c.coeffs @@ -175,25 +173,23 @@ let build_dual_linear_system l = let strict = { coeffs = Vect.from_list - ( Big_int zero_big_int :: Big_int unit_big_int + ( Q.of_bigint Z.zero :: Q.of_bigint Z.one :: List.map (fun c -> - if is_strict c then Big_int unit_big_int - else Big_int zero_big_int) + if is_strict c then Q.of_bigint Z.one else Q.of_bigint Z.zero) l ) ; op = Ge - ; cst = Big_int unit_big_int } + ; cst = Q.of_bigint Z.one } in (* Add the positivity constraint *) - { coeffs = Vect.from_list [Big_int zero_big_int; Big_int unit_big_int] + { coeffs = Vect.from_list [Q.of_bigint Z.zero; Q.of_bigint Z.one] ; op = Ge - ; cst = Big_int zero_big_int } + ; cst = Q.of_bigint Z.zero } :: ((strict :: positivity l) @ (c :: s0)) -open Util - (** [direct_linear_prover l] does not handle strict inegalities *) let fourier_linear_prover l = + let open Util in match Mfourier.Fourier.find_point l with | Inr prf -> if debug then Printf.printf "AProof : %a\n" Mfourier.pp_proof prf; @@ -211,6 +207,7 @@ let direct_linear_prover l = else fourier_linear_prover l let find_point l = + let open Util in if !use_simplex then Simplex.find_point l else match Mfourier.Fourier.find_point l with @@ -237,8 +234,8 @@ let dual_raw_certificate l = match Vect.choose cert with | None -> failwith "dual_raw_certificate: empty_certificate" | Some _ -> - (*Some (rats_to_ints (Vect.to_list (Vect.decr_var 2 (Vect.set 1 (Int 0) cert))))*) - Some (Vect.normalise (Vect.decr_var 2 (Vect.set 1 (Int 0) cert))) ) + (*Some (rats_to_ints (Vect.to_list (Vect.decr_var 2 (Vect.set 1 Q.zero cert))))*) + Some (Vect.normalise (Vect.decr_var 2 (Vect.set 1 Q.zero cert))) ) (* should not use rats_to_ints *) with x when CErrors.noncritical x -> if debug then ( @@ -306,14 +303,14 @@ exception FoundProof of ProofFormat.prf_rule let check_int_sat (cstr, prf) = let {coeffs; op; cst} = cstr in match Vect.choose coeffs with - | None -> if eval_op op (Int 0) cst then Tauto else Unsat prf + | None -> if eval_op op Q.zero cst then Tauto else Unsat prf | _ -> ( let gcdi = Vect.gcd coeffs in - let gcd = Big_int gcdi in - if eq_num gcd (Int 1) then Normalise (cstr, prf) - else if Int.equal (sign_num (mod_num cst gcd)) 0 then begin + let gcd = Q.of_bigint gcdi in + if gcd =/ Q.one then Normalise (cstr, prf) + else if Int.equal (Q.sign (Q.mod_ cst gcd)) 0 then begin (* We can really normalise *) - assert (sign_num gcd >= 1); + assert (Q.sign gcd >= 1); let cstr = {coeffs = Vect.div gcd coeffs; op; cst = cst // gcd} in Normalise (cstr, ProofFormat.Gcd (gcdi, prf)) (* Normalise(cstr,CutPrf prf)*) @@ -323,7 +320,7 @@ let check_int_sat (cstr, prf) = | Eq -> Unsat (ProofFormat.CutPrf prf) | Ge -> let cstr = - {coeffs = Vect.div gcd coeffs; op; cst = ceiling_num (cst // gcd)} + {coeffs = Vect.div gcd coeffs; op; cst = Q.ceiling (cst // gcd)} in Cut (cstr, ProofFormat.CutPrf prf) | Gt -> failwith "check_sat : Unexpected operator" ) @@ -351,7 +348,7 @@ let is_linear_for v pc = *) let is_linear_substitution sys ((p, o), prf) = - let pred v = v =/ Int 1 || v =/ Int (-1) in + let pred v = v =/ Q.one || v =/ Q.neg_one in match o with | Eq -> ( match @@ -413,8 +410,14 @@ let bound_monomials (sys : WithProof.t list) = (fun acc ((p, o), _) -> ISet.union (LinPoly.monomials p) acc) ISet.empty sys in + let module SetWP = Set.Make (struct + type t = int * WithProof.t + + let compare (_, x) (_, y) = WithProof.compare x y + end) in let bounds = saturate_bin + (module SetWP : Set.S with type elt = int * WithProof.t) (fun (i1, w1) (i2, w2) -> if i1 + i2 > deg then None else @@ -515,28 +518,31 @@ open Sos_types let rec scale_term t = match t with - | Zero -> (unit_big_int, Zero) - | Const n -> (denominator n, Const (Big_int (numerator n))) - | Var n -> (unit_big_int, Var n) + | Zero -> (Z.one, Zero) + | Const n -> (Q.den n, Const (Q.of_bigint (Q.num n))) + | Var n -> (Z.one, Var n) | Opp t -> let s, t = scale_term t in (s, Opp t) | Add (t1, t2) -> let s1, y1 = scale_term t1 and s2, y2 = scale_term t2 in - let g = gcd_big_int s1 s2 in - let s1' = div_big_int s1 g in - let s2' = div_big_int s2 g in - let e = mult_big_int g (mult_big_int s1' s2') in - if Int.equal (compare_big_int e unit_big_int) 0 then - (unit_big_int, Add (y1, y2)) - else (e, Add (Mul (Const (Big_int s2'), y1), Mul (Const (Big_int s1'), y2))) + let g = Z.gcd s1 s2 in + let s1' = Z.div s1 g in + let s2' = Z.div s2 g in + let e = Z.mul g (Z.mul s1' s2') in + if Int.equal (Z.compare e Z.one) 0 then (Z.one, Add (y1, y2)) + else + ( e + , Add + (Mul (Const (Q.of_bigint s2'), y1), Mul (Const (Q.of_bigint s1'), y2)) + ) | Sub _ -> failwith "scale term: not implemented" | Mul (y, z) -> let s1, y1 = scale_term y and s2, y2 = scale_term z in - (mult_big_int s1 s2, Mul (y1, y2)) + (Z.mul s1 s2, Mul (y1, y2)) | Pow (t, n) -> let s, t = scale_term t in - (power_big_int_positive_int s n, Pow (t, n)) + (Z.power_int s n, Pow (t, n)) let scale_term t = let s, t' = scale_term t in @@ -544,37 +550,38 @@ let scale_term t = let rec scale_certificate pos = match pos with - | Axiom_eq i -> (unit_big_int, Axiom_eq i) - | Axiom_le i -> (unit_big_int, Axiom_le i) - | Axiom_lt i -> (unit_big_int, Axiom_lt i) - | Monoid l -> (unit_big_int, Monoid l) - | Rational_eq n -> (denominator n, Rational_eq (Big_int (numerator n))) - | Rational_le n -> (denominator n, Rational_le (Big_int (numerator n))) - | Rational_lt n -> (denominator n, Rational_lt (Big_int (numerator n))) + | Axiom_eq i -> (Z.one, Axiom_eq i) + | Axiom_le i -> (Z.one, Axiom_le i) + | Axiom_lt i -> (Z.one, Axiom_lt i) + | Monoid l -> (Z.one, Monoid l) + | Rational_eq n -> (Q.den n, Rational_eq (Q.of_bigint (Q.num n))) + | Rational_le n -> (Q.den n, Rational_le (Q.of_bigint (Q.num n))) + | Rational_lt n -> (Q.den n, Rational_lt (Q.of_bigint (Q.num n))) | Square t -> let s, t' = scale_term t in - (mult_big_int s s, Square t') + (Z.mul s s, Square t') | Eqmul (t, y) -> let s1, y1 = scale_term t and s2, y2 = scale_certificate y in - (mult_big_int s1 s2, Eqmul (y1, y2)) + (Z.mul s1 s2, Eqmul (y1, y2)) | Sum (y, z) -> let s1, y1 = scale_certificate y and s2, y2 = scale_certificate z in - let g = gcd_big_int s1 s2 in - let s1' = div_big_int s1 g in - let s2' = div_big_int s2 g in - ( mult_big_int g (mult_big_int s1' s2') + let g = Z.gcd s1 s2 in + let s1' = Z.div s1 g in + let s2' = Z.div s2 g in + ( Z.mul g (Z.mul s1' s2') , Sum - ( Product (Rational_le (Big_int s2'), y1) - , Product (Rational_le (Big_int s1'), y2) ) ) + ( Product (Rational_le (Q.of_bigint s2'), y1) + , Product (Rational_le (Q.of_bigint s1'), y2) ) ) | Product (y, z) -> let s1, y1 = scale_certificate y and s2, y2 = scale_certificate z in - (mult_big_int s1 s2, Product (y1, y2)) + (Z.mul s1 s2, Product (y1, y2)) +module Z_ = Z open Micromega let rec term_to_q_expr = function | Const n -> PEc (Ml2C.q n) - | Zero -> PEc (Ml2C.q (Int 0)) + | Zero -> PEc (Ml2C.q Q.zero) | Var s -> PEX (Ml2C.index (int_of_string (String.sub s 1 (String.length s - 1)))) | Mul (p1, p2) -> PEmul (term_to_q_expr p1, term_to_q_expr p2) @@ -584,8 +591,8 @@ let rec term_to_q_expr = function | Sub (t1, t2) -> PEsub (term_to_q_expr t1, term_to_q_expr t2) let term_to_q_pol e = - Mc.norm_aux (Ml2C.q (Int 0)) (Ml2C.q (Int 1)) Mc.qplus Mc.qmult Mc.qminus - Mc.qopp Mc.qeq_bool (term_to_q_expr e) + Mc.norm_aux (Ml2C.q Q.zero) (Ml2C.q Q.one) Mc.qplus Mc.qmult Mc.qminus Mc.qopp + Mc.qeq_bool (term_to_q_expr e) let rec product l = match l with @@ -600,7 +607,7 @@ let q_cert_of_pos pos = | Axiom_lt i -> Mc.PsatzIn (Ml2C.nat i) | Monoid l -> product l | Rational_eq n | Rational_le n | Rational_lt n -> - if Int.equal (compare_num n (Int 0)) 0 then Mc.PsatzZ + if Int.equal (Q.compare n Q.zero) 0 then Mc.PsatzZ else Mc.PsatzC (Ml2C.q n) | Square t -> Mc.PsatzSquare (term_to_q_pol t) | Eqmul (t, y) -> Mc.PsatzMulC (term_to_q_pol t, _cert_of_pos y) @@ -610,7 +617,7 @@ let q_cert_of_pos pos = simplify_cone q_spec (_cert_of_pos pos) let rec term_to_z_expr = function - | Const n -> PEc (Ml2C.bigint (big_int_of_num n)) + | Const n -> PEc (Ml2C.bigint (Q.to_bigint n)) | Zero -> PEc Z0 | Var s -> PEX (Ml2C.index (int_of_string (String.sub s 1 (String.length s - 1)))) @@ -632,11 +639,11 @@ let z_cert_of_pos pos = | Axiom_lt i -> Mc.PsatzIn (Ml2C.nat i) | Monoid l -> product l | Rational_eq n | Rational_le n | Rational_lt n -> - if Int.equal (compare_num n (Int 0)) 0 then Mc.PsatzZ - else Mc.PsatzC (Ml2C.bigint (big_int_of_num n)) + if Int.equal (Q.compare n Q.zero) 0 then Mc.PsatzZ + else Mc.PsatzC (Ml2C.bigint (Q.to_bigint n)) | Square t -> Mc.PsatzSquare (term_to_z_pol t) | Eqmul (t, y) -> - let is_unit = match t with Const n -> n =/ Int 1 | _ -> false in + let is_unit = match t with Const n -> n =/ Q.one | _ -> false in if is_unit then _cert_of_pos y else Mc.PsatzMulC (term_to_z_pol t, _cert_of_pos y) | Sum (y, z) -> Mc.PsatzAdd (_cert_of_pos y, _cert_of_pos z) @@ -649,8 +656,6 @@ open Mutils Given a constraint, all the coefficients are always integers. *) -open Num -open Big_int open Polynomial type prf_sys = (cstr * ProofFormat.prf_rule) list @@ -668,19 +673,18 @@ let pivot v (c1, p1) (c2, p2) = (ProofFormat.mul_cst_proof cv1 p1) (ProofFormat.mul_cst_proof cv2 p2) ) in - match (Vect.get v v1, Vect.get v v2) with - | Int 0, _ | _, Int 0 -> None - | a, b -> - if Int.equal (sign_num a * sign_num b) (-1) then - let cv1 = abs_num b and cv2 = abs_num a in - Some (xpivot cv1 cv2) - else if op1 == Eq then - let cv1 = minus_num (b */ Int (sign_num a)) and cv2 = abs_num a in - Some (xpivot cv1 cv2) - else if op2 == Eq then - let cv1 = abs_num b and cv2 = minus_num (a */ Int (sign_num b)) in - Some (xpivot cv1 cv2) - else None + let a, b = (Vect.get v v1, Vect.get v v2) in + if a =/ Q.zero || b =/ Q.zero then None + else if Int.equal (Q.sign a * Q.sign b) (-1) then + let cv1 = Q.abs b and cv2 = Q.abs a in + Some (xpivot cv1 cv2) + else if op1 == Eq then + let cv1 = Q.neg (b */ Q.of_int (Q.sign a)) and cv2 = Q.abs a in + Some (xpivot cv1 cv2) + else if op2 == Eq then + let cv1 = Q.abs b and cv2 = Q.neg (a */ Q.of_int (Q.sign b)) in + Some (xpivot cv1 cv2) + else None (* op2 could be Eq ... this might happen *) @@ -699,21 +703,17 @@ let simpl_sys sys = Source: http://en.wikipedia.org/wiki/Extended_Euclidean_algorithm *) let rec ext_gcd a b = - if Int.equal (sign_big_int b) 0 then (unit_big_int, zero_big_int) + if Int.equal (Z_.sign b) 0 then (Z_.one, Z_.zero) else - let q, r = quomod_big_int a b in + let q, r = Z_.quomod a b in let s, t = ext_gcd b r in - (t, sub_big_int s (mult_big_int q t)) + (t, Z_.sub s (Z_.mul q t)) let extract_coprime (c1, p1) (c2, p2) = if c1.op == Eq && c2.op == Eq then Vect.exists2 (fun n1 n2 -> - Int.equal - (compare_big_int - (gcd_big_int (numerator n1) (numerator n2)) - unit_big_int) - 0) + Int.equal (Z_.compare (Z_.gcd (Q.num n1) (Q.num n2)) Z_.one) 0) c1.coeffs c2.coeffs else None @@ -736,8 +736,8 @@ let reduce_coprime psys = match oeq with | None -> None (* Nothing to do *) | Some ((v, n1, n2), (c1, p1), (c2, p2)) -> - let l1, l2 = ext_gcd (numerator n1) (numerator n2) in - let l1' = Big_int l1 and l2' = Big_int l2 in + let l1, l2 = ext_gcd (Q.num n1) (Q.num n2) in + let l1' = Q.of_bigint l1 and l2' = Q.of_bigint l2 in let cstr = { coeffs = Vect.add (Vect.mul l1' c1.coeffs) (Vect.mul l2' c2.coeffs) ; op = Eq @@ -755,7 +755,7 @@ let reduce_unary psys = let is_unary_equation (cstr, prf) = if cstr.op == Eq then Vect.find - (fun v n -> if n =/ Int 1 || n =/ Int (-1) then Some v else None) + (fun v n -> if n =/ Q.one || n =/ Q.neg_one then Some v else None) cstr.coeffs else None in @@ -769,13 +769,12 @@ let reduce_var_change psys = match Vect.choose vect with | None -> None | Some (x, v, vect) -> ( - let v = numerator v in + let v = Q.num v in match Vect.find (fun x' v' -> - let v' = numerator v' in - if eq_big_int (gcd_big_int v v') unit_big_int then Some (x', v') - else None) + let v' = Q.num v' in + if Z_.equal (Z_.gcd v v') Z_.one then Some (x', v') else None) vect with | Some (x', v') -> Some ((x, v), (x', v')) @@ -789,12 +788,12 @@ let reduce_var_change psys = | None -> None | Some (((x, v), (x', v')), (c, p)) -> let l1, l2 = ext_gcd v v' in - let l1, l2 = (Big_int l1, Big_int l2) in + let l1, l2 = (Q.of_bigint l1, Q.of_bigint l2) in let pivot_eq (c', p') = let {coeffs; op; cst} = c' in let vx = Vect.get x coeffs in let vx' = Vect.get x' coeffs in - let m = minus_num ((vx */ l1) +/ (vx' */ l2)) in + let m = Q.neg ((vx */ l1) +/ (vx' */ l2)) in Some ( { coeffs = Vect.add (Vect.mul m c.coeffs) coeffs ; op @@ -812,7 +811,7 @@ let reduction_equations psys = (** [get_bound sys] returns upon success an interval (lb,e,ub) with proofs *) let get_bound sys = let is_small (v, i) = - match Itv.range i with None -> false | Some i -> i <=/ Int 1 + match Itv.range i with None -> false | Some i -> i <=/ Q.one in let select_best (x1, i1) (x2, i2) = if Itv.smaller_itv i1 i2 then (x1, i1) else (x2, i2) @@ -852,18 +851,20 @@ let get_bound sys = in match smallest_interval with | Some (lb, e, ub) -> ( - let lbn, lbd = (sub_big_int (numerator lb) unit_big_int, denominator lb) in - let ubn, ubd = (add_big_int unit_big_int (numerator ub), denominator ub) in + let lbn, lbd = (Z_.sub (Q.num lb) Z_.one, Q.den lb) in + let ubn, ubd = (Z_.add Z_.one (Q.num ub), Q.den ub) in (* x <= ub -> x > ub *) match ( direct_linear_prover - ( {coeffs = Vect.mul (Big_int ubd) e; op = Ge; cst = Big_int ubn} + ( { coeffs = Vect.mul (Q.of_bigint ubd) e + ; op = Ge + ; cst = Q.of_bigint ubn } :: sys ) , (* lb <= x -> lb > x *) direct_linear_prover - ( { coeffs = Vect.mul (minus_num (Big_int lbd)) e + ( { coeffs = Vect.mul (Q.neg (Q.of_bigint lbd)) e ; op = Ge - ; cst = minus_num (Big_int lbn) } + ; cst = Q.neg (Q.of_bigint lbn) } :: sys ) ) with | Some cub, Some clb -> @@ -873,7 +874,7 @@ let get_bound sys = let check_sys sys = List.for_all - (fun (c, p) -> Vect.for_all (fun _ n -> sign_num n <> 0) c.coeffs) + (fun (c, p) -> Vect.for_all (fun _ n -> Q.sign n <> 0) c.coeffs) sys open ProofFormat @@ -890,8 +891,8 @@ let xlia (can_enum : bool) reduction_equations sys = | Some (prf1, (lb, e, ub), prf2) -> ( if debug then Printf.printf "Found interval: %a in [%s;%s] -> " Vect.pp e - (string_of_num lb) (string_of_num ub); - match start_enum id e (ceiling_num lb) (floor_num ub) sys with + (Q.to_string lb) (Q.to_string ub); + match start_enum id e (Q.ceiling lb) (Q.floor ub) sys with | Prf prfl -> Prf (ProofFormat.Enum @@ -910,7 +911,7 @@ let xlia (can_enum : bool) reduction_equations sys = match aux_lia (id + 1) ((eq, ProofFormat.Def id) :: sys) with | Unknown | Model _ -> Unknown | Prf prf -> ( - match start_enum id e (clb +/ Int 1) cub sys with + match start_enum id e (clb +/ Q.one) cub sys with | Prf l -> Prf (prf :: l) | _ -> Unknown ) and aux_lia (id : int) (sys : prf_sys) = @@ -958,7 +959,7 @@ let xlia (can_enum : bool) reduction_equations sys = if Mc.zChecker sys' prf then Some prf else raise Certificate.BadCertificate with Failure s -> (Printf.printf "%s" s ; Some prf) - *) + *) Prf prf let xlia_simplex env red sys = diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 4b656f8e61..c3f59b4208 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -518,7 +518,7 @@ module M = struct | Mc.Zneg p -> EConstr.mkApp (Lazy.force coq_NEG, [|dump_positive p|]) let pp_z o x = - Printf.fprintf o "%s" (Big_int.string_of_big_int (CoqToCaml.z_big_int x)) + Printf.fprintf o "%s" (NumCompat.Z.to_string (CoqToCaml.z_big_int x)) let dump_q q = EConstr.mkApp @@ -636,14 +636,14 @@ module M = struct in pp_pol o e - (* let pp_clause pp_c o (f: 'cst clause) = - List.iter (fun ((p,_),(t,_)) -> Printf.fprintf o "(%a @%a)" (pp_pol pp_c) p Tag.pp t) f *) + (* let pp_clause pp_c o (f: 'cst clause) = + List.iter (fun ((p,_),(t,_)) -> Printf.fprintf o "(%a @%a)" (pp_pol pp_c) p Tag.pp t) f *) let pp_clause_tag o (f : 'cst clause) = List.iter (fun ((p, _), (t, _)) -> Printf.fprintf o "(_ @%a)" Tag.pp t) f - (* let pp_cnf pp_c o (f:'cst cnf) = - List.iter (fun l -> Printf.fprintf o "[%a]" (pp_clause pp_c) l) f *) + (* let pp_cnf pp_c o (f:'cst cnf) = + List.iter (fun l -> Printf.fprintf o "[%a]" (pp_clause pp_c) l) f *) let pp_cnf_tag o (f : 'cst cnf) = List.iter (fun l -> Printf.fprintf o "[%a]" pp_clause_tag l) f @@ -819,16 +819,16 @@ module M = struct let elements env = env.vars - (* let string_of_env gl env = - let rec string_of_env i env acc = - match env with - | [] -> acc - | e::env -> string_of_env (i+1) env - (IMap.add i - (Pp.string_of_ppcmds - (Printer.pr_econstr_env gl.env gl.sigma e)) acc) in - string_of_env 1 env IMap.empty - *) + (* let string_of_env gl env = + let rec string_of_env i env acc = + match env with + | [] -> acc + | e::env -> string_of_env (i+1) env + (IMap.add i + (Pp.string_of_ppcmds + (Printer.pr_econstr_env gl.env gl.sigma e)) acc) in + string_of_env 1 env IMap.empty + *) let pp gl env = let ppl = List.mapi @@ -951,7 +951,7 @@ module M = struct (* NB: R is a different story. Because it is axiomatised, reducing would not be effective. Therefore, there is a specific parser for constant over R - *) + *) let rconst_assoc = [ (coq_Rplus, fun x y -> Mc.CPlus (x, y)) @@ -1613,14 +1613,14 @@ let compact_proofs (cnf_ff : 'cst cnf) res (cnf_ff' : 'cst cnf) = in List.assoc formula new_cl in - (* if debug then - begin - Printf.printf "\ncompact_proof : %a %a %a" - (pp_ml_list prover.pp_f) (List.map fst old_cl) - prover.pp_prf prf - (pp_ml_list prover.pp_f) (List.map fst new_cl) ; - flush stdout - end ; *) + (* if debug then + begin + Printf.printf "\ncompact_proof : %a %a %a" + (pp_ml_list prover.pp_f) (List.map fst old_cl) + prover.pp_prf prf + (pp_ml_list prover.pp_f) (List.map fst new_cl) ; + flush stdout + end ; *) let res = try prover.compact prf remap with x when CErrors.noncritical x -> ( @@ -1790,14 +1790,14 @@ let micromega_tauto pre_process cnf spec prover env flush stdout end; (* Even if it does not work, this does not mean it is not provable - -- the prover is REALLY incomplete *) + -- the prover is REALLY incomplete *) (* if debug then - begin - (* recompute the proofs *) - match witness_list_tags prover cnf_ff' with - | None -> failwith "abstraction is wrong" - | Some res -> () - end ; *) + begin + (* recompute the proofs *) + match witness_list_tags prover cnf_ff' with + | None -> failwith "abstraction is wrong" + | Some res -> () + end ; *) let res' = compact_proofs cnf_ff res cnf_ff' in let ff', res', ids = (ff', res', Mc.ids_of_formula ff') in let res' = dump_list spec.proof_typ spec.dump_proof res' in @@ -2009,7 +2009,7 @@ let micromega_genr prover tac = let goal_vars = List.map (fun (_, i) -> List.nth env (i - 1)) vars in let arith_args = goal_props @ goal_vars in let kill_arith = Tacticals.New.tclTHEN tac_arith tac in - (* Tacticals.New.tclTHEN + (* Tacticals.New.tclTHEN (Tactics.keep []) (Tactics.tclABSTRACT None*) Tacticals.New.tclTHENS diff --git a/plugins/micromega/csdpcert.ml b/plugins/micromega/csdpcert.ml index 90dd81adf4..a636fb0bdf 100644 --- a/plugins/micromega/csdpcert.ml +++ b/plugins/micromega/csdpcert.ml @@ -14,7 +14,7 @@ (* *) (************************************************************************) -open Num +open NumCompat open Sos open Sos_types open Sos_lib @@ -96,7 +96,7 @@ let real_nonlinear_prover d l = | Axiom_lt i -> poly_mul p y | Axiom_eq i -> poly_mul (poly_pow p 2) y | _ -> failwith "monoids") - m (poly_const (Int 1)) + m (poly_const Q.one) , List.map snd m )) (sets_of_list neq) in @@ -127,7 +127,7 @@ let real_nonlinear_prover d l = match List.map (function Axiom_eq i -> i | _ -> failwith "error") neq with - | [] -> Rational_lt (Int 1) + | [] -> Rational_lt Q.one | l -> Monoid l in List.fold_right (fun x y -> Product (x, y)) lt sq @@ -146,7 +146,7 @@ let real_nonlinear_prover d l = let pure_sos l = let l = List.map (fun (e, o) -> (Mc.denorm e, o)) l in (* If there is no strict inequality, - I should nonetheless be able to try something - over Z > is equivalent to -1 >= *) + 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 = @@ -162,11 +162,11 @@ let pure_sos l = , List.fold_right (fun (c, p) rst -> Sum (Product (Rational_lt c, Square (term_of_poly p)), rst)) - polys (Rational_lt (Int 0)) ) + polys (Rational_lt Q.zero) ) in let proof = Sum (Axiom_lt i, pos) in - (* let s,proof' = scale_certificate proof in - let cert = snd (cert_of_pos proof') in *) + (* let s,proof' = scale_certificate proof in + let cert = snd (cert_of_pos proof') in *) S (Some proof) with (* | Sos.CsdpNotFound -> F "Sos.CsdpNotFound" *) | any -> @@ -184,8 +184,8 @@ let main () = try let (prover, poly) = (input_value stdin : provername * micromega_polys) in let cert = run_prover prover poly in - (* Printf.fprintf chan "%a -> %a" print_list_term poly output_csdp_certificate cert ; - close_out chan ; *) + (* Printf.fprintf chan "%a -> %a" print_list_term poly output_csdp_certificate cert ; + close_out chan ; *) output_value stdout (cert : csdp_certificate); flush stdout; Marshal.to_channel chan (cert : csdp_certificate) []; diff --git a/plugins/micromega/g_zify.mlg b/plugins/micromega/g_zify.mlg index 2b5fac32a2..5e4a847e6b 100644 --- a/plugins/micromega/g_zify.mlg +++ b/plugins/micromega/g_zify.mlg @@ -25,7 +25,8 @@ VERNAC COMMAND EXTEND DECLAREINJECTION CLASSIFIED AS SIDEFF | ["Add" "UnOp" constr(t) ] -> { Zify.UnOp.register t } | ["Add" "CstOp" constr(t) ] -> { Zify.CstOp.register t } | ["Add" "BinRel" constr(t) ] -> { Zify.BinRel.register t } -| ["Add" "PropOp" constr(t) ] -> { Zify.PropOp.register t } +| ["Add" "PropOp" constr(t) ] -> { Zify.PropBinOp.register t } +| ["Add" "PropBinOp" constr(t) ] -> { Zify.PropBinOp.register t } | ["Add" "PropUOp" constr(t) ] -> { Zify.PropUnOp.register t } | ["Add" "Spec" constr(t) ] -> { Zify.Spec.register t } | ["Add" "BinOpSpec" constr(t) ] -> { Zify.Spec.register t } @@ -34,13 +35,14 @@ VERNAC COMMAND EXTEND DECLAREINJECTION CLASSIFIED AS SIDEFF END TACTIC EXTEND ITER -| [ "zify_iter_specs" tactic(t)] -> { Zify.iter_specs t } +| [ "zify_iter_specs"] -> { Zify.iter_specs} END TACTIC EXTEND TRANS | [ "zify_op" ] -> { Zify.zify_tac } | [ "zify_saturate" ] -> { Zify.saturate } | [ "zify_iter_let" tactic(t)] -> { Zify.iter_let t } +| [ "zify_elim_let" ] -> { Zify.elim_let } END VERNAC COMMAND EXTEND ZifyPrint CLASSIFIED AS SIDEFF diff --git a/plugins/micromega/itv.ml b/plugins/micromega/itv.ml index 214edb46ba..74a9657038 100644 --- a/plugins/micromega/itv.ml +++ b/plugins/micromega/itv.ml @@ -8,12 +8,13 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(** Intervals (extracted from mfourier.ml) *) +open NumCompat +open Q.Notations -open Num +(** Intervals (extracted from mfourier.ml) *) (** The type of intervals is *) -type interval = num option * num option +type interval = Q.t option * Q.t option (** None models the absence of bound i.e. infinity As a result, - None , None -> \]-oo,+oo\[ @@ -26,11 +27,11 @@ type interval = num option * num option let pp o (n1, n2) = ( match n1 with | None -> output_string o "]-oo" - | Some n -> Printf.fprintf o "[%s" (string_of_num n) ); + | Some n -> Printf.fprintf o "[%s" (Q.to_string n) ); output_string o ","; match n2 with | None -> output_string o "+oo[" - | Some n -> Printf.fprintf o "%s]" (string_of_num n) + | Some n -> Printf.fprintf o "%s]" (Q.to_string n) (** if then interval [itv] is empty, [norm_itv itv] returns [None] otherwise, it returns [Some itv] *) @@ -51,11 +52,11 @@ let inter i1 i2 = | None, Some _ -> o2 | Some n1, Some n2 -> Some (f n1 n2) in - norm_itv (inter max_num l1 l2, inter min_num r1 r2) + norm_itv (inter Q.max l1 l2, inter Q.min r1 r2) let range = function | None, _ | _, None -> None - | Some i, Some j -> Some (floor_num j -/ ceiling_num i +/ Int 1) + | Some i, Some j -> Some (Q.floor j -/ Q.ceiling i +/ Q.one) let smaller_itv i1 i2 = match (range i1, range i2) with diff --git a/plugins/micromega/itv.mli b/plugins/micromega/itv.mli index c7164f2c98..0dec639353 100644 --- a/plugins/micromega/itv.mli +++ b/plugins/micromega/itv.mli @@ -7,13 +7,13 @@ (* * GNU Lesser General Public License Version 2.1 *) (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Num +open NumCompat -type interval = num option * num option +type interval = Q.t option * Q.t option val pp : out_channel -> interval -> unit val inter : interval -> interval -> interval option -val range : interval -> num option +val range : interval -> Q.t option val smaller_itv : interval -> interval -> bool -val in_bound : interval -> num -> bool +val in_bound : interval -> Q.t -> bool val norm_itv : interval -> interval option diff --git a/plugins/micromega/mfourier.ml b/plugins/micromega/mfourier.ml index da75137185..838dab8ec8 100644 --- a/plugins/micromega/mfourier.ml +++ b/plugins/micromega/mfourier.ml @@ -8,8 +8,9 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +open NumCompat +open Q.Notations open Util -open Num open Polynomial open Vect @@ -61,11 +62,11 @@ let pp_cstr o (vect, bnd) = let l, r = bnd in ( match l with | None -> () - | Some n -> Printf.fprintf o "%s <= " (string_of_num n) ); + | Some n -> Printf.fprintf o "%s <= " (Q.to_string n) ); Vect.pp o vect; match r with | None -> output_string o "\n" - | Some n -> Printf.fprintf o "<=%s\n" (string_of_num n) + | Some n -> Printf.fprintf o "<=%s\n" (Q.to_string n) let pp_system o sys = System.iter (fun vect ibnd -> pp_cstr o (vect, !ibnd.bound)) sys @@ -121,12 +122,12 @@ let normalise_cstr vect cinfo = | None -> Contradiction | Some (l, r) -> ( match Vect.choose vect with - | None -> if Itv.in_bound (l, r) (Int 0) then Redundant else Contradiction + | None -> if Itv.in_bound (l, r) Q.zero then Redundant else Contradiction | Some (_, n, _) -> Cstr ( Vect.div n vect , let divn x = x // n in - if Int.equal (sign_num n) 1 then + if Int.equal (Q.sign n) 1 then {cinfo with bound = (Option.map divn l, Option.map divn r)} else { cinfo with @@ -139,7 +140,7 @@ let normalise_cstr vect cinfo = let count v = Vect.fold (fun (n, p) _ vl -> - let sg = sign_num vl in + let sg = Q.sign vl in assert (sg <> 0); if Int.equal sg 1 then (n, p + 1) else (n + 1, p)) (0, 0) v @@ -181,20 +182,20 @@ let system_list sys = System.fold (fun k bi l -> (k, !bi) :: l) s [] (** [add (v1,c1) (v2,c2) ] - precondition: (c1 <>/ Int 0 && c2 <>/ Int 0) + precondition: (c1 <>/ Q.zero && c2 <>/ Q.zero) @return a pair [(v,ln)] such that [v] is the sum of vector [v1] divided by [c1] and vector [v2] divided by [c2] Note that the resulting vector is not normalised. *) let add (v1, c1) (v2, c2) = - assert (c1 <>/ Int 0 && c2 <>/ Int 0); - let res = mul_add (Int 1 // c1) v1 (Int 1 // c2) v2 in + assert (c1 <>/ Q.zero && c2 <>/ Q.zero); + let res = mul_add (Q.one // c1) v1 (Q.one // c2) v2 in (res, count res) let add (v1, c1) (v2, c2) = let res = add (v1, c1) (v2, c2) in - (* Printf.printf "add(%a,%s,%a,%s) -> %a\n" pp_vect v1 (string_of_num c1) pp_vect v2 (string_of_num c2) pp_vect (fst res) ;*) + (* Printf.printf "add(%a,%s,%a,%s) -> %a\n" pp_vect v1 (Q.to_string c1) pp_vect v2 (Q.to_string c2) pp_vect (fst res) ;*) res (** To perform Fourier elimination, constraints are categorised depending on the sign of the variable to eliminate. *) @@ -207,11 +208,11 @@ let add (v1, c1) (v2, c2) = *) let split x (vect : vector) info (l, m, r) = - match get x vect with - | Int 0 -> + let vl = get x vect in + if Q.zero =/ vl then (* The constraint does not mention [x], store it in m *) (l, (vect, info) :: m, r) - | vl -> + else (* otherwise *) let cons_bound lst bd = match bd with @@ -219,7 +220,7 @@ let split x (vect : vector) info (l, m, r) = | Some bnd -> (vl, vect, {info with bound = (Some bnd, None)}) :: lst in let lb, rb = info.bound in - if Int.equal (sign_num vl) 1 then (cons_bound l lb, m, cons_bound r rb) + if Int.equal (Q.sign vl) 1 then (cons_bound l lb, m, cons_bound r rb) else (* sign_num vl = -1 *) (cons_bound l rb, m, cons_bound r lb) @@ -239,8 +240,8 @@ let project vr sys = let {neg = n1; pos = p1; bound = bound1; prf = prf1} = info1 and {neg = n2; pos = p2; bound = bound2; prf = prf2} = info2 in let bnd1 = Option.get (fst bound1) and bnd2 = Option.get (fst bound2) in - let bound = (bnd1 // v1) +/ (bnd2 // minus_num v2) in - let vres, (n, p) = add (vect1, v1) (vect2, minus_num v2) in + let bound = (bnd1 // v1) +/ (bnd2 // Q.neg v2) in + let vres, (n, p) = add (vect1, v1) (vect2, Q.neg v2) in ( vres , { neg = n ; pos = p @@ -270,11 +271,11 @@ let project vr sys = *) let project_using_eq vr c vect bound prf (vect', info') = - match get vr vect' with - | Int 0 -> (vect', info') - | c2 -> - let c1 = if c2 >=/ Int 0 then minus_num c else c in - let c2 = abs_num c2 in + let c2 = get vr vect' in + if Q.zero =/ c2 then (vect', info') + else + let c1 = if c2 >=/ Q.zero then Q.neg c else c in + let c2 = Q.abs c2 in let vres, (n, p) = add (vect, c1) (vect', c2) in let cst = bound // c1 in let bndres = @@ -315,14 +316,14 @@ let eval_vect map vect = let val_v = IMap.find v map in (sum +/ (val_v */ vl), rst) with Not_found -> (sum, Vect.set v vl rst)) - (Int 0, Vect.null) vect + (Q.zero, Vect.null) vect (** [restrict_bound n sum itv] returns the interval of [x] given that (fst itv) <= x * n + sum <= (snd itv) *) let restrict_bound n sum (itv : interval) = let f x = (x -/ sum) // n in let l, r = itv in - match sign_num n with + match Q.sign n with | 0 -> if in_bound itv sum then (None, None) (* redundant *) else failwith "SystemContradiction" @@ -339,7 +340,7 @@ let bound_of_variable map v sys = match inter bnd (restrict_bound vl sum !iref.bound) with | None -> Printf.fprintf stdout "bound_of_variable: eval_vecr %a = %s,%a\n" - Vect.pp vect (Num.string_of_num sum) Vect.pp rst; + Vect.pp vect (Q.to_string sum) Vect.pp rst; Printf.fprintf stdout "current interval: %a\n" Itv.pp !iref.bound; failwith "bound_of_variable: impossible" | Some itv -> itv) @@ -348,12 +349,12 @@ let bound_of_variable map v sys = (** [pick_small_value bnd] picks a value being closed to zero within the interval *) let pick_small_value bnd = match bnd with - | None, None -> Int 0 - | None, Some i -> if Int 0 <=/ floor_num i then Int 0 else floor_num i - | Some i, None -> if i <=/ Int 0 then Int 0 else ceiling_num i + | None, None -> Q.zero + | None, Some i -> if Q.zero <=/ Q.floor i then Q.zero else Q.floor i + | Some i, None -> if i <=/ Q.zero then Q.zero else Q.ceiling i | Some i, Some j -> - if i <=/ Int 0 && Int 0 <=/ j then Int 0 - else if ceiling_num i <=/ floor_num j then ceiling_num i (* why not *) + if i <=/ Q.zero && Q.zero <=/ j then Q.zero + else if Q.ceiling i <=/ Q.floor j then Q.ceiling i (* why not *) else i (** [solution s1 sys_l = Some(sn,\[(vn-1,sn-1);...; (v1,s1)\]\@sys_l)] @@ -373,8 +374,8 @@ let solve_sys black_v choose_eq choose_variable sys sys_l = fst (List.find (fun ((v, _, _, _), _) -> v <> black_v) eqs) in if debug then ( - Printf.printf "\nE %a = %s variable %i\n" Vect.pp vect - (string_of_num cst) v; + Printf.printf "\nE %a = %s variable %i\n" Vect.pp vect (Q.to_string cst) + v; flush stdout ); let sys' = elim_var_using_eq v vect cst ln sys in solve_sys sys' ((v, sys) :: sys_l) @@ -422,7 +423,7 @@ module EstimateElimVar = struct | Some bnd -> (info.neg + info.pos) :: lst in let lb, rb = info.bound in - if Int.equal (sign_num vl) 1 then + if Int.equal (Q.sign vl) 1 then xpart rl ((rl1, info) :: ltl) (cons_bound n lb) z (cons_bound p rb) else @@ -568,7 +569,7 @@ module Fourier = struct (* We add a dummy (fresh) variable for vector *) let fresh = 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; cst = Int 0} + {coeffs = Vect.set fresh Q.neg_one vect; op = Eq; cst = Q.zero} in match solve fresh choose_equality_var choose_variable (cstr :: l) with | Inr prf -> None (* This is an unsatisfiability proof *) @@ -619,28 +620,27 @@ module Proof = struct let pivot v (p1, c1) (p2, c2) = let {coeffs = v1; op = op1; cst = n1} = c1 and {coeffs = v2; op = op2; cst = n2} = c2 in - match (Vect.get v v1, Vect.get v v2) with - | Int 0, _ | _, Int 0 -> None - | a, b -> - if Int.equal (sign_num a * sign_num b) (-1) then - Some - ( add (p1, abs_num a) (p2, abs_num b) - , { coeffs = add (v1, abs_num a) (v2, abs_num b) - ; op = add_op op1 op2 - ; cst = (n1 // abs_num a) +/ (n2 // abs_num b) } ) - else if op1 == Eq then - Some - ( add (p1, minus_num (a // b)) (p2, Int 1) - , { coeffs = add (v1, minus_num (a // b)) (v2, Int 1) - ; op = add_op op1 op2 - ; cst = (n1 // minus_num (a // b)) +/ (n2 // Int 1) } ) - else if op2 == Eq then - Some - ( add (p2, minus_num (b // a)) (p1, Int 1) - , { coeffs = add (v2, minus_num (b // a)) (v1, Int 1) - ; op = add_op op1 op2 - ; cst = (n2 // minus_num (b // a)) +/ (n1 // Int 1) } ) - else None + let a, b = (Vect.get v v1, Vect.get v v2) in + if Q.zero =/ a || Q.zero =/ b then None + else if Int.equal (Q.sign a * Q.sign b) (-1) then + Some + ( add (p1, Q.abs a) (p2, Q.abs b) + , { coeffs = add (v1, Q.abs a) (v2, Q.abs b) + ; op = add_op op1 op2 + ; cst = (n1 // Q.abs a) +/ (n2 // Q.abs b) } ) + else if op1 == Eq then + Some + ( add (p1, Q.neg (a // b)) (p2, Q.one) + , { coeffs = add (v1, Q.neg (a // b)) (v2, Q.one) + ; op = add_op op1 op2 + ; cst = (n1 // Q.neg (a // b)) +/ (n2 // Q.one) } ) + else if op2 == Eq then + Some + ( add (p2, Q.neg (b // a)) (p1, Q.one) + , { coeffs = add (v2, Q.neg (b // a)) (v1, Q.one) + ; op = add_op op1 op2 + ; cst = (n2 // Q.neg (b // a)) +/ (n1 // Q.one) } ) + else None (* op2 could be Eq ... this might happen *) @@ -656,7 +656,7 @@ module Proof = struct | Cstr (v, info) -> Inl ((prf, cstr, v, info) :: acc) )) (Inl []) l - type oproof = (vector * cstr * num) option + type oproof = (vector * cstr * Q.t) option let merge_proof (oleft : oproof) (prf, cstr, v, info) (oright : oproof) = let l, r = info.bound in @@ -679,7 +679,7 @@ module Proof = struct (* There is a contradiction - it should show up by scaling up the vectors - any pivot should do*) match Vect.choose cstrr.coeffs with | None -> - Inr (add (prfl, Int 1) (prfr, Int 1), cstrr) (* this is wrong *) + Inr (add (prfl, Q.one) (prfr, Q.one), cstrr) (* this is wrong *) | Some (v, _, _) -> ( match pivot v (prfl, cstrl) (prfr, cstrr) with | None -> failwith "merge_proof : pivot is not possible" @@ -687,12 +687,12 @@ module Proof = struct let mk_proof hyps prf = (* I am keeping list - I might have a proof for the left bound and a proof for the right bound. - If I perform aggressive elimination of redundancies, I expect the list to be of length at most 2. - For each proof list, all the vectors should be of the form a.v for different constants a. - *) + If I perform aggressive elimination of redundancies, I expect the list to be of length at most 2. + For each proof list, all the vectors should be of the form a.v for different constants a. + *) let rec mk_proof prf = match prf with - | Assum i -> [(Vect.set i (Int 1) Vect.null, List.nth hyps i)] + | Assum i -> [(Vect.set i Q.one Vect.null, List.nth hyps i)] | Elim (v, prf1, prf2) -> let prfsl = mk_proof prf1 and prfsr = mk_proof prf2 in (* I take only the pairs for which the elimination is meaningful *) diff --git a/plugins/micromega/micromega_plugin.mlpack b/plugins/micromega/micromega_plugin.mlpack index e3aa0dab7d..2630e883c9 100644 --- a/plugins/micromega/micromega_plugin.mlpack +++ b/plugins/micromega/micromega_plugin.mlpack @@ -1,4 +1,5 @@ Micromega +NumCompat Mutils Itv Vect diff --git a/plugins/micromega/mutils.ml b/plugins/micromega/mutils.ml index 160b492d3d..2e054a21c2 100644 --- a/plugins/micromega/mutils.ml +++ b/plugins/micromega/mutils.ml @@ -19,6 +19,9 @@ (* *) (************************************************************************) +open NumCompat +module Z_ = NumCompat.Z + module Int = struct type t = int @@ -140,42 +143,24 @@ let saturate p f sys = Printexc.print_backtrace stdout; raise x -let saturate_bin (f : 'a -> 'a -> 'a option) (l : 'a list) = - let rec map_with acc e l = +let saturate_bin (type a) (module Set : Set.S with type elt = a) + (f : a -> a -> a option) (l : a list) = + let rec map_with (acc : Set.t) e l = match l with | [] -> acc - | e' :: l' -> ( + | e' :: l -> ( match f e e' with - | None -> map_with acc e l' - | Some r -> map_with (r :: acc) e l' ) - in - let rec map2_with acc l' = - match l' with [] -> acc | e' :: l' -> map2_with (map_with acc e' l) l' + | None -> map_with acc e l + | Some r -> map_with (Set.add r acc) e l ) in + let map2_with acc l' = Set.fold (fun e' acc -> map_with acc e' l) l' acc in let rec iterate acc l' = - match map2_with [] l' with - | [] -> List.rev_append l' acc - | res -> iterate (List.rev_append l' acc) res + let res = map2_with Set.empty l' in + if Set.is_empty res then Set.union l' acc + else iterate (Set.union l' acc) res in - iterate [] l - -open Num -open Big_int - -let ppcm x y = - let g = gcd_big_int x y in - let x' = div_big_int x g in - let y' = div_big_int y g in - mult_big_int g (mult_big_int x' y') - -let denominator = function - | Int _ | Big_int _ -> unit_big_int - | Ratio r -> Ratio.denominator_ratio r - -let numerator = function - | Ratio r -> Ratio.numerator_ratio r - | Int i -> Big_int.big_int_of_int i - | Big_int i -> i + let s0 = List.fold_left (fun acc e -> Set.add e acc) Set.empty l in + Set.elements (Set.diff (iterate Set.empty s0) s0) let iterate_until_stable f x = let rec iter x = match f x with None -> x | Some x' -> iter x' in @@ -207,24 +192,23 @@ module CoqToCaml = struct (* Swap left-right ? *) match i with XH -> 1 | XI i -> 1 + (2 * index i) | XO i -> 2 * index i - open Big_int - let rec positive_big_int p = match p with - | XH -> unit_big_int - | XI p -> add_int_big_int 1 (mult_int_big_int 2 (positive_big_int p)) - | XO p -> mult_int_big_int 2 (positive_big_int p) + | XH -> Z_.one + | XI p -> Z_.add Z_.one (Z_.mul Z_.two (positive_big_int p)) + | XO p -> Z_.mul Z_.two (positive_big_int p) let z_big_int x = match x with - | Z0 -> zero_big_int + | Z0 -> Z_.zero | Zpos p -> positive_big_int p - | Zneg p -> minus_big_int (positive_big_int p) + | Zneg p -> Z_.neg (positive_big_int p) let z x = match x with Z0 -> 0 | Zpos p -> index p | Zneg p -> -index p let q_to_num {qnum = x; qden = y} = - Big_int (z_big_int x) // Big_int (z_big_int (Zpos y)) + let open Q.Notations in + Q.of_bigint (z_big_int x) // Q.of_bigint (z_big_int (Zpos y)) end (** @@ -259,27 +243,24 @@ module CamlToCoq = struct (* this should be -1 *) Zneg (positive (-x)) - open Big_int - let positive_big_int n = - let two = big_int_of_int 2 in let rec _pos n = - if eq_big_int n unit_big_int then XH + if Z_.equal n Z_.one then XH else - let q, m = quomod_big_int n two in - if eq_big_int unit_big_int m then XI (_pos q) else XO (_pos q) + let q, m = Z_.quomod n Z_.two in + if Z_.equal Z_.one m then XI (_pos q) else XO (_pos q) in _pos n let bigint x = - match sign_big_int x with + match Z_.sign x with | 0 -> Z0 | 1 -> Zpos (positive_big_int x) - | _ -> Zneg (positive_big_int (minus_big_int x)) + | _ -> Zneg (positive_big_int (Z_.neg x)) let q n = - { Micromega.qnum = bigint (numerator n) - ; Micromega.qden = positive_big_int (denominator n) } + { Micromega.qnum = bigint (Q.num n) + ; Micromega.qden = positive_big_int (Q.den n) } end (** diff --git a/plugins/micromega/mutils.mli b/plugins/micromega/mutils.mli index 5dcaf3be44..a03b03ed8e 100644 --- a/plugins/micromega/mutils.mli +++ b/plugins/micromega/mutils.mli @@ -8,6 +8,8 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +open NumCompat + module Int : sig type t = int @@ -28,9 +30,6 @@ module IMap : sig (** [from k m] returns the submap of [m] with keys greater or equal k *) end -val numerator : Num.num -> Big_int.big_int -val denominator : Num.num -> Big_int.big_int - module Cmp : sig val compare_list : ('a -> 'b -> int) -> 'a list -> 'b list -> int val compare_lexical : (unit -> int) list -> int @@ -53,19 +52,19 @@ val pp_list : module CamlToCoq : sig val positive : int -> Micromega.positive - val bigint : Big_int.big_int -> Micromega.z + val bigint : Z.t -> Micromega.z val n : int -> Micromega.n val nat : int -> Micromega.nat - val q : Num.num -> Micromega.q + val q : Q.t -> Micromega.q val index : int -> Micromega.positive val z : int -> Micromega.z - val positive_big_int : Big_int.big_int -> Micromega.positive + val positive_big_int : Z.t -> Micromega.positive end module CoqToCaml : sig - val z_big_int : Micromega.z -> Big_int.big_int + val z_big_int : Micromega.z -> Z.t val z : Micromega.z -> int - val q_to_num : Micromega.q -> Num.num + val q_to_num : Micromega.q -> Q.t val positive : Micromega.positive -> int val n : Micromega.n -> int val nat : Micromega.nat -> int @@ -96,7 +95,6 @@ module Hash : sig val hash_elt : ('a -> int) -> int -> 'a -> int end -val ppcm : Big_int.big_int -> Big_int.big_int -> Big_int.big_int val all_pairs : ('a -> 'a -> 'b) -> 'a list -> 'b list val try_any : (('a -> 'b option) * 'c) list -> 'a -> 'b option val is_sublist : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool @@ -116,7 +114,12 @@ val simplify : ('a -> 'a option) -> 'a list -> 'a list option val saturate : ('a -> 'b option) -> ('b * 'a -> 'a -> 'a option) -> 'a list -> 'a list -val saturate_bin : ('a -> 'a -> 'a option) -> 'a list -> 'a list +val saturate_bin : + (module Set.S with type elt = 'a) + -> ('a -> 'a -> 'a option) + -> 'a list + -> 'a list + val generate : ('a -> 'b option) -> 'a list -> 'b list val app_funs : ('a -> 'b option) list -> 'a -> 'b option val command : string -> string array -> 'a -> 'b diff --git a/plugins/micromega/numCompat.ml b/plugins/micromega/numCompat.ml new file mode 100644 index 0000000000..82993cd730 --- /dev/null +++ b/plugins/micromega/numCompat.ml @@ -0,0 +1,174 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +module type ZArith = sig + type t + + val zero : t + val one : t + val two : t + val add : t -> t -> t + val sub : t -> t -> t + val mul : t -> t -> t + val div : t -> t -> t + val neg : t -> t + val sign : t -> int + val equal : t -> t -> bool + val compare : t -> t -> int + val power_int : t -> int -> t + val quomod : t -> t -> t * t + val ppcm : t -> t -> t + val gcd : t -> t -> t + val lcm : t -> t -> t + val to_string : t -> string +end + +module Z = struct + type t = Big_int.big_int + + open Big_int + + let zero = zero_big_int + let one = unit_big_int + let two = big_int_of_int 2 + let add = Big_int.add_big_int + let sub = Big_int.sub_big_int + let mul = Big_int.mult_big_int + let div = Big_int.div_big_int + let neg = Big_int.minus_big_int + let sign = Big_int.sign_big_int + let equal = eq_big_int + let compare = compare_big_int + let power_int = power_big_int_positive_int + let quomod = quomod_big_int + + let ppcm x y = + let g = gcd_big_int x y in + let x' = div_big_int x g in + let y' = div_big_int y g in + mult_big_int g (mult_big_int x' y') + + let gcd = gcd_big_int + + let lcm x y = + if eq_big_int x zero && eq_big_int y zero then zero + else abs_big_int (div_big_int (mult_big_int x y) (gcd x y)) + + let to_string = string_of_big_int +end + +module type QArith = sig + module Z : ZArith + + type t + + val of_int : int -> t + val zero : t + val one : t + val two : t + val ten : t + val neg_one : t + + module Notations : sig + val ( // ) : t -> t -> t + val ( +/ ) : t -> t -> t + val ( -/ ) : t -> t -> t + val ( */ ) : t -> t -> t + val ( =/ ) : t -> t -> bool + val ( <>/ ) : t -> t -> bool + val ( >/ ) : t -> t -> bool + val ( >=/ ) : t -> t -> bool + val ( </ ) : t -> t -> bool + val ( <=/ ) : t -> t -> bool + end + + val compare : t -> t -> int + val make : Z.t -> Z.t -> t + val den : t -> Z.t + val num : t -> Z.t + val of_bigint : Z.t -> t + val to_bigint : t -> Z.t + val neg : t -> t + + (* val inv : t -> t *) + val max : t -> t -> t + val min : t -> t -> t + val sign : t -> int + val abs : t -> t + val mod_ : t -> t -> t + val floor : t -> t + + (* val floorZ : t -> Z.t *) + val ceiling : t -> t + val round : t -> t + val pow2 : int -> t + val pow10 : int -> t + val power : int -> t -> t + val to_string : t -> string + val of_string : string -> t + val to_float : t -> float +end + +module Q : QArith with module Z = Z = struct + module Z = Z + + type t = Num.num + + open Num + + let of_int x = Int x + let zero = Int 0 + let one = Int 1 + let two = Int 2 + let ten = Int 10 + let neg_one = Int (-1) + + module Notations = struct + let ( // ) = div_num + let ( +/ ) = add_num + let ( -/ ) = sub_num + let ( */ ) = mult_num + let ( =/ ) = eq_num + let ( <>/ ) = ( <>/ ) + let ( >/ ) = ( >/ ) + let ( >=/ ) = ( >=/ ) + let ( </ ) = ( </ ) + let ( <=/ ) = ( <=/ ) + end + + let compare = compare_num + let make x y = Big_int x // Big_int y + + let numdom r = + let r' = Ratio.normalize_ratio (ratio_of_num r) in + (Ratio.numerator_ratio r', Ratio.denominator_ratio r') + + let num x = numdom x |> fst + let den x = numdom x |> snd + let of_bigint x = Big_int x + let to_bigint = big_int_of_num + let neg = minus_num + + (* let inv = *) + let max = max_num + let min = min_num + let sign = sign_num + let abs = abs_num + let mod_ = mod_num + let floor = floor_num + let ceiling = ceiling_num + let round = round_num + let pow2 n = power_num two (Int n) + let pow10 n = power_num ten (Int n) + let power x = power_num (Int x) + let to_string = string_of_num + let of_string = num_of_string + let to_float = float_of_num +end diff --git a/plugins/micromega/numCompat.mli b/plugins/micromega/numCompat.mli new file mode 100644 index 0000000000..183285e259 --- /dev/null +++ b/plugins/micromega/numCompat.mli @@ -0,0 +1,85 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +module type ZArith = sig + type t + + val zero : t + val one : t + val two : t + val add : t -> t -> t + val sub : t -> t -> t + val mul : t -> t -> t + val div : t -> t -> t + val neg : t -> t + val sign : t -> int + val equal : t -> t -> bool + val compare : t -> t -> int + val power_int : t -> int -> t + val quomod : t -> t -> t * t + val ppcm : t -> t -> t + val gcd : t -> t -> t + val lcm : t -> t -> t + val to_string : t -> string +end + +module type QArith = sig + module Z : ZArith + + type t + + val of_int : int -> t + val zero : t + val one : t + val two : t + val ten : t + val neg_one : t + + module Notations : sig + val ( // ) : t -> t -> t + val ( +/ ) : t -> t -> t + val ( -/ ) : t -> t -> t + val ( */ ) : t -> t -> t + val ( =/ ) : t -> t -> bool + val ( <>/ ) : t -> t -> bool + val ( >/ ) : t -> t -> bool + val ( >=/ ) : t -> t -> bool + val ( </ ) : t -> t -> bool + val ( <=/ ) : t -> t -> bool + end + + val compare : t -> t -> int + val make : Z.t -> Z.t -> t + val den : t -> Z.t + val num : t -> Z.t + val of_bigint : Z.t -> t + val to_bigint : t -> Z.t + val neg : t -> t + + (* val inv : t -> t *) + + val max : t -> t -> t + val min : t -> t -> t + val sign : t -> int + val abs : t -> t + val mod_ : t -> t -> t + val floor : t -> t + val ceiling : t -> t + val round : t -> t + val pow2 : int -> t + val pow10 : int -> t + val power : int -> t -> t + val to_string : t -> string + val of_string : string -> t + val to_float : t -> float +end + +module Z : ZArith +module Q : QArith with module Z = Z diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml index d5b28cb03e..4777b5e231 100644 --- a/plugins/micromega/persistent_cache.ml +++ b/plugins/micromega/persistent_cache.ml @@ -82,9 +82,9 @@ module PHashtable (Key : HashedType) : PHashtable with type key = Key.t = struct with Unix.Unix_error (_, _, _) -> () (* Here, this is really bad news -- - there is a pending lock which could cause a deadlock. - Should it be an anomaly or produce a warning ? - *); + there is a pending lock which could cause a deadlock. + Should it be an anomaly or produce a warning ? + *); ignore (lseek fd pos SEEK_SET) (* We make the assumption that an acquired lock can always be released *) diff --git a/plugins/micromega/polynomial.ml b/plugins/micromega/polynomial.ml index b20213979b..68aa739a6f 100644 --- a/plugins/micromega/polynomial.ml +++ b/plugins/micromega/polynomial.ml @@ -14,7 +14,8 @@ (* *) (************************************************************************) -open Num +open NumCompat +open Q.Notations open Mutils module Mc = Micromega @@ -23,8 +24,8 @@ let max_nb_cstr = ref max_int type var = int let debug = false -let ( <+> ) = add_num -let ( <*> ) = mult_num +let ( <+> ) = ( +/ ) +let ( <*> ) = ( */ ) module Monomial : sig type t @@ -153,13 +154,11 @@ end let pp_mon o (m, i) = if Monomial.is_const m then - if eq_num (Int 0) i then () else Printf.fprintf o "%s" (string_of_num i) - else - match i with - | Int 1 -> Monomial.pp o m - | Int -1 -> Printf.fprintf o "-%a" Monomial.pp m - | Int 0 -> () - | _ -> Printf.fprintf o "%s*%a" (string_of_num i) Monomial.pp m + if Q.zero =/ i then () else Printf.fprintf o "%s" (Q.to_string i) + else if Q.one =/ i then Monomial.pp o m + else if Q.neg_one =/ i then Printf.fprintf o "-%a" Monomial.pp m + else if Q.zero =/ i then () + else Printf.fprintf o "%s*%a" (Q.to_string i) Monomial.pp m module Poly : (* A polynomial is a map of monomials *) (* @@ -171,51 +170,51 @@ sig type t val pp : out_channel -> t -> unit - val get : Monomial.t -> t -> num + val get : Monomial.t -> t -> Q.t val variable : var -> t - val add : Monomial.t -> num -> t -> t - val constant : num -> t + val add : Monomial.t -> Q.t -> t -> t + val constant : Q.t -> t val product : t -> t -> t val addition : t -> t -> t val uminus : t -> t - val fold : (Monomial.t -> num -> 'a -> 'a) -> t -> 'a -> 'a + val fold : (Monomial.t -> Q.t -> 'a -> 'a) -> t -> 'a -> 'a val factorise : var -> t -> t * t end = struct (*normalisation bug : 0*x ... *) module P = Map.Make (Monomial) open P - type t = num P.t + type t = Q.t P.t let pp o p = P.iter (fun mn i -> Printf.fprintf o "%a + " pp_mon (mn, i)) p (* Get the coefficient of monomial mn *) - let get : Monomial.t -> t -> num = - fun mn p -> try find mn p with Not_found -> Int 0 + let get : Monomial.t -> t -> Q.t = + fun mn p -> try find mn p with Not_found -> Q.zero (* The polynomial 1.x *) - let variable : var -> t = fun x -> add (Monomial.var x) (Int 1) empty + let variable : var -> t = fun x -> add (Monomial.var x) Q.one empty (*The constant polynomial *) - let constant : num -> t = fun c -> add Monomial.const c empty + let constant : Q.t -> t = fun c -> add Monomial.const c empty (* The addition of a monomial *) - let add : Monomial.t -> num -> t -> t = + let add : Monomial.t -> Q.t -> t -> t = fun mn v p -> - if sign_num v = 0 then p + if Q.sign v = 0 then p else let vl = get mn p <+> v in - if sign_num vl = 0 then remove mn p else add mn vl p + if Q.sign vl = 0 then remove mn p else add mn vl p (** Design choice: empty is not a polynomial I do not remember why .... **) (* The product by a monomial *) - let mult : Monomial.t -> num -> t -> t = + let mult : Monomial.t -> Q.t -> t -> t = fun mn v p -> - if sign_num v = 0 then constant (Int 0) + if Q.sign v = 0 then constant Q.zero else fold (fun mn' v' res -> P.add (Monomial.prod mn mn') (v <*> v') res) @@ -227,7 +226,7 @@ end = struct let product : t -> t -> t = fun p1 p2 -> fold (fun mn v res -> addition (mult mn v p2) res) p1 empty - let uminus : t -> t = fun p -> map (fun v -> minus_num v) p + let uminus : t -> t = fun p -> map (fun v -> Q.neg v) p let fold = P.fold let factorise x p = @@ -240,12 +239,12 @@ end = struct let mx = Monomial.prod m1 (Monomial.exp x (i - 1)) in (add mx v px, cx)) p - (constant (Int 0), constant (Int 0)) + (constant Q.zero, constant Q.zero) end type vector = Vect.t -type cstr = {coeffs : vector; op : op; cst : num} +type cstr = {coeffs : vector; op : op; cst : Q.t} and op = Eq | Ge | Gt @@ -256,8 +255,7 @@ let eval_op = function Eq -> ( =/ ) | Ge -> ( >=/ ) | Gt -> ( >/ ) let string_of_op = function Eq -> "=" | Ge -> ">=" | Gt -> ">" let output_cstr o {coeffs; op; cst} = - Printf.fprintf o "%a %s %s" Vect.pp coeffs (string_of_op op) - (string_of_num cst) + Printf.fprintf o "%a %s %s" Vect.pp coeffs (string_of_op op) (Q.to_string cst) let opMult o1 o2 = match (o1, o2) with Eq, _ | _, Eq -> Eq | Ge, _ | _, Ge -> Ge | Gt, Gt -> Gt @@ -308,11 +306,11 @@ module LinPoly = struct let _ = register Monomial.const end - let var v = Vect.set (MonT.register (Monomial.var v)) (Int 1) Vect.null + let var v = Vect.set (MonT.register (Monomial.var v)) Q.one Vect.null let of_monomial m = let v = MonT.register m in - Vect.set v (Int 1) Vect.null + Vect.set v Q.one Vect.null let linpol_of_pol p = Poly.fold @@ -324,7 +322,7 @@ module LinPoly = struct let pol_of_linpol v = Vect.fold (fun p vr n -> Poly.add (MonT.retrieve vr) n p) - (Poly.constant (Int 0)) v + (Poly.constant Q.zero) v let coq_poly_of_linpol cst p = let pol_of_mon m = @@ -332,13 +330,13 @@ module LinPoly = struct (fun x v p -> Mc.PEmul (Mc.PEpow (Mc.PEX (CamlToCoq.positive x), CamlToCoq.n v), p)) m - (Mc.PEc (cst (Int 1))) + (Mc.PEc (cst Q.one)) in Vect.fold (fun acc x v -> let mn = MonT.retrieve x in Mc.PEadd (Mc.PEmul (Mc.PEc (cst v), pol_of_mon mn), acc)) - (Mc.PEc (cst (Int 0))) + (Mc.PEc (cst Q.zero)) p let pp_var o vr = @@ -346,7 +344,7 @@ module LinPoly = struct with Not_found -> Printf.fprintf o "v%i" vr let pp o p = Vect.pp_gen pp_var o p - let constant c = if sign_num c = 0 then Vect.null else Vect.set 0 c Vect.null + let constant c = if Q.sign c = 0 then Vect.null else Vect.set 0 c Vect.null let is_linear p = Vect.for_all @@ -357,7 +355,7 @@ module LinPoly = struct let is_variable p = let (x, v), r = Vect.decomp_fst p in - if Vect.is_null r && v >/ Int 0 then Monomial.get_var (MonT.retrieve x) + if Vect.is_null r && v >/ Q.zero then Monomial.get_var (MonT.retrieve x) else None let factorise x p = @@ -431,17 +429,15 @@ module LinPoly = struct end module ProofFormat = struct - open Big_int - type prf_rule = | Annot of string * prf_rule | Hyp of int | Def of int - | Cst of Num.num + | Cst of Q.t | Zero | Square of Vect.t | MulC of Vect.t * prf_rule - | Gcd of Big_int.big_int * prf_rule + | Gcd of Z.t * prf_rule | MulPrf of prf_rule * prf_rule | AddPrf of prf_rule * prf_rule | CutPrf of prf_rule @@ -458,7 +454,7 @@ module ProofFormat = struct | Annot (s, p) -> Printf.fprintf o "(%a)@%s" output_prf_rule p s | Hyp i -> Printf.fprintf o "Hyp %i" i | Def i -> Printf.fprintf o "Def %i" i - | Cst c -> Printf.fprintf o "Cst %s" (string_of_num c) + | Cst c -> Printf.fprintf o "Cst %s" (Q.to_string c) | Zero -> Printf.fprintf o "Zero" | Square s -> Printf.fprintf o "(%a)^2" Poly.pp (LinPoly.pol_of_linpol s) | MulC (p, pr) -> @@ -469,8 +465,7 @@ module ProofFormat = struct | AddPrf (p1, p2) -> Printf.fprintf o "%a + %a" output_prf_rule p1 output_prf_rule p2 | CutPrf p -> Printf.fprintf o "[%a]" output_prf_rule p - | Gcd (c, p) -> - Printf.fprintf o "(%a)/%s" output_prf_rule p (string_of_big_int c) + | Gcd (c, p) -> Printf.fprintf o "(%a)/%s" output_prf_rule p (Z.to_string c) let rec output_proof o = function | Done -> Printf.fprintf o "." @@ -485,11 +480,11 @@ module ProofFormat = struct let rec pr_size = function | Annot (_, p) -> pr_size p - | Zero | Square _ -> Int 0 - | Hyp _ -> Int 1 - | Def _ -> Int 1 + | Zero | Square _ -> Q.zero + | Hyp _ -> Q.one + | Def _ -> Q.one | Cst n -> n - | Gcd (i, p) -> pr_size p // Big_int i + | Gcd (i, p) -> pr_size p // Q.of_bigint i | MulPrf (p1, p2) | AddPrf (p1, p2) -> pr_size p1 +/ pr_size p2 | CutPrf p -> pr_size p | MulC (v, p) -> pr_size p @@ -601,12 +596,12 @@ module ProofFormat = struct (id, ExProof (i, j, k, x, z, t, prf)) | Enum (i, p1, v, p2, pl) -> (* Why do I have top-level cuts ? *) - (* let p1 = implicit_cut p1 in - let p2 = implicit_cut p2 in - let (ids,prfs) = List.split (List.map (normalise_proof id) pl) in - (List.fold_left max 0 ids , - Enum(i,p1,v,p2,prfs)) - *) + (* let p1 = implicit_cut p1 in + let p2 = implicit_cut p2 in + let (ids,prfs) = List.split (List.map (normalise_proof id) pl) in + (List.fold_left max 0 ids , + Enum(i,p1,v,p2,prfs)) + *) let bds1, id, p1' = pr_rule_def_cut id (implicit_cut p1) in let bds2, id, p2' = pr_rule_def_cut id (implicit_cut p2) in let ids, prfs = List.split (List.map (normalise_proof id) pl) in @@ -649,13 +644,13 @@ module ProofFormat = struct if s1 = s2 then compare p1 p2 else String.compare s1 s2 | Hyp i, Hyp j -> Int.compare i j | Def i, Def j -> Int.compare i j - | Cst n, Cst m -> Num.compare_num n m + | Cst n, Cst m -> Q.compare n m | Zero, Zero -> 0 | Square v1, Square v2 -> Vect.compare v1 v2 | MulC (v1, p1), MulC (v2, p2) -> cmp_pair Vect.compare compare (v1, p1) (v2, p2) | Gcd (b1, p1), Gcd (b2, p2) -> - cmp_pair Big_int.compare_big_int compare (b1, p1) (b2, p2) + cmp_pair Z.compare compare (b1, p1) (b2, p2) | MulPrf (p1, q1), MulPrf (p2, q2) -> cmp_pair compare compare (p1, q1) (p2, q2) | AddPrf (p1, q1), MulPrf (p2, q2) -> @@ -672,11 +667,11 @@ module ProofFormat = struct | Annot (s, p) -> Annot (s, mul_cst_proof c p) | MulC (v, p') -> MulC (Vect.mul c v, p') | _ -> ( - match sign_num c with + match Q.sign c with | 0 -> Zero (* This is likely to be a bug *) | -1 -> MulC (LinPoly.constant c, p) (* [p] should represent an equality *) - | 1 -> if eq_num (Int 1) c then p else MulPrf (Cst c, p) + | 1 -> if Q.one =/ c then p else MulPrf (Cst c, p) | _ -> assert false ) let sMulC v p = @@ -698,7 +693,7 @@ module ProofFormat = struct match p with | Annot (s, p) -> dev_prf_rule p | Hyp _ | Def _ | Cst _ | Zero | Square _ -> - PrfRuleMap.singleton p (LinPoly.constant (Int 1)) + PrfRuleMap.singleton p (LinPoly.constant Q.one) | MulC (v, p) -> PrfRuleMap.map (fun v1 -> LinPoly.product v v1) (dev_prf_rule p) | AddPrf (p1, p2) -> @@ -716,9 +711,9 @@ module ProofFormat = struct let p2'' = prf_rule_of_map p2' in match p1'' with | Cst c -> PrfRuleMap.map (fun v1 -> Vect.mul c v1) p2' - | _ -> - PrfRuleMap.singleton (MulPrf (p1'', p2'')) (LinPoly.constant (Int 1)) ) - | _ -> PrfRuleMap.singleton p (LinPoly.constant (Int 1)) + | _ -> PrfRuleMap.singleton (MulPrf (p1'', p2'')) (LinPoly.constant Q.one) + ) + | _ -> PrfRuleMap.singleton p (LinPoly.constant Q.one) let simplify_prf_rule p = prf_rule_of_map (dev_prf_rule p) @@ -766,7 +761,7 @@ module ProofFormat = struct xid_of_hyp 0 l end - let cmpl_prf_rule norm (cst : num -> 'a) env prf = + let cmpl_prf_rule norm (cst : Q.t -> 'a) env prf = let rec cmpl = function | Annot (s, p) -> cmpl p | Hyp i | Def i -> Mc.PsatzIn (CamlToCoq.nat (Env.id_of_hyp i env)) @@ -783,7 +778,7 @@ module ProofFormat = struct cmpl prf let cmpl_prf_rule_z env r = - cmpl_prf_rule Mc.normZ (fun x -> CamlToCoq.bigint (numerator x)) env r + cmpl_prf_rule Mc.normZ (fun x -> CamlToCoq.bigint (Q.num x)) env r let rec cmpl_proof env = function | Done -> Mc.DoneProof @@ -810,7 +805,7 @@ module ProofFormat = struct | Hyp i | Def i -> env i | Cst n -> ( ( Vect.set 0 n Vect.null - , match Num.compare_num n (Int 0) with + , match Q.compare n Q.zero with | 0 -> Ge | 1 -> Gt | _ -> failwith "eval_prf_rule : negative constant" ) ) @@ -826,7 +821,7 @@ module ProofFormat = struct failwith "eval_prf_rule : not an equality" ) | Gcd (g, p) -> let v, op = eval_prf_rule env p in - (Vect.div (Big_int g) v, op) + (Vect.div (Q.of_bigint g) v, op) | MulPrf (p1, p2) -> let v1, o1 = eval_prf_rule env p1 in let v2, o2 = eval_prf_rule env p2 in @@ -839,7 +834,7 @@ module ProofFormat = struct let is_unsat (p, o) = let c, r = Vect.decomp_cst p in - if Vect.is_null r then not (eval_op o c (Int 0)) else false + if Vect.is_null r then not (eval_op o c Q.zero) else false let rec eval_proof env p = match p with @@ -864,6 +859,12 @@ end module WithProof = struct type t = (LinPoly.t * op) * ProofFormat.prf_rule + (* The comparison ignores proofs on purpose *) + let compare : t -> t -> int = + fun ((lp1, o1), _) ((lp2, o2), _) -> + let c = Vect.compare lp1 lp2 in + if c = 0 then compare o1 o2 else c + let annot s (p, prf) = (p, ProofFormat.Annot (s, prf)) let output o ((lp, op), prf) = @@ -876,7 +877,7 @@ module WithProof = struct let zero = ((Vect.null, Eq), ProofFormat.Zero) let const n = ((LinPoly.constant n, Ge), ProofFormat.Cst n) - let of_cstr (c, prf) = ((Vect.set 0 (Num.minus_num c.cst) c.coeffs, c.op), prf) + let of_cstr (c, prf) = ((Vect.set 0 (Q.neg c.cst) c.coeffs, c.op), prf) let product : t -> t -> t = fun ((p1, o1), prf1) ((p2, o2), prf2) -> @@ -891,7 +892,7 @@ module WithProof = struct | Eq -> ((LinPoly.product p p1, o1), ProofFormat.sMulC p prf1) | Gt | Ge -> let n, r = Vect.decomp_cst p in - if Vect.is_null r && n >/ Int 0 then + if Vect.is_null r && n >/ Q.zero then ((LinPoly.product p p1, o1), ProofFormat.mul_cst_proof n prf1) else ( if debug then @@ -902,34 +903,31 @@ module WithProof = struct let cutting_plane ((p, o), prf) = let c, p' = Vect.decomp_cst p in let g = Vect.gcd p' in - if - Big_int.eq_big_int Big_int.unit_big_int g - || c =/ Int 0 - || not (Big_int.eq_big_int (denominator c) Big_int.unit_big_int) - then None (* Nothing to do *) + if Z.equal Z.one g || c =/ Q.zero || not (Z.equal (Q.den c) Z.one) then None + (* Nothing to do *) else - let c1 = c // Big_int g in - let c1' = Num.floor_num c1 in + let c1 = c // Q.of_bigint g in + let c1' = Q.floor c1 in if c1 =/ c1' then None else match o with | Eq -> - Some ((Vect.set 0 (Int (-1)) Vect.null, Eq), ProofFormat.Gcd (g, prf)) + Some ((Vect.set 0 Q.neg_one Vect.null, Eq), ProofFormat.Gcd (g, prf)) | Gt -> failwith "cutting_plane ignore strict constraints" | Ge -> (* This is a non-trivial common divisor *) Some - ( (Vect.set 0 c1' (Vect.div (Big_int g) p), o) + ( (Vect.set 0 c1' (Vect.div (Q.of_bigint g) p), o) , ProofFormat.Gcd (g, prf) ) let construct_sign p = let c, p' = Vect.decomp_cst p in if Vect.is_null p' then Some - ( match sign_num c with + ( match Q.sign c with | 0 -> (true, Eq, ProofFormat.Zero) | 1 -> (true, Gt, ProofFormat.Cst c) - | _ (*-1*) -> (false, Gt, ProofFormat.Cst (minus_num c)) ) + | _ (*-1*) -> (false, Gt, ProofFormat.Cst (Q.neg c)) ) else None let get_sign l p = @@ -1001,7 +999,7 @@ module WithProof = struct | Some (c, p) -> Some (c, ProofFormat.simplify_prf_rule p) let is_substitution strict ((p, o), prf) = - let pred v = if strict then v =/ Int 1 || v =/ Int (-1) else true in + let pred v = if strict then v =/ Q.one || v =/ Q.neg_one else true in match o with Eq -> LinPoly.search_linear pred p | _ -> None let subst1 sys0 = @@ -1042,14 +1040,14 @@ module WithProof = struct , Some {cst = c2; var = v2; coeff = c2'} ) -> ( let good_coeff b o = match o with - | Eq -> Some (minus_num b) - | _ -> if b <=/ Int 0 then Some (minus_num b) else None + | Eq -> Some (Q.neg b) + | _ -> if b <=/ Q.zero then Some (Q.neg b) else None in match (good_coeff c1 o2, good_coeff c2 o1) with | None, _ | _, None -> None | Some c1, Some c2 -> let ext_mult c w = - if c =/ Int 0 then zero else mult (LinPoly.constant c) w + if c =/ Q.zero then zero else mult (LinPoly.constant c) w in Some (addition diff --git a/plugins/micromega/polynomial.mli b/plugins/micromega/polynomial.mli index 4b56b037e0..357a2b10e1 100644 --- a/plugins/micromega/polynomial.mli +++ b/plugins/micromega/polynomial.mli @@ -9,6 +9,7 @@ (************************************************************************) open Mutils +open NumCompat module Mc = Micromega val max_nb_cstr : int ref @@ -81,7 +82,7 @@ module Poly : sig type t - val constant : Num.num -> t + val constant : Q.t -> t (** [constant c] @return the constant polynomial c *) @@ -101,24 +102,24 @@ module Poly : sig (** [uminus p] @return the polynomial -p i.e product by -1 *) - val get : Monomial.t -> t -> Num.num + val get : Monomial.t -> t -> Q.t (** [get mi p] @return the coefficient ai of the monomial mi. *) - val fold : (Monomial.t -> Num.num -> 'a -> 'a) -> t -> 'a -> 'a + val fold : (Monomial.t -> Q.t -> 'a -> 'a) -> t -> 'a -> 'a (** [fold f p a] folds f over the monomials of p with non-zero coefficient *) - val add : Monomial.t -> Num.num -> t -> t + val add : Monomial.t -> Q.t -> t -> t (** [add m n p] @return the polynomial n*m + p *) end -type cstr = {coeffs : Vect.t; op : op; cst : Num.num} +type cstr = {coeffs : Vect.t; op : op; cst : Q.t} (* Representation of linear constraints *) and op = Eq | Ge | Gt -val eval_op : op -> Num.num -> Num.num -> bool +val eval_op : op -> Q.t -> Q.t -> bool (*val opMult : op -> op -> op*) @@ -172,7 +173,7 @@ module LinPoly : sig @return 1.y where y is the variable index of the monomial x^1. *) - val coq_poly_of_linpol : (Num.num -> 'a) -> t -> 'a Mc.pExpr + val coq_poly_of_linpol : (Q.t -> 'a) -> t -> 'a Mc.pExpr (** [coq_poly_of_linpol c p] @param p is a multi-variate polynomial. @param c maps a rational to a Coq polynomial coefficient. @@ -206,7 +207,7 @@ module LinPoly : sig @return true if the polynomial is linear in x i.e can be written c*x+r where c is a constant and r is independent from x *) - val constant : Num.num -> t + val constant : Q.t -> t (** [constant c] @return the constant polynomial c *) @@ -216,9 +217,9 @@ module LinPoly : sig p is linear in x i.e x does not occur in b and a is a constant such that [pred a] *) - val search_linear : (Num.num -> bool) -> t -> var option + val search_linear : (Q.t -> bool) -> t -> var option - val search_all_linear : (Num.num -> bool) -> t -> var list + val search_all_linear : (Q.t -> bool) -> t -> var list (** [search_all_linear pred p] @return all the variables x such p = a.x + b such that p is linear in x i.e x does not occur in b and @@ -270,11 +271,11 @@ module ProofFormat : sig | Annot of string * prf_rule | Hyp of int | Def of int - | Cst of Num.num + | Cst of Q.t | Zero | Square of Vect.t | MulC of Vect.t * prf_rule - | Gcd of Big_int.big_int * prf_rule + | Gcd of Z.t * prf_rule | MulPrf of prf_rule * prf_rule | AddPrf of prf_rule * prf_rule | CutPrf of prf_rule @@ -287,20 +288,20 @@ module ProofFormat : sig (* x = z - t, z >= 0, t >= 0 *) - val pr_size : prf_rule -> Num.num + val pr_size : prf_rule -> Q.t val pr_rule_max_id : prf_rule -> int val proof_max_id : proof -> int val normalise_proof : int -> proof -> int * proof val output_prf_rule : out_channel -> prf_rule -> unit val output_proof : out_channel -> proof -> unit val add_proof : prf_rule -> prf_rule -> prf_rule - val mul_cst_proof : Num.num -> prf_rule -> prf_rule + val mul_cst_proof : Q.t -> prf_rule -> prf_rule val mul_proof : prf_rule -> prf_rule -> prf_rule val compile_proof : int list -> proof -> Micromega.zArithProof val cmpl_prf_rule : ('a Micromega.pExpr -> 'a Micromega.pol) - -> (Num.num -> 'a) + -> (Q.t -> 'a) -> int list -> prf_rule -> 'a Micromega.psatz @@ -320,6 +321,7 @@ module WithProof : sig exception InvalidProof (** [InvalidProof] is raised if the operation is invalid. *) + val compare : t -> t -> int val annot : string -> t -> t val of_cstr : cstr * ProofFormat.prf_rule -> t @@ -331,7 +333,7 @@ module WithProof : sig val zero : t (** [zero] represents the tautology (0=0) *) - val const : Num.num -> t + val const : Q.t -> t (** [const n] represents the tautology (n>=0) *) val product : t -> t -> t diff --git a/plugins/micromega/simplex.ml b/plugins/micromega/simplex.ml index 54976221bc..15ab03964e 100644 --- a/plugins/micromega/simplex.ml +++ b/plugins/micromega/simplex.ml @@ -8,10 +8,9 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +open NumCompat +open Q.Notations open Polynomial -open Num - -(*open Util*) open Mutils type ('a, 'b) sum = Inl of 'a | Inr of 'b @@ -118,7 +117,7 @@ let output_vars o m = let unfeasible (rst : Restricted.t) tbl = Restricted.fold rst - (fun k v m -> if Vect.get_cst v >=/ Int 0 then m else IMap.add k () m) + (fun k v m -> if Vect.get_cst v >=/ Q.zero then m else IMap.add k () m) tbl IMap.empty let is_feasible rst tb = IMap.is_empty (unfeasible rst tb) @@ -138,7 +137,7 @@ let is_feasible rst tb = IMap.is_empty (unfeasible rst tb) let is_maximised_vect rst v = Vect.for_all (fun xi ai -> - if ai >/ Int 0 then false else Restricted.is_restricted xi rst) + if ai >/ Q.zero then false else Restricted.is_restricted xi rst) v (** [is_maximised rst v] @@ -161,11 +160,11 @@ let is_maximised rst v = *) type result = - | Max of num (** Maximum is reached *) + | Max of Q.t (** Maximum is reached *) | Ubnd of var (** Problem is unbounded *) | Feas (** Problem is feasible *) -type pivot = Done of result | Pivot of int * int * num +type pivot = Done of result | Pivot of int * int * Q.t type simplex = Opt of tableau * result (** For a row, x = ao.xo+...+ai.xi @@ -180,7 +179,7 @@ let rec find_pivot_column (rst : Restricted.t) (r : Vect.t) = match Vect.choose r with | None -> failwith "find_pivot_column" | Some (xi, ai, r') -> - if ai </ Int 0 then + if ai </ Q.zero then if Restricted.is_restricted xi rst then find_pivot_column rst r' (* ai.xi cannot be improved *) else (xi, -1) (* r is not restricted, sign of ai does not matter *) @@ -207,9 +206,9 @@ let find_pivot_row rst tbl j sgn = Restricted.fold rst (fun i' v res -> let aij = Vect.get j v in - if Int sgn */ aij </ Int 0 then + if Q.of_int sgn */ aij </ Q.zero then (* This would improve *) - let score' = Num.abs_num (Vect.get_cst v // aij) in + let score' = Q.abs (Vect.get_cst v // aij) in min_score res (i', score') else res) tbl None @@ -246,10 +245,10 @@ let find_pivot vr (rst : Restricted.t) tbl = let solve_column (c : var) (r : var) (e : Vect.t) : Vect.t = let a = Vect.get c e in - if a =/ Int 0 then failwith "Cannot solve column" + if a =/ Q.zero then failwith "Cannot solve column" else - let a' = Int (-1) // a in - Vect.mul a' (Vect.set r (Int (-1)) (Vect.set c (Int 0) e)) + let a' = Q.neg_one // a in + Vect.mul a' (Vect.set r Q.neg_one (Vect.set c Q.zero e)) (** [pivot_row r c e] @param c is such that c = e @@ -258,7 +257,7 @@ let solve_column (c : var) (r : var) (e : Vect.t) : Vect.t = let pivot_row (row : Vect.t) (c : var) (e : Vect.t) : Vect.t = let g = Vect.get c row in - if g =/ Int 0 then row else Vect.mul_add g e (Int 1) (Vect.set c (Int 0) row) + if g =/ Q.zero then row else Vect.mul_add g e Q.one (Vect.set c Q.zero row) let pivot_with (m : tableau) (v : var) (p : Vect.t) = IMap.map (fun (r : Vect.t) -> pivot_row r v p) m @@ -270,7 +269,7 @@ let pivot (m : tableau) (r : var) (c : var) = IMap.add c piv (pivot_with (IMap.remove r m) c piv) let adapt_unbounded vr x rst tbl = - if Vect.get_cst (IMap.find vr tbl) >=/ Int 0 then tbl else pivot tbl vr x + if Vect.get_cst (IMap.find vr tbl) >=/ Q.zero then tbl else pivot tbl vr x module BaseSet = Set.Make (struct type t = iset @@ -295,7 +294,7 @@ let simplex opt vr rst tbl = output_tableau stdout tbl; Printf.fprintf stdout "Error for variables %a\n" output_vars m end; - if (not opt) && Vect.get_cst (IMap.find vr tbl) >=/ Int 0 then + if (not opt) && Vect.get_cst (IMap.find vr tbl) >=/ Q.zero then Opt (tbl, Feas) else match find_pivot vr rst tbl with @@ -308,7 +307,7 @@ let simplex opt vr rst tbl = | Feas -> raise (Invalid_argument "find_pivot") ) | Pivot (i, j, s) -> if debug then begin - Printf.fprintf stdout "Find pivot for x%i(%s)\n" vr (string_of_num s); + Printf.fprintf stdout "Find pivot for x%i(%s)\n" vr (Q.to_string s); Printf.fprintf stdout "Leaving variable x%i\n" i; Printf.fprintf stdout "Entering variable x%i\n" j end; @@ -359,14 +358,13 @@ let push_real (opt : bool) (nw : var) (v : Vect.t) (rst : Restricted.t) | Feas -> Sat (t', None) | Max n -> if debug then begin - Printf.printf "The objective is maximised %s\n" (string_of_num n); + Printf.printf "The objective is maximised %s\n" (Q.to_string n); Printf.printf "%a = %a\n" LinPoly.pp_var nw pp_row (IMap.find nw t') end; - if n >=/ Int 0 then Sat (t', None) + if n >=/ Q.zero then Sat (t', None) else let v' = safe_find "push_real" nw t' in - Unsat - (Vect.set nw (Int 1) (Vect.set 0 (Int 0) (Vect.mul (Int (-1)) v'))) ) + Unsat (Vect.set nw Q.one (Vect.set 0 Q.zero (Vect.mul Q.neg_one v'))) ) open Mutils (** One complication is that equalities needs some pre-processing. @@ -381,7 +379,7 @@ let make_certificate vm l = (Vect.fold (fun acc x n -> let x', b = IMap.find x vm in - Vect.set x' (if b then n else Num.minus_num n) acc) + Vect.set x' (if b then n else Q.neg n) acc) Vect.null l) (** [eliminate_equalities vr0 l] @@ -397,11 +395,11 @@ let eliminate_equalities (vr0 : var) (l : Polynomial.cstr list) = | c :: l -> ( match c.op with | Ge -> - let v = Vect.set 0 (minus_num c.cst) c.coeffs in + let v = Vect.set 0 (Q.neg c.cst) c.coeffs in elim (idx + 1) (vr + 1) (IMap.add vr (idx, true) vm) l ((vr, v) :: acc) | Eq -> - let v1 = Vect.set 0 (minus_num c.cst) c.coeffs in - let v2 = Vect.mul (Int (-1)) v1 in + let v1 = Vect.set 0 (Q.neg c.cst) c.coeffs in + let v2 = Vect.mul Q.neg_one v1 in let vm = IMap.add vr (idx, true) (IMap.add (vr + 1) (idx, false) vm) in elim (idx + 1) (vr + 2) vm l ((vr, v1) :: (vr + 1, v2) :: acc) | Gt -> raise Strict ) @@ -419,7 +417,7 @@ let find_full_solution rst tbl = IMap.fold (fun vr v res -> Vect.set vr (Vect.get_cst v) res) tbl Vect.null let choose_conflict (sol : Vect.t) (l : (var * Vect.t) list) = - let esol = Vect.set 0 (Int 1) sol in + let esol = Vect.set 0 Q.one sol in let rec most_violating l e (x, v) rst = match l with | [] -> Some ((x, v), rst) @@ -476,7 +474,7 @@ let optimise obj l = let _, vm, l' = eliminate_equalities (vr0 + 1) l in let bound pos res = match res with - | Opt (_, Max n) -> Some (if pos then n else minus_num n) + | Opt (_, Max n) -> Some (if pos then n else Q.neg n) | Opt (_, Ubnd _) -> None | Opt (_, Feas) -> None in @@ -501,9 +499,7 @@ let make_farkas_certificate (env : WithProof.t IMap.t) vm v = begin try let x', b = IMap.find x vm in - mul_cst_proof - (if b then n else Num.minus_num n) - (snd (IMap.find x' env)) + mul_cst_proof (if b then n else Q.neg n) (snd (IMap.find x' env)) with Not_found -> (* This is an introduced hypothesis *) mul_cst_proof n (snd (IMap.find x env)) @@ -517,7 +513,7 @@ let make_farkas_proof (env : WithProof.t IMap.t) vm v = begin try let x', b = IMap.find x vm in - let n = if b then n else Num.minus_num n in + let n = if b then n else Q.neg n in let prf = IMap.find x' env in WithProof.mult (Vect.cst n) prf with Not_found -> @@ -526,7 +522,7 @@ let make_farkas_proof (env : WithProof.t IMap.t) vm v = end) WithProof.zero v -let frac_num n = n -/ Num.floor_num n +let frac_num n = n -/ Q.floor n type ('a, 'b) hitkind = | Forget @@ -538,38 +534,38 @@ type ('a, 'b) hitkind = let cut env rmin sol vm (rst : Restricted.t) tbl (x, v) = let n, r = Vect.decomp_cst v in let fn = frac_num n in - if fn =/ Int 0 then Forget (* The solution is integral *) + if fn =/ Q.zero then Forget (* The solution is integral *) else (* The cut construction is from: Letchford and Lodi. Strengthening Chvatal-Gomory cuts and Gomory fractional cuts. We implement the classic Proposition 2 from the "known results" - *) + *) (* Proposition 3 requires all the variables to be restricted and is therefore not always applicable. *) (* let ccoeff_prop1 v = frac_num v in - let ccoeff_prop3 v = - (* mixed integer cut *) - let fv = frac_num v in - Num.min_num fv (fn */ (Int 1 -/ fv) // (Int 1 -/ fn)) - in - let ccoeff_prop3 = - if Restricted.is_restricted x rst then ("Prop3", ccoeff_prop3) - else ("Prop1", ccoeff_prop1) - in *) - let n0_5 = Int 1 // Int 2 in + let ccoeff_prop3 v = + (* mixed integer cut *) + let fv = frac_num v in + Num.min_num fv (fn */ (Q.one -/ fv) // (Q.one -/ fn)) + in + let ccoeff_prop3 = + if Restricted.is_restricted x rst then ("Prop3", ccoeff_prop3) + else ("Prop1", ccoeff_prop1) + in *) + let n0_5 = Q.one // Q.two in (* If the fractional part [fn] is small, we construct the t-cut. If the fractional part [fn] is big, we construct the t-cut of the negated row. (This is only a cut if all the fractional variables are restricted.) - *) + *) let ccoeff_prop2 = let tmin = if fn </ n0_5 then (* t-cut *) - Num.ceiling_num (n0_5 // fn) + Q.ceiling (n0_5 // fn) else (* multiply by -1 & t-cut *) - minus_num (Num.ceiling_num (n0_5 // (Int 1 -/ fn))) + Q.neg (Q.ceiling (n0_5 // (Q.one -/ fn))) in ("Prop2", fun v -> frac_num (v */ tmin)) in @@ -651,7 +647,7 @@ let eliminate_variable (bounded, vr, env, tbl) x = let tv = var_of_vect t in (* x = z - t *) let xdef = Vect.add z (Vect.uminus t) in - let xp = ((Vect.set x (Int 1) (Vect.uminus xdef), Eq), Def vr) in + let xp = ((Vect.set x Q.one (Vect.uminus xdef), Eq), Def vr) in let zp = ((z, Ge), Def zv) in let tp = ((t, Ge), Def tv) in (* Pivot the current tableau using xdef *) @@ -662,11 +658,8 @@ let eliminate_variable (bounded, vr, env, tbl) x = (fun lp -> let (v, o), p = lp in let ai = Vect.get x v in - if ai =/ Int 0 then lp - else - WithProof.addition - (WithProof.mult (Vect.cst (Num.minus_num ai)) xp) - lp) + if ai =/ Q.zero then lp + else WithProof.addition (WithProof.mult (Vect.cst (Q.neg ai)) xp) lp) env in (* Add the variables to the environment *) diff --git a/plugins/micromega/simplex.mli b/plugins/micromega/simplex.mli index ff672edafd..8edea2d4b2 100644 --- a/plugins/micromega/simplex.mli +++ b/plugins/micromega/simplex.mli @@ -7,6 +7,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (* * (see LICENSE file for the text of the license) *) (************************************************************************) + +open NumCompat open Polynomial (** Profiling *) @@ -23,7 +25,7 @@ val get_profile_info : unit -> profile_info (** Simplex interface *) -val optimise : Vect.t -> cstr list -> (Num.num option * Num.num option) option +val optimise : Vect.t -> cstr list -> (Q.t option * Q.t option) option val find_point : cstr list -> Vect.t option val find_unsat_certificate : cstr list -> Vect.t option diff --git a/plugins/micromega/sos.ml b/plugins/micromega/sos.ml index 772ed7a8c5..2b04bb80e2 100644 --- a/plugins/micromega/sos.ml +++ b/plugins/micromega/sos.ml @@ -9,7 +9,9 @@ (* ========================================================================= *) (* Nonlinear universal reals procedure using SOS decomposition. *) (* ========================================================================= *) -open Num + +open NumCompat +open Q.Notations open Sos_types open Sos_lib @@ -27,19 +29,19 @@ exception Sanity let decimalize = let rec normalize y = - if abs_num y </ Int 1 // Int 10 then normalize (Int 10 */ y) - 1 - else if abs_num y >=/ Int 1 then normalize (y // Int 10) + 1 + if Q.abs y </ Q.one // Q.ten then normalize (Q.ten */ y) - 1 + else if Q.abs y >=/ Q.one then normalize (y // Q.ten) + 1 else 0 in fun d x -> - if x =/ Int 0 then "0.0" + if x =/ Q.zero then "0.0" else - let y = abs_num x in + let y = Q.abs x in let e = normalize y in - let z = (pow10 (-e) */ y) +/ Int 1 in - let k = round_num (pow10 d */ z) in - (if x </ Int 0 then "-0." else "0.") - ^ implode (List.tl (explode (string_of_num k))) + let z = (Q.pow10 (-e) */ y) +/ Q.one in + let k = Q.round (Q.pow10 d */ z) in + (if x </ Q.zero then "-0." else "0.") + ^ implode (List.tl (explode (Q.to_string k))) ^ if e = 0 then "" else "e" ^ string_of_int e (* ------------------------------------------------------------------------- *) @@ -55,22 +57,22 @@ let rec iter (m, n) f a = if n < m then a else iter (m + 1, n) f (f m a) (* The main types. *) (* ------------------------------------------------------------------------- *) -type vector = int * (int, num) func -type matrix = (int * int) * (int * int, num) func +type vector = int * (int, Q.t) func +type matrix = (int * int) * (int * int, Q.t) func type monomial = (vname, int) func -type poly = (monomial, num) func +type poly = (monomial, Q.t) func (* ------------------------------------------------------------------------- *) (* Assignment avoiding zeros. *) (* ------------------------------------------------------------------------- *) -let ( |--> ) x y a = if y =/ Int 0 then a else (x |-> y) a +let ( |--> ) x y a = if y =/ Q.zero then a else (x |-> y) a (* ------------------------------------------------------------------------- *) (* This can be generic. *) (* ------------------------------------------------------------------------- *) -let element (d, v) i = tryapplyd v i (Int 0) +let element (d, v) i = tryapplyd v i Q.zero let mapa f (d, v) = (d, foldl (fun a i c -> (i |--> f c) a) undefined v) let is_zero (d, v) = match v with Empty -> true | _ -> false @@ -82,12 +84,12 @@ let vector_0 n = ((n, undefined) : vector) let dim (v : vector) = fst v let vector_const c n = - if c =/ Int 0 then vector_0 n + if c =/ Q.zero then vector_0 n else ((n, List.fold_right (fun k -> k |-> c) (1 -- n) undefined) : vector) let vector_cmul c (v : vector) = let n = dim v in - if c =/ Int 0 then vector_0 n else (n, mapf (fun x -> c */ x) (snd v)) + if c =/ Q.zero then vector_0 n else (n, mapf (fun x -> c */ x) (snd v)) let vector_of_list l = let n = List.length l in @@ -102,15 +104,15 @@ let dimensions (m : matrix) = fst m let matrix_cmul c (m : matrix) = let i, j = dimensions m in - if c =/ Int 0 then matrix_0 (i, j) + if c =/ Q.zero then matrix_0 (i, j) else ((i, j), mapf (fun x -> c */ x) (snd m)) -let matrix_neg (m : matrix) = ((dimensions m, mapf minus_num (snd m)) : matrix) +let matrix_neg (m : matrix) = ((dimensions m, mapf Q.neg (snd m)) : matrix) let matrix_add (m1 : matrix) (m2 : matrix) = let d1 = dimensions m1 and d2 = dimensions m2 in if d1 <> d2 then failwith "matrix_add: incompatible dimensions" - else ((d1, combine ( +/ ) (fun x -> x =/ Int 0) (snd m1) (snd m2)) : matrix) + else ((d1, combine ( +/ ) (fun x -> x =/ Q.zero) (snd m1) (snd m2)) : matrix) let row k (m : matrix) = let i, j = dimensions m in @@ -150,21 +152,21 @@ let monomial_variables m = dom m (* ------------------------------------------------------------------------- *) let poly_0 = (undefined : poly) let poly_isconst (p : poly) = foldl (fun a m c -> m = monomial_1 && a) true p -let poly_var x = (monomial_var x |=> Int 1 : poly) -let poly_const c = if c =/ Int 0 then poly_0 else monomial_1 |=> c +let poly_var x = (monomial_var x |=> Q.one : poly) +let poly_const c = if c =/ Q.zero then poly_0 else monomial_1 |=> c let poly_cmul c (p : poly) = - if c =/ Int 0 then poly_0 else mapf (fun x -> c */ x) p + if c =/ Q.zero then poly_0 else mapf (fun x -> c */ x) p -let poly_neg (p : poly) = (mapf minus_num p : poly) +let poly_neg (p : poly) = (mapf Q.neg p : poly) let poly_add (p1 : poly) (p2 : poly) = - (combine ( +/ ) (fun x -> x =/ Int 0) p1 p2 : poly) + (combine ( +/ ) (fun x -> x =/ Q.zero) p1 p2 : poly) let poly_sub p1 p2 = poly_add p1 (poly_neg p2) let poly_cmmul (c, m) (p : poly) = - if c =/ Int 0 then poly_0 + if c =/ Q.zero then poly_0 else if m = monomial_1 then mapf (fun d -> c */ d) p else foldl (fun a m' d -> (monomial_mul m m' |-> c */ d) a) poly_0 p @@ -174,7 +176,7 @@ let poly_mul (p1 : poly) (p2 : poly) = let poly_square p = poly_mul p p let rec poly_pow p k = - if k = 0 then poly_const (Int 1) + if k = 0 then poly_const Q.one else if k = 1 then p else let q = poly_square (poly_pow p (k / 2)) in @@ -228,9 +230,9 @@ let string_of_monomial m = String.concat "*" vps let string_of_cmonomial (c, m) = - if m = monomial_1 then string_of_num c - else if c =/ Int 1 then string_of_monomial m - else string_of_num c ^ "*" ^ string_of_monomial m + if m = monomial_1 then Q.to_string c + else if c =/ Q.one then string_of_monomial m + else Q.to_string c ^ "*" ^ string_of_monomial m let string_of_poly (p : poly) = if p = poly_0 then "<<0>>" @@ -241,7 +243,7 @@ let string_of_poly (p : poly) = let s = List.fold_left (fun a (m, c) -> - if c </ Int 0 then a ^ " - " ^ string_of_cmonomial (minus_num c, m) + if c </ Q.zero then a ^ " - " ^ string_of_cmonomial (Q.neg c, m) else a ^ " + " ^ string_of_cmonomial (c, m)) "" cms in @@ -338,21 +340,19 @@ let token s = let decimal = let ( || ) = parser_or in let numeral = some isnum in - let decimalint = atleast 1 numeral >> o Num.num_of_string implode in + let decimalint = atleast 1 numeral >> o Q.of_string implode in let decimalfrac = atleast 1 numeral - >> fun s -> Num.num_of_string (implode s) // pow10 (List.length s) + >> fun s -> Q.of_string (implode s) // Q.pow10 (List.length s) in let decimalsig = decimalint ++ possibly (a "." ++ decimalfrac >> snd) >> function h, [x] -> h +/ x | h, _ -> h in - let signed prs = - a "-" ++ prs >> o minus_num snd || a "+" ++ prs >> snd || prs - in + let signed prs = a "-" ++ prs >> o Q.neg snd || a "+" ++ prs >> snd || prs in let exponent = (a "e" || a "E") ++ signed decimalint >> snd in signed decimalsig ++ possibly exponent - >> function h, [x] -> h */ power_num (Int 10) x | h, _ -> h + >> function h, [x] -> h */ Q.power 10 x | h, _ -> h let mkparser p s = let x, rst = p (explode s) in @@ -469,19 +469,19 @@ let run_csdp dbg obj mats = let scale_then = let common_denominator amat acc = - foldl (fun a m c -> lcm_num (denominator c) a) acc amat + foldl (fun a m c -> Z.lcm (Q.den c) a) acc amat and maximal_element amat acc = - foldl (fun maxa m c -> max_num maxa (abs_num c)) acc amat + foldl (fun maxa m c -> Q.max maxa (Q.abs c)) acc amat in fun solver obj mats -> - let cd1 = List.fold_right common_denominator mats (Int 1) - and cd2 = common_denominator (snd obj) (Int 1) in + let cd1 = Q.of_bigint @@ List.fold_right common_denominator mats Z.one + and cd2 = Q.of_bigint @@ common_denominator (snd obj) Z.one in let mats' = List.map (mapf (fun x -> cd1 */ x)) mats and obj' = vector_cmul cd2 obj in - let max1 = List.fold_right maximal_element mats' (Int 0) - and max2 = maximal_element (snd obj') (Int 0) in - let scal1 = pow2 (20 - int_of_float (log (float_of_num max1) /. log 2.0)) - and scal2 = pow2 (20 - int_of_float (log (float_of_num max2) /. log 2.0)) in + let max1 = List.fold_right maximal_element mats' Q.zero + and max2 = maximal_element (snd obj') Q.zero in + let scal1 = Q.pow2 (20 - int_of_float (log (Q.to_float max1) /. log 2.0)) + and scal2 = Q.pow2 (20 - int_of_float (log (Q.to_float max2) /. log 2.0)) in let mats'' = List.map (mapf (fun x -> x */ scal1)) mats' and obj'' = vector_cmul scal2 obj' in solver obj'' mats'' @@ -490,7 +490,7 @@ let scale_then = (* Round a vector to "nice" rationals. *) (* ------------------------------------------------------------------------- *) -let nice_rational n x = round_num (n */ x) // n +let nice_rational n x = Q.round (n */ x) // n let nice_vector n = mapa (nice_rational n) (* ------------------------------------------------------------------------- *) @@ -501,7 +501,7 @@ let nice_vector n = mapa (nice_rational n) let linear_program_basic a = let m, n = dimensions a in let mats = List.map (fun j -> diagonal (column j a)) (1 -- n) - and obj = vector_const (Int 1) m in + and obj = vector_const Q.one m in let rv, res = run_csdp false obj mats in if rv = 1 || rv = 2 then false else if rv = 0 then true @@ -521,8 +521,8 @@ let in_convex_hull pts pt = let mat = ( (m, n) , itern 1 pts2 - (fun pts j -> itern 1 pts (fun x i -> (i, j) |-> Int x)) - (iter (1, n) (fun i -> (v + i, i + 1) |-> Int 1) undefined) ) + (fun pts j -> itern 1 pts (fun x i -> (i, j) |-> Q.of_int x)) + (iter (1, n) (fun i -> (v + i, i + 1) |-> Q.one) undefined) ) in linear_program_basic mat @@ -544,12 +544,14 @@ let minimal_convex_hull = (* Stuff for "equations" (generic A->num functions). *) (* ------------------------------------------------------------------------- *) -let equation_cmul c eq = if c =/ Int 0 then Empty else mapf (fun d -> c */ d) eq -let equation_add eq1 eq2 = combine ( +/ ) (fun x -> x =/ Int 0) eq1 eq2 +let equation_cmul c eq = + if c =/ Q.zero then Empty else mapf (fun d -> c */ d) eq + +let equation_add eq1 eq2 = combine ( +/ ) (fun x -> x =/ Q.zero) eq1 eq2 let equation_eval assig eq = let value v = apply assig v in - foldl (fun a v c -> a +/ (value v */ c)) (Int 0) eq + foldl (fun a v c -> a +/ (value v */ c)) Q.zero eq (* ------------------------------------------------------------------------- *) (* Eliminate all variables, in an essentially arbitrary order. *) @@ -574,11 +576,11 @@ let eliminate_all_equations one = else let v = choose_variable eq in let a = apply eq v in - let eq' = equation_cmul (Int (-1) // a) (undefine v eq) in + let eq' = equation_cmul (Q.neg_one // a) (undefine v eq) in let elim e = - let b = tryapplyd e v (Int 0) in - if b =/ Int 0 then e - else equation_add e (equation_cmul (minus_num b // a) eq) + let b = tryapplyd e v Q.zero in + if b =/ Q.zero then e + else equation_add e (equation_cmul (Q.neg b // a) eq) in eliminate ((v |-> eq') (mapf elim dun)) (List.map elim oeqs) in @@ -631,8 +633,8 @@ let diag m = if is_zero m then [] else let a11 = element m (i, i) in - if a11 </ Int 0 then failwith "diagonalize: not PSD" - else if a11 =/ Int 0 then + if a11 </ Q.zero then failwith "diagonalize: not PSD" + else if a11 =/ Q.zero then if is_zero (row i m) then diagonalize (i + 1) m else failwith "diagonalize: not PSD" else @@ -659,21 +661,23 @@ let diag m = (* ------------------------------------------------------------------------- *) let deration d = - if d = [] then (Int 0, d) + if d = [] then (Q.zero, d) else let adj (c, l) = let a = - foldl (fun a i c -> lcm_num a (denominator c)) (Int 1) (snd l) - // foldl (fun a i c -> gcd_num a (numerator c)) (Int 0) (snd l) + Q.make + (foldl (fun a i c -> Z.lcm a (Q.den c)) Z.one (snd l)) + (foldl (fun a i c -> Z.gcd a (Q.num c)) Z.zero (snd l)) in (c // (a */ a), mapa (fun x -> a */ x) l) in let d' = List.map adj d in let a = - List.fold_right (o lcm_num (o denominator fst)) d' (Int 1) - // List.fold_right (o gcd_num (o numerator fst)) d' (Int 0) + Q.make + (List.fold_right (o Z.lcm (o Q.den fst)) d' Z.one) + (List.fold_right (o Z.gcd (o Q.num fst)) d' Z.zero) in - (Int 1 // a, List.map (fun (c, l) -> (a */ c, l)) d') + (Q.one // a, List.map (fun (c, l) -> (a */ c, l)) d') (* ------------------------------------------------------------------------- *) (* Enumeration of monomials with given multidegree bound. *) @@ -702,11 +706,11 @@ let rec enumerate_monomials d vars = (* ------------------------------------------------------------------------- *) let rec enumerate_products d pols = - if d = 0 then [(poly_const num_1, Rational_lt num_1)] + if d = 0 then [(poly_const Q.one, Rational_lt Q.one)] else if d < 0 then [] else match pols with - | [] -> [(poly_const num_1, Rational_lt num_1)] + | [] -> [(poly_const Q.one, Rational_lt Q.one)] | (p, b) :: ps -> let e = multidegree p in if e = 0 then enumerate_products d ps @@ -736,7 +740,7 @@ let epoly_pmul p q acc = (* ------------------------------------------------------------------------- *) let epoly_of_poly p = - foldl (fun a m c -> (m |-> ((0, 0, 0) |=> minus_num c)) a) undefined p + foldl (fun a m c -> (m |-> ((0, 0, 0) |=> Q.neg c)) a) undefined p (* ------------------------------------------------------------------------- *) (* String for block diagonal matrix numbered k. *) @@ -796,7 +800,7 @@ let csdp nblocks blocksizes obj mats = if rv = 1 || rv = 2 then failwith "csdp: Problem is infeasible" else if rv = 3 then () (*Format.print_string "csdp warning: Reduced accuracy"; - Format.print_newline() *) + Format.print_newline() *) else if rv <> 0 then failwith ("csdp: error " ^ string_of_int rv) else (); res @@ -805,12 +809,12 @@ let csdp nblocks blocksizes obj mats = (* 3D versions of matrix operations to consider blocks separately. *) (* ------------------------------------------------------------------------- *) -let bmatrix_add = combine ( +/ ) (fun x -> x =/ Int 0) +let bmatrix_add = combine ( +/ ) (fun x -> x =/ Q.zero) let bmatrix_cmul c bm = - if c =/ Int 0 then undefined else mapf (fun x -> c */ x) bm + if c =/ Q.zero then undefined else mapf (fun x -> c */ x) bm -let bmatrix_neg = bmatrix_cmul (Int (-1)) +let bmatrix_neg = bmatrix_cmul Q.neg_one (* ------------------------------------------------------------------------- *) (* Smash a block matrix into components. *) @@ -839,7 +843,7 @@ let real_positivnullstellensatz_general linf d eqs leqs pol = in let monoid = if linf then - (poly_const num_1, Rational_lt num_1) + (poly_const Q.one, Rational_lt Q.one) :: List.filter (fun (p, c) -> multidegree p <= d) leqs else enumerate_products d leqs in @@ -850,7 +854,7 @@ let real_positivnullstellensatz_general linf d eqs leqs pol = let nons = List.combine mons (1 -- List.length mons) in ( mons , List.fold_right - (fun (m, n) -> m |-> ((-k, -n, n) |=> Int 1)) + (fun (m, n) -> m |-> ((-k, -n, n) |=> Q.one)) nons undefined ) in let mk_sqmultiplier k (p, c) = @@ -865,7 +869,7 @@ let real_positivnullstellensatz_general linf d eqs leqs pol = let m = monomial_mul m1 m2 in if n1 > n2 then a else - let c = if n1 = n2 then Int 1 else Int 2 in + let c = if n1 = n2 then Q.one else Q.two in let e = tryapplyd a m undefined in (m |-> equation_add ((k, n1, n2) |=> c) e) a) nons) @@ -889,14 +893,14 @@ let real_positivnullstellensatz_general linf d eqs leqs pol = let eqns = foldl (fun a m e -> e :: a) [] bigsum in let pvs, assig = eliminate_all_equations (0, 0, 0) eqns in let qvars = (0, 0, 0) :: pvs in - let allassig = List.fold_right (fun v -> v |-> (v |=> Int 1)) pvs assig in + let allassig = List.fold_right (fun v -> v |-> (v |=> Q.one)) pvs assig in let mk_matrix v = foldl (fun m (b, i, j) ass -> if b < 0 then m else - let c = tryapplyd ass v (Int 0) in - if c =/ Int 0 then m else ((b, j, i) |-> c) (((b, i, j) |-> c) m)) + let c = tryapplyd ass v Q.zero in + if c =/ Q.zero then m else ((b, j, i) |-> c) (((b, i, j) |-> c) m)) undefined allassig in let diagents = @@ -907,7 +911,7 @@ let real_positivnullstellensatz_general linf d eqs leqs pol = let mats = List.map mk_matrix qvars and obj = ( List.length pvs - , itern 1 pvs (fun v i -> i |--> tryapplyd diagents v (Int 0)) undefined ) + , itern 1 pvs (fun v i -> i |--> tryapplyd diagents v Q.zero) undefined ) in let raw_vec = if pvs = [] then vector_0 0 @@ -915,7 +919,7 @@ let real_positivnullstellensatz_general linf d eqs leqs pol = in let find_rounding d = if !debugging then ( - Format.print_string ("Trying rounding with limit " ^ string_of_num d); + Format.print_string ("Trying rounding with limit " ^ Q.to_string d); Format.print_newline () ) else (); let vec = nice_vector d raw_vec in @@ -930,16 +934,16 @@ let real_positivnullstellensatz_general linf d eqs leqs pol = (vec, List.map diag allmats) in let vec, ratdias = - if pvs = [] then find_rounding num_1 + if pvs = [] then find_rounding Q.one else tryfind find_rounding - (List.map Num.num_of_int (1 -- 31) @ List.map pow2 (5 -- 66)) + (List.map Q.of_int (1 -- 31) @ List.map Q.pow2 (5 -- 66)) in let newassigs = List.fold_right (fun k -> List.nth pvs (k - 1) |-> element vec k) (1 -- dim vec) - ((0, 0, 0) |=> Int (-1)) + ((0, 0, 0) |=> Q.neg_one) in let finalassigs = foldl (fun a v e -> (v |-> equation_eval newassigs e) a) newassigs allassig @@ -1017,7 +1021,7 @@ let monomial_order = let term_of_varpow x k = if k = 1 then Var x else Pow (Var x, k) let term_of_monomial m = - if m = monomial_1 then Const num_1 + if m = monomial_1 then Const Q.one else let m' = dest_monomial m in let vps = List.fold_right (fun (x, k) a -> term_of_varpow x k :: a) m' [] in @@ -1025,7 +1029,7 @@ let term_of_monomial m = let term_of_cmonomial (m, c) = if m = monomial_1 then Const c - else if c =/ num_1 then term_of_monomial m + else if c =/ Q.one then term_of_monomial m else Mul (Const c, term_of_monomial m) let term_of_poly p = @@ -1114,8 +1118,8 @@ let csdp obj mats = let rv, res = run_csdp !debugging obj mats in if rv = 1 || rv = 2 then failwith "csdp: Problem is infeasible" else if rv = 3 then () - (* (Format.print_string "csdp warning: Reduced accuracy"; - Format.print_newline()) *) + (* (Format.print_string "csdp warning: Reduced accuracy"; + Format.print_newline()) *) else if rv <> 0 then failwith ("csdp: error " ^ string_of_int rv) else (); res @@ -1162,7 +1166,7 @@ let sumofsquares_general_symmetry tool pol = match cls with | [] -> raise Sanity | [h] -> acc - | h :: t -> List.map (fun k -> (k |-> Int (-1)) (h |=> Int 1)) t @ acc + | h :: t -> List.map (fun k -> (k |-> Q.neg_one) (h |=> Q.one)) t @ acc in List.fold_right mk_eq eqvcls [] in @@ -1176,13 +1180,13 @@ let sumofsquares_general_symmetry tool pol = let m = monomial_mul m1 m2 in if n1 > n2 then f else - let c = if n1 = n2 then Int 1 else Int 2 in + let c = if n1 = n2 then Q.one else Q.two in (m |-> ((n1, n2) |-> c) (tryapplyd f m undefined)) f)) (foldl (fun a m c -> (m |-> ((0, 0) |=> c)) a) undefined pol)) @ sym_eqs in let pvs, assig = eliminate_all_equations (0, 0) eqs in - let allassig = List.fold_right (fun v -> v |-> (v |=> Int 1)) pvs assig in + let allassig = List.fold_right (fun v -> v |-> (v |=> Q.one)) pvs assig in let qvars = (0, 0) :: pvs in let diagents = end_itlist equation_add (List.map (fun i -> apply allassig (i, i)) (1 -- n)) @@ -1191,20 +1195,20 @@ let sumofsquares_general_symmetry tool pol = ( ( (n, n) , foldl (fun m (i, j) ass -> - let c = tryapplyd ass v (Int 0) in - if c =/ Int 0 then m else ((j, i) |-> c) (((i, j) |-> c) m)) + let c = tryapplyd ass v Q.zero in + if c =/ Q.zero then m else ((j, i) |-> c) (((i, j) |-> c) m)) undefined allassig ) : matrix ) in let mats = List.map mk_matrix qvars and obj = ( List.length pvs - , itern 1 pvs (fun v i -> i |--> tryapplyd diagents v (Int 0)) undefined ) + , itern 1 pvs (fun v i -> i |--> tryapplyd diagents v Q.zero) undefined ) in let raw_vec = if pvs = [] then vector_0 0 else tool obj mats in let find_rounding d = if !debugging then ( - Format.print_string ("Trying rounding with limit " ^ string_of_num d); + Format.print_string ("Trying rounding with limit " ^ Q.to_string d); Format.print_newline () ) else (); let vec = nice_vector d raw_vec in @@ -1223,7 +1227,7 @@ let sumofsquares_general_symmetry tool pol = deration (diag mat) else tryfind find_rounding - (List.map Num.num_of_int (1 -- 31) @ List.map pow2 (5 -- 66)) + (List.map Q.of_int (1 -- 31) @ List.map Q.pow2 (5 -- 66)) in let poly_of_lin (d, v) = (d, foldl (fun a i c -> (List.nth lpps (i - 1) |-> c) a) undefined (snd v)) diff --git a/plugins/micromega/sos.mli b/plugins/micromega/sos.mli index ac75bd37f0..8a461b4c20 100644 --- a/plugins/micromega/sos.mli +++ b/plugins/micromega/sos.mli @@ -8,6 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +open NumCompat open Sos_types type poly @@ -16,13 +17,10 @@ val poly_isconst : poly -> bool val poly_neg : poly -> poly val poly_mul : poly -> poly -> poly val poly_pow : poly -> int -> poly -val poly_const : Num.num -> poly +val poly_const : Q.t -> poly val poly_of_term : term -> poly val term_of_poly : poly -> term - -val term_of_sos : - positivstellensatz * (Num.num * poly) list -> positivstellensatz - +val term_of_sos : positivstellensatz * (Q.t * poly) list -> positivstellensatz val string_of_poly : poly -> string val real_positivnullstellensatz_general : @@ -31,6 +29,6 @@ val real_positivnullstellensatz_general : -> poly list -> (poly * positivstellensatz) list -> poly - -> poly list * (positivstellensatz * (Num.num * poly) list) list + -> poly list * (positivstellensatz * (Q.t * poly) list) list -val sumofsquares : poly -> Num.num * (Num.num * poly) list +val sumofsquares : poly -> Q.t * (Q.t * poly) list diff --git a/plugins/micromega/sos_lib.ml b/plugins/micromega/sos_lib.ml index 51221aa6b9..99c552e379 100644 --- a/plugins/micromega/sos_lib.ml +++ b/plugins/micromega/sos_lib.ml @@ -7,8 +7,6 @@ (* - Frédéric Besson (fbesson@irisa.fr) is using it to feed micromega *) (* ========================================================================= *) -open Num - (* ------------------------------------------------------------------------- *) (* Comparisons that are reflexive on NaN and also short-circuiting. *) (* ------------------------------------------------------------------------- *) @@ -28,32 +26,6 @@ let ( >? ) x y = cmp x y > 0 let o f g x = f (g x) (* ------------------------------------------------------------------------- *) -(* Some useful functions on "num" type. *) -(* ------------------------------------------------------------------------- *) - -let num_0 = Int 0 -and num_1 = Int 1 -and num_2 = Int 2 -and num_10 = Int 10 - -let pow2 n = power_num num_2 (Int n) -let pow10 n = power_num num_10 (Int n) - -let numdom r = - let r' = Ratio.normalize_ratio (ratio_of_num r) in - ( num_of_big_int (Ratio.numerator_ratio r') - , num_of_big_int (Ratio.denominator_ratio r') ) - -let numerator = o fst numdom -and denominator = o snd numdom - -let gcd_num n1 n2 = - num_of_big_int (Big_int.gcd_big_int (big_int_of_num n1) (big_int_of_num n2)) - -let lcm_num x y = - if x =/ num_0 && y =/ num_0 then num_0 else abs_num (x */ y // gcd_num x y) - -(* ------------------------------------------------------------------------- *) (* Various versions of list iteration. *) (* ------------------------------------------------------------------------- *) @@ -518,8 +490,8 @@ let deepen_until limit f n = let rec d_until f n = try (* if !debugging - then (print_string "Searching with depth limit "; - print_int n; print_newline()) ;*) + then (print_string "Searching with depth limit "; + print_int n; print_newline()) ;*) f n with Failure x -> (*if !debugging then (Printf.printf "solver error : %s\n" x) ; *) diff --git a/plugins/micromega/sos_lib.mli b/plugins/micromega/sos_lib.mli index 2bbcbf336b..7795808e12 100644 --- a/plugins/micromega/sos_lib.mli +++ b/plugins/micromega/sos_lib.mli @@ -9,9 +9,6 @@ (************************************************************************) val o : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b -val num_1 : Num.num -val pow10 : int -> Num.num -val pow2 : int -> Num.num val implode : string list -> string val explode : string -> string list val funpow : int -> ('a -> 'a) -> 'a -> 'a @@ -50,10 +47,6 @@ val sort : ('a -> 'a -> bool) -> 'a list -> 'a list val setify : 'a list -> 'a list val increasing : ('a -> 'b) -> 'a -> 'a -> bool val allpairs : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list -val gcd_num : Num.num -> Num.num -> Num.num -val lcm_num : Num.num -> Num.num -> Num.num -val numerator : Num.num -> Num.num -val denominator : Num.num -> Num.num val end_itlist : ('a -> 'a -> 'a) -> 'a list -> 'a val ( >> ) : ('a -> 'b * 'c) -> ('b -> 'd) -> 'a -> 'd * 'c val ( ++ ) : ('a -> 'b * 'c) -> ('c -> 'd * 'e) -> 'a -> ('b * 'd) * 'e diff --git a/plugins/micromega/sos_types.ml b/plugins/micromega/sos_types.ml index 988024968b..62699d8362 100644 --- a/plugins/micromega/sos_types.ml +++ b/plugins/micromega/sos_types.ml @@ -9,13 +9,13 @@ (************************************************************************) (* The type of positivstellensatz -- used to communicate with sos *) -open Num - type vname = string +open NumCompat + type term = | Zero - | Const of Num.num + | Const of Q.t | Var of vname | Opp of term | Add of (term * term) @@ -26,7 +26,7 @@ type term = let rec output_term o t = match t with | Zero -> output_string o "0" - | Const n -> output_string o (string_of_num n) + | Const n -> output_string o (Q.to_string n) | Var n -> Printf.fprintf o "v%s" n | Opp t -> Printf.fprintf o "- (%a)" output_term t | Add (t1, t2) -> Printf.fprintf o "(%a)+(%a)" output_term t1 output_term t2 @@ -42,9 +42,9 @@ type positivstellensatz = | Axiom_eq of int | Axiom_le of int | Axiom_lt of int - | Rational_eq of num - | Rational_le of num - | Rational_lt of num + | Rational_eq of Q.t + | Rational_le of Q.t + | Rational_lt of Q.t | Square of term | Monoid of int list | Eqmul of term * positivstellensatz @@ -55,9 +55,9 @@ let rec output_psatz o = function | Axiom_eq i -> Printf.fprintf o "Aeq(%i)" i | Axiom_le i -> Printf.fprintf o "Ale(%i)" i | Axiom_lt i -> Printf.fprintf o "Alt(%i)" i - | Rational_eq n -> Printf.fprintf o "eq(%s)" (string_of_num n) - | Rational_le n -> Printf.fprintf o "le(%s)" (string_of_num n) - | Rational_lt n -> Printf.fprintf o "lt(%s)" (string_of_num n) + | Rational_eq n -> Printf.fprintf o "eq(%s)" (Q.to_string n) + | Rational_le n -> Printf.fprintf o "le(%s)" (Q.to_string n) + | Rational_lt n -> Printf.fprintf o "lt(%s)" (Q.to_string n) | Square t -> Printf.fprintf o "(%a)^2" output_term t | Monoid l -> Printf.fprintf o "monoid" | Eqmul (t, ps) -> Printf.fprintf o "%a * %a" output_term t output_psatz ps diff --git a/plugins/micromega/sos_types.mli b/plugins/micromega/sos_types.mli index ca9a43b1d0..a0b9157880 100644 --- a/plugins/micromega/sos_types.mli +++ b/plugins/micromega/sos_types.mli @@ -8,13 +8,15 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +open NumCompat + (* The type of positivstellensatz -- used to communicate with sos *) type vname = string type term = | Zero - | Const of Num.num + | Const of Q.t | Var of vname | Opp of term | Add of (term * term) @@ -28,9 +30,9 @@ type positivstellensatz = | Axiom_eq of int | Axiom_le of int | Axiom_lt of int - | Rational_eq of Num.num - | Rational_le of Num.num - | Rational_lt of Num.num + | Rational_eq of Q.t + | Rational_le of Q.t + | Rational_lt of Q.t | Square of term | Monoid of int list | Eqmul of term * positivstellensatz diff --git a/plugins/micromega/vect.ml b/plugins/micromega/vect.ml index f53a7b42c9..198430295b 100644 --- a/plugins/micromega/vect.ml +++ b/plugins/micromega/vect.ml @@ -8,7 +8,8 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Num +open NumCompat +open Q.Notations open Mutils type var = int @@ -18,7 +19,7 @@ type var = int - values are all non-zero *) -type t = (var * num) list +type t = (var * Q.t) list type vector = t (** [equal v1 v2 = true] if the vectors are syntactically equal. *) @@ -33,32 +34,30 @@ let rec equal v1 v2 = let hash v = let rec hash i = function | [] -> i - | (vr, vl) :: l -> hash (i + Hashtbl.hash (vr, float_of_num vl)) l + | (vr, vl) :: l -> hash (i + Hashtbl.hash (vr, Q.to_float vl)) l in Hashtbl.hash (hash 0 v) let null = [] -let is_null v = match v with [] | [(0, Int 0)] -> true | _ -> false + +let is_null v = + match v with [] -> true | [(0, x)] when Q.zero =/ x -> true | _ -> false let pp_var_num pp_var o (v, n) = if Int.equal v 0 then - if eq_num (Int 0) n then () else Printf.fprintf o "%s" (string_of_num n) - else - match n with - | Int 1 -> pp_var o v - | Int -1 -> Printf.fprintf o "-%a" pp_var v - | Int 0 -> () - | _ -> Printf.fprintf o "%s*%a" (string_of_num n) pp_var v + if Q.zero =/ n then () else Printf.fprintf o "%s" (Q.to_string n) + else if Q.one =/ n then pp_var o v + else if Q.neg_one =/ n then Printf.fprintf o "-%a" pp_var v + else if Q.zero =/ n then () + else Printf.fprintf o "%s*%a" (Q.to_string n) pp_var v let pp_var_num_smt pp_var o (v, n) = if Int.equal v 0 then - if eq_num (Int 0) n then () else Printf.fprintf o "%s" (string_of_num n) - else - match n with - | Int 1 -> pp_var o v - | Int -1 -> Printf.fprintf o "(- %a)" pp_var v - | Int 0 -> () - | _ -> Printf.fprintf o "(* %s %a)" (string_of_num n) pp_var v + if Q.zero =/ n then () else Printf.fprintf o "%s" (Q.to_string n) + else if Q.one =/ n then pp_var o v + else if Q.neg_one =/ n then Printf.fprintf o "(- %a)" pp_var v + else if Q.zero =/ n then () + else Printf.fprintf o "(* %s %a)" (Q.to_string n) pp_var v let rec pp_gen pp_var o v = match v with @@ -75,36 +74,34 @@ let pp_smt o v = in Printf.fprintf o "(+ %a)" list v -let from_list (l : num list) = +let from_list (l : Q.t list) = let rec xfrom_list i l = match l with | [] -> [] | e :: l -> - if e <>/ Int 0 then (i, e) :: xfrom_list (i + 1) l + if e <>/ Q.zero then (i, e) :: xfrom_list (i + 1) l else xfrom_list (i + 1) l in xfrom_list 0 l -let zero_num = Int 0 - let to_list m = let rec xto_list i l = match l with | [] -> [] | (x, v) :: l' -> - if i = x then v :: xto_list (i + 1) l' else zero_num :: xto_list (i + 1) l + if i = x then v :: xto_list (i + 1) l' else Q.zero :: xto_list (i + 1) l in xto_list 0 m -let cons i v rst = if v =/ Int 0 then rst else (i, v) :: rst +let cons i v rst = if v =/ Q.zero then rst else (i, v) :: rst let rec update i f t = match t with - | [] -> cons i (f zero_num) [] + | [] -> cons i (f Q.zero) [] | (k, v) :: l -> ( match Int.compare i k with | 0 -> cons k (f v) l - | -1 -> cons i (f zero_num) t + | -1 -> cons i (f Q.zero) t | 1 -> (k, v) :: update i f l | _ -> failwith "compare_num" ) @@ -118,18 +115,17 @@ let rec set i n t = | 1 -> (k, v) :: set i n l | _ -> failwith "compare_num" ) -let cst n = if n =/ Int 0 then [] else [(0, n)] +let cst n = if n =/ Q.zero then [] else [(0, n)] let mul z t = - match z with - | Int 0 -> [] - | Int 1 -> t - | _ -> List.map (fun (i, n) -> (i, mult_num z n)) t + if z =/ Q.zero then [] + else if z =/ Q.one then t + else List.map (fun (i, n) -> (i, z */ n)) t let div z t = - if z <>/ Int 1 then List.map (fun (x, nx) -> (x, nx // z)) t else t + if z <>/ Q.one then List.map (fun (x, nx) -> (x, nx // z)) t else t -let uminus t = List.map (fun (i, n) -> (i, minus_num n)) t +let uminus t = List.map (fun (i, n) -> (i, Q.neg n)) t let rec add (ve1 : t) (ve2 : t) = match (ve1, ve2) with @@ -137,12 +133,12 @@ let rec add (ve1 : t) (ve2 : t) = | (v1, c1) :: l1, (v2, c2) :: l2 -> let cmp = Int.compare v1 v2 in if cmp == 0 then - let s = add_num c1 c2 in - if eq_num (Int 0) s then add l1 l2 else (v1, s) :: add l1 l2 + let s = c1 +/ c2 in + if Q.zero =/ s then add l1 l2 else (v1, s) :: add l1 l2 else if cmp < 0 then (v1, c1) :: add l1 ve2 else (v2, c2) :: add l2 ve1 -let rec xmul_add (n1 : num) (ve1 : t) (n2 : num) (ve2 : t) = +let rec xmul_add (n1 : Q.t) (ve1 : t) (n2 : Q.t) (ve2 : t) = match (ve1, ve2) with | [], _ -> mul n2 ve2 | _, [] -> mul n1 ve1 @@ -150,19 +146,19 @@ let rec xmul_add (n1 : num) (ve1 : t) (n2 : num) (ve2 : t) = let cmp = Int.compare v1 v2 in if cmp == 0 then let s = (n1 */ c1) +/ (n2 */ c2) in - if eq_num (Int 0) s then xmul_add n1 l1 n2 l2 + if Q.zero =/ s then xmul_add n1 l1 n2 l2 else (v1, s) :: xmul_add n1 l1 n2 l2 else if cmp < 0 then (v1, n1 */ c1) :: xmul_add n1 l1 n2 ve2 else (v2, n2 */ c2) :: xmul_add n1 ve1 n2 l2 let mul_add n1 ve1 n2 ve2 = - if n1 =/ Int 1 && n2 =/ Int 1 then add ve1 ve2 else xmul_add n1 ve1 n2 ve2 + if n1 =/ Q.one && n2 =/ Q.one then add ve1 ve2 else xmul_add n1 ve1 n2 ve2 let compare : t -> t -> int = Mutils.Cmp.compare_list (fun x y -> Mutils.Cmp.compare_lexical [ (fun () -> Int.compare (fst x) (fst y)) - ; (fun () -> compare_num (snd x) (snd y)) ]) + ; (fun () -> Q.compare (snd x) (snd y)) ]) (** [tail v vect] returns - [None] if [v] is not a variable of the vector [vect] @@ -181,28 +177,28 @@ let rec tail (v : var) (vect : t) = (* Hopeless *) -let get v vect = match tail v vect with None -> Int 0 | Some (vl, _) -> vl +let get v vect = match tail v vect with None -> Q.zero | Some (vl, _) -> vl let is_constant v = match v with [] | [(0, _)] -> true | _ -> false -let get_cst vect = match vect with (0, v) :: _ -> v | _ -> Int 0 +let get_cst vect = match vect with (0, v) :: _ -> v | _ -> Q.zero let choose v = match v with [] -> None | (vr, vl) :: rst -> Some (vr, vl, rst) let rec fresh v = match v with [] -> 1 | [(v, _)] -> v + 1 | _ :: v -> fresh v let variables v = List.fold_left (fun acc (x, _) -> ISet.add x acc) ISet.empty v -let decomp_cst v = match v with (0, vl) :: v -> (vl, v) | _ -> (Int 0, v) +let decomp_cst v = match v with (0, vl) :: v -> (vl, v) | _ -> (Q.zero, v) let rec decomp_at i v = match v with - | [] -> (Int 0, null) + | [] -> (Q.zero, null) | (vr, vl) :: r -> - if i = vr then (vl, r) else if i < vr then (Int 0, v) else decomp_at i r + if i = vr then (vl, r) else if i < vr then (Q.zero, v) else decomp_at i r -let decomp_fst v = match v with [] -> ((0, Int 0), []) | x :: v -> (x, v) +let decomp_fst v = match v with [] -> ((0, Q.zero), []) | x :: v -> (x, v) let rec subst (vr : int) (e : t) (v : t) = match v with | [] -> [] | (x, n) :: v' -> ( match Int.compare vr x with - | 0 -> mul_add n e (Int 1) v' + | 0 -> mul_add n e Q.one v' | -1 -> v | 1 -> add [(x, n)] (subst vr e v') | _ -> assert false ) @@ -227,25 +223,23 @@ let for_all p l = List.for_all (fun (v, n) -> p v n) l let decr_var i v = List.map (fun (v, n) -> (v - i, n)) v let incr_var i v = List.map (fun (v, n) -> (v + i, n)) v -open Big_int - let gcd v = let res = fold (fun c _ n -> - assert (Int.equal (compare_big_int (denominator n) unit_big_int) 0); - gcd_big_int c (numerator n)) - zero_big_int v + assert (Int.equal (Z.compare (Q.den n) Z.one) 0); + Z.gcd c (Q.num n)) + Z.zero v in - if Int.equal (compare_big_int res zero_big_int) 0 then unit_big_int else res + if Int.equal (Z.compare res Z.zero) 0 then Z.one else res let normalise v = - let ppcm = fold (fun c _ n -> ppcm c (denominator n)) unit_big_int v in + let ppcm = fold (fun c _ n -> Z.ppcm c (Q.den n)) Z.one v in let gcd = - let gcd = fold (fun c _ n -> gcd_big_int c (numerator n)) zero_big_int v in - if Int.equal (compare_big_int gcd zero_big_int) 0 then unit_big_int else gcd + let gcd = fold (fun c _ n -> Z.gcd c (Q.num n)) Z.zero v in + if Int.equal (Z.compare gcd Z.zero) 0 then Z.one else gcd in - List.map (fun (x, v) -> (x, v */ Big_int ppcm // Big_int gcd)) v + List.map (fun (x, v) -> (x, v */ Q.of_bigint ppcm // Q.of_bigint gcd)) v let rec exists2 p vect1 vect2 = match (vect1, vect2) with @@ -265,7 +259,7 @@ let dotproduct v1 v2 = else if x1 < x2 then dot acc v1' v2 else dot acc v1 v2' in - dot (Int 0) v1 v2 + dot Q.zero v1 v2 let map f v = List.map (fun (x, v) -> f x v) v @@ -276,18 +270,18 @@ let abs_min_elt v = Some (List.fold_left (fun (v1, vl1) (v2, vl2) -> - if abs_num vl1 </ abs_num vl2 then (v1, vl1) else (v2, vl2)) + if Q.abs vl1 </ Q.abs vl2 then (v1, vl1) else (v2, vl2)) (v, vl) r) let partition p = List.partition (fun (vr, vl) -> p vr vl) -let mkvar x = set x (Int 1) null +let mkvar x = set x Q.one null module Bound = struct - type t = {cst : num; var : var; coeff : num} + type t = {cst : Q.t; var : var; coeff : Q.t} let of_vect (v : vector) = match v with - | [(x, v)] -> if x = 0 then None else Some {cst = Int 0; var = x; coeff = v} + | [(x, v)] -> if x = 0 then None else Some {cst = Q.zero; var = x; coeff = v} | [(0, v); (x, v')] -> Some {cst = v; var = x; coeff = v'} | _ -> None end diff --git a/plugins/micromega/vect.mli b/plugins/micromega/vect.mli index 4b814cbb82..56c8ce87dd 100644 --- a/plugins/micromega/vect.mli +++ b/plugins/micromega/vect.mli @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Num +open NumCompat open Mutils type var = int @@ -50,18 +50,18 @@ val pp_smt : out_channel -> t -> unit val variables : t -> ISet.t (** [variables v] returns the set of variables with non-zero coefficients *) -val get_cst : t -> num +val get_cst : t -> Q.t (** [get_cst v] returns c i.e. the coefficient of the variable zero *) -val decomp_cst : t -> num * t +val decomp_cst : t -> Q.t * t (** [decomp_cst v] returns the pair (c,a1.x1+...+an.xn) *) -val decomp_at : int -> t -> num * t +val decomp_at : int -> t -> Q.t * t (** [decomp_cst v] returns the pair (ai, ai+1.xi+...+an.xn) *) -val decomp_fst : t -> (var * num) * t +val decomp_fst : t -> (var * Q.t) * t -val cst : num -> t +val cst : Q.t -> t (** [cst c] returns the vector v=c+0.x1+...+0.xn *) val is_constant : t -> bool @@ -74,33 +74,33 @@ val null : t val is_null : t -> bool (** [is_null v] returns whether [v] is the [null] vector i.e [equal v null] *) -val get : var -> t -> num +val get : var -> t -> Q.t (** [get xi v] returns the coefficient ai of the variable [xi]. [get] is also defined for the variable 0 *) -val set : var -> num -> t -> t +val set : var -> Q.t -> t -> t (** [set xi ai' v] returns the vector c+a1.x1+...ai'.xi+...+an.xn i.e. the coefficient of the variable xi is set to ai' *) val mkvar : var -> t (** [mkvar xi] returns 1.xi *) -val update : var -> (num -> num) -> t -> t +val update : var -> (Q.t -> Q.t) -> t -> t (** [update xi f v] returns c+a1.x1+...+f(ai).xi+...+an.xn *) val fresh : t -> int (** [fresh v] return the fresh variable with index 1+ max (variables v) *) -val choose : t -> (var * num * t) option +val choose : t -> (var * Q.t * t) option (** [choose v] decomposes a vector [v] depending on whether it is [null] or not. @return None if v is [null] @return Some(x,n,r) where v = r + n.x x is the smallest variable with non-zero coefficient n <> 0. *) -val from_list : num list -> t +val from_list : Q.t list -> t (** [from_list l] returns the vector c+a1.x1...an.xn from the list of coefficient [l=c;a1;...;an] *) -val to_list : t -> num list +val to_list : t -> Q.t list (** [to_list v] returns the list of all coefficient of the vector v i.e. [c;a1;...;an] The list representation is (obviously) not sparsed and therefore certain ai may be 0 *) @@ -114,7 +114,7 @@ val incr_var : int -> t -> t (** [incr_var i v] increments the variables of the vector [v] by the amount [i]. *) -val gcd : t -> Big_int.big_int +val gcd : t -> Z.t (** [gcd v] returns gcd(num(c),num(a1),...,num(an)) where num extracts the numerator of a rational value. *) @@ -130,17 +130,17 @@ val add : t -> t -> t @return c1+c1'+ (a1+a1').x1 + ... + (an+an').xn *) -val mul : num -> t -> t +val mul : Q.t -> t -> t (** [mul a v] is vector multiplication of vector [v] by a scalar [a]. @return a.v = a.c+a.a1.x1+...+a.an.xn *) -val mul_add : num -> t -> num -> t -> t +val mul_add : Q.t -> t -> Q.t -> t -> t (** [mul_add c1 v1 c2 v2] returns the linear combination c1.v1+c2.v2 *) val subst : int -> t -> t -> t (** [subst x v v'] replaces x by v in vector v' *) -val div : num -> t -> t +val div : Q.t -> t -> t (** [div c1 v1] returns the mutiplication by the inverse of c1 i.e (1/c1).v1 *) val uminus : t -> t @@ -148,36 +148,36 @@ val uminus : t -> t (** {1 Iterators} *) -val fold : ('acc -> var -> num -> 'acc) -> 'acc -> t -> 'acc +val fold : ('acc -> var -> Q.t -> 'acc) -> 'acc -> t -> 'acc (** [fold f acc v] returns f (f (f acc 0 c ) x1 a1 ) ... xn an *) -val fold_error : ('acc -> var -> num -> 'acc option) -> 'acc -> t -> 'acc option +val fold_error : ('acc -> var -> Q.t -> 'acc option) -> 'acc -> t -> 'acc option (** [fold_error f acc v] is the same as [fold (fun acc x i -> match acc with None -> None | Some acc' -> f acc' x i) (Some acc) v] but with early exit... *) -val find : (var -> num -> 'c option) -> t -> 'c option +val find : (var -> Q.t -> 'c option) -> t -> 'c option (** [find f v] returns the first [f xi ai] such that [f xi ai <> None]. If no such xi ai exists, it returns None *) -val for_all : (var -> num -> bool) -> t -> bool +val for_all : (var -> Q.t -> bool) -> t -> bool (** [for_all p v] returns /\_{i>=0} (f xi ai) *) -val exists2 : (num -> num -> bool) -> t -> t -> (var * num * num) option +val exists2 : (Q.t -> Q.t -> bool) -> t -> t -> (var * Q.t * Q.t) option (** [exists2 p v v'] returns Some(xi,ai,ai') if p(xi,ai,ai') holds and ai,ai' <> 0. It returns None if no such pair of coefficient exists. *) -val dotproduct : t -> t -> num +val dotproduct : t -> t -> Q.t (** [dotproduct v1 v2] is the dot product of v1 and v2. *) -val map : (var -> num -> 'a) -> t -> 'a list -val abs_min_elt : t -> (var * num) option -val partition : (var -> num -> bool) -> t -> t * t +val map : (var -> Q.t -> 'a) -> t -> 'a list +val abs_min_elt : t -> (var * Q.t) option +val partition : (var -> Q.t -> bool) -> t -> t * t module Bound : sig - type t = {cst : num; var : var; coeff : num} + type t = {cst : Q.t; var : var; coeff : Q.t} (** represents a0 + ai.xi *) val of_vect : vector -> t option diff --git a/plugins/micromega/zify.ml b/plugins/micromega/zify.ml index e71c89b4db..dd8ea2c5ba 100644 --- a/plugins/micromega/zify.ml +++ b/plugins/micromega/zify.ml @@ -12,11 +12,43 @@ open Constr open Names open Pp open Lazy +module NamedDecl = Context.Named.Declaration -(** [get_type_of] performs beta reduction ; - Is it ok for Retyping.get_type_of (Zpower_nat n q) to return (fun _ : nat => Z) q ? *) -let get_type_of env evd e = - Tacred.cbv_beta env evd (Retyping.get_type_of env evd e) +let debug = false + +(* The following [constr] are necessary for constructing the proof terms *) + +let zify str = + EConstr.of_constr + (UnivGen.constr_of_monomorphic_global + (Coqlib.lib_ref ("ZifyClasses." ^ str))) + +(* morphism like lemma *) + +let mkapp2 = lazy (zify "mkapp2") +let mkapp = lazy (zify "mkapp") +let eq_refl = lazy (zify "eq_refl") +let eq = lazy (zify "eq") +let mkrel = lazy (zify "mkrel") +let iff_refl = lazy (zify "iff_refl") +let eq_iff = lazy (zify "eq_iff") +let rew_iff = lazy (zify "rew_iff") + +(* propositional logic *) + +let op_and = lazy (zify "and") +let op_and_morph = lazy (zify "and_morph") +let op_or = lazy (zify "or") +let op_or_morph = lazy (zify "or_morph") +let op_impl_morph = lazy (zify "impl_morph") +let op_iff = lazy (zify "iff") +let op_iff_morph = lazy (zify "iff_morph") +let op_not = lazy (zify "not") +let op_not_morph = lazy (zify "not_morph") + +(* identity function *) +(*let identity = lazy (zify "identity")*) +let whd = Reductionops.clos_whd_flags CClosure.all (** [unsafe_to_constr c] returns a [Constr.t] without considering an evar_map. This is useful for calling Constr.hash *) @@ -24,6 +56,18 @@ let unsafe_to_constr = EConstr.Unsafe.to_constr let pr_constr env evd e = Printer.pr_econstr_env env evd e +let gl_pr_constr e = + let genv = Global.env () in + let evd = Evd.from_env genv in + pr_constr genv evd e + +let is_convertible env evd t1 t2 = Reductionops.(is_conv env evd t1 t2) + +(** [get_type_of] performs beta reduction ; + Is it ok for Retyping.get_type_of (Zpower_nat n q) to return (fun _ : nat => Z) q ? *) +let get_type_of env evd e = + Tacred.cbv_beta env evd (Retyping.get_type_of env evd e) + let rec find_option pred l = match l with | [] -> raise Not_found @@ -62,10 +106,7 @@ end *) let get_projections_from_constant (evd, i) = - match - EConstr.kind evd - (Reductionops.clos_whd_flags CClosure.all (Global.env ()) evd i) - with + match EConstr.kind evd (whd (Global.env ()) evd i) with | App (c, a) -> Some a | _ -> raise @@ -98,6 +139,109 @@ module EInjT = struct cstr : EConstr.t option (* forall x, pred (inj x) *) } end +(** [classify_op] classify injected operators and detect special cases. *) + +type classify_op = + | OpInj (* e.g. Z.of_nat -> \x.x *) + | OpSame (* e.g. Z.add -> Z.add *) + | OpConv (* e.g. Pos.ge == \x.y. Z.ge (Z.pos x) (Z.pos y) + \x.y. Z.pos (Pos.add x y) == \x.y. Z.add (Z.pos x) (Z.pos y) + Z.succ == (\x.x + 1) + *) + | OpOther + +(*let pp_classify_op = function + | OpInj -> Pp.str "Identity" + | OpSame -> Pp.str "Same" + | OpConv -> Pp.str "Conv" + | OpOther -> Pp.str "Other" + *) + +let name x = + Context.make_annot (Name.mk_name (Names.Id.of_string x)) Sorts.Relevant + +let mkconvert_unop i1 i2 op top = + (* fun x => inj (op x) *) + let op = + EConstr.mkLambda + ( name "x" + , i1.EInjT.source + , EConstr.mkApp (i2.EInjT.inj, [|EConstr.mkApp (op, [|EConstr.mkRel 1|])|]) + ) + in + (* fun x => top (inj x) *) + let top = + EConstr.mkLambda + ( name "x" + , i1.EInjT.source + , EConstr.mkApp + (top, [|EConstr.mkApp (i1.EInjT.inj, [|EConstr.mkRel 1|])|]) ) + in + (op, top) + +let mkconvert_binop i1 i2 i3 op top = + (* fun x y => inj (op x y) *) + let op = + EConstr.mkLambda + ( name "x" + , i1.EInjT.source + , EConstr.mkLambda + ( name "y" + , i1.EInjT.source + , EConstr.mkApp + ( i3.EInjT.inj + , [|EConstr.mkApp (op, [|EConstr.mkRel 2; EConstr.mkRel 1|])|] ) + ) ) + in + (* fun x y => top (inj x) (inj y) *) + let top = + EConstr.mkLambda + ( name "x" + , i1.EInjT.source + , EConstr.mkLambda + ( name "y" + , i2.EInjT.source + , EConstr.mkApp + ( top + , [| EConstr.mkApp (i1.EInjT.inj, [|EConstr.mkRel 2|]) + ; EConstr.mkApp (i2.EInjT.inj, [|EConstr.mkRel 1|]) |] ) ) ) + in + (op, top) + +let mkconvert_rel i r tr = + let tr = + EConstr.mkLambda + ( name "x" + , i.EInjT.source + , EConstr.mkLambda + ( name "y" + , i.EInjT.source + , EConstr.mkApp + ( tr + , [| EConstr.mkApp (i.EInjT.inj, [|EConstr.mkRel 2|]) + ; EConstr.mkApp (i.EInjT.inj, [|EConstr.mkRel 1|]) |] ) ) ) + in + (r, tr) + +(** [classify_op mkconvert op top] takes the injection [inj] for the origin operator [op] + and the destination operator [top] -- both [op] and [top] are closed terms *) +let classify_op mkconvert inj op top = + let env = Global.env () in + let evd = Evd.from_env env in + if is_convertible env evd inj op then OpInj + else if EConstr.eq_constr evd op top then OpSame + else + let op, top = mkconvert op top in + if is_convertible env evd op top then OpConv else OpOther + +(*let classify_op mkconvert tysrc op top = + let res = classify_op mkconvert tysrc op top in + Feedback.msg_debug + Pp.( + str "classify_op:" ++ gl_pr_constr op ++ str " " ++ gl_pr_constr top + ++ str " " ++ pp_classify_op res ++ fnl ()); + res + *) module EBinOpT = struct type t = { (* Op : source1 -> source2 -> source3 *) @@ -105,17 +249,23 @@ module EBinOpT = struct ; source2 : EConstr.t ; source3 : EConstr.t ; target : EConstr.t - ; inj1 : EConstr.t - ; (* InjTyp source1 target *) - inj2 : EConstr.t - ; (* InjTyp source2 target *) - inj3 : EConstr.t - ; (* InjTyp source3 target *) - tbop : EConstr.t (* TBOpInj *) } + ; inj1 : EInjT.t (* InjTyp source1 target *) + ; inj2 : EInjT.t (* InjTyp source2 target *) + ; inj3 : EInjT.t (* InjTyp source3 target *) + ; bop : EConstr.t (* BOP *) + ; tbop : EConstr.t (* TBOP *) + ; tbopinj : EConstr.t (* TBOpInj *) + ; classify_binop : classify_op } end module ECstOpT = struct - type t = {source : EConstr.t; target : EConstr.t; inj : EConstr.t} + type t = + { source : EConstr.t + ; target : EConstr.t + ; inj : EInjT.t + ; cst : EConstr.t + ; cstinj : EConstr.t + ; is_construct : bool } end module EUnOpT = struct @@ -123,28 +273,42 @@ module EUnOpT = struct { source1 : EConstr.t ; source2 : EConstr.t ; target : EConstr.t - ; inj1_t : EConstr.t - ; inj2_t : EConstr.t - ; unop : EConstr.t } + ; uop : EConstr.t + ; inj1_t : EInjT.t + ; inj2_t : EInjT.t + ; tuop : EConstr.t + ; tuopinj : EConstr.t + ; classify_unop : classify_op + ; is_construct : bool } end module EBinRelT = struct type t = - {source : EConstr.t; target : EConstr.t; inj : EConstr.t; brel : EConstr.t} + { source : EConstr.t + ; target : EConstr.t + ; inj : EInjT.t + ; brel : EConstr.t + ; tbrel : EConstr.t + ; brelinj : EConstr.t + ; classify_rel : classify_op } end module EPropBinOpT = struct - type t = EConstr.t + type t = {op : EConstr.t; op_iff : EConstr.t} end module EPropUnOpT = struct - type t = EConstr.t + type t = {op : EConstr.t; op_iff : EConstr.t} end module ESatT = struct type t = {parg1 : EConstr.t; parg2 : EConstr.t; satOK : EConstr.t} end +module ESpecT = struct + type t = {spec : EConstr.t} +end + (* Different type of declarations *) type decl_kind = | PropOp of EPropBinOpT.t decl @@ -155,16 +319,7 @@ type decl_kind = | UnOp of EUnOpT.t decl | CstOp of ECstOpT.t decl | Saturate of ESatT.t decl - -let get_decl = function - | PropOp d -> d.decl - | PropUnOp d -> d.decl - | InjTyp d -> d.decl - | BinRel d -> d.decl - | BinOp d -> d.decl - | UnOp d -> d.decl - | CstOp d -> d.decl - | Saturate d -> d.decl + | Spec of ESpecT.t decl type term_kind = Application of EConstr.constr | OtherTerm of EConstr.constr @@ -191,8 +346,10 @@ end let table = Summary.ref ~name:"zify_table" HConstr.empty let saturate = Summary.ref ~name:"zify_saturate" HConstr.empty +let specs = Summary.ref ~name:"zify_specs" HConstr.empty let table_cache = ref HConstr.empty let saturate_cache = ref HConstr.empty +let specs_cache = ref HConstr.empty (** Each type-class gives rise to a different table. They only differ on how projections are extracted. *) @@ -207,7 +364,7 @@ module EInj = struct let dest = function InjTyp x -> Some x | _ -> None let mk_elt evd i (a : EConstr.t array) = - let isid = EConstr.eq_constr evd a.(0) a.(1) in + let isid = EConstr.eq_constr_nounivs evd a.(0) a.(1) in { isid ; source = a.(0) ; target = a.(1) @@ -218,6 +375,14 @@ module EInj = struct let get_key = 0 end +let get_inj evd c = + match get_projections_from_constant (evd, c) with + | None -> + let env = Global.env () in + let t = string_of_ppcmds (pr_constr env evd c) in + failwith ("Cannot register term " ^ t) + | Some a -> EInj.mk_elt evd c a + module EBinOp = struct type elt = EBinOpT.t @@ -227,20 +392,34 @@ module EBinOp = struct let table = table let mk_elt evd i a = + let i1 = get_inj evd a.(5) in + let i2 = get_inj evd a.(6) in + let i3 = get_inj evd a.(7) in + let tbop = a.(8) in { source1 = a.(0) ; source2 = a.(1) ; source3 = a.(2) ; target = a.(3) - ; inj1 = a.(5) - ; inj2 = a.(6) - ; inj3 = a.(7) - ; tbop = a.(9) } + ; inj1 = i1 + ; inj2 = i2 + ; inj3 = i3 + ; bop = a.(4) + ; tbop = a.(8) + ; tbopinj = a.(9) + ; classify_binop = + classify_op (mkconvert_binop i1 i2 i3) i1.EInjT.inj a.(4) tbop } let get_key = 4 let cast x = BinOp x let dest = function BinOp x -> Some x | _ -> None end +(*let debug_term msg c = + let genv = Global.env () in + Feedback.msg_debug + Pp.(str msg ++ str " " ++ pr_constr genv (Evd.from_env genv) c); + c + *) module ECstOp = struct type elt = ECstOpT.t @@ -250,7 +429,15 @@ module ECstOp = struct let table = table let cast x = CstOp x let dest = function CstOp x -> Some x | _ -> None - let mk_elt evd i a = {source = a.(0); target = a.(1); inj = a.(3)} + + let mk_elt evd i a = + { source = a.(0) + ; target = a.(1) + ; inj = get_inj evd a.(3) + ; cst = a.(4) + ; cstinj = a.(5) + ; is_construct = EConstr.isConstruct evd a.(2) } + let get_key = 2 end @@ -265,12 +452,21 @@ module EUnOp = struct let dest = function UnOp x -> Some x | _ -> None let mk_elt evd i a = + let i1 = get_inj evd a.(4) in + let i2 = get_inj evd a.(5) in + let uop = a.(3) in + let tuop = a.(6) in { source1 = a.(0) ; source2 = a.(1) ; target = a.(2) - ; inj1_t = a.(4) - ; inj2_t = a.(5) - ; unop = a.(6) } + ; uop + ; inj1_t = i1 + ; inj2_t = i2 + ; tuop + ; tuopinj = a.(7) + ; is_construct = EConstr.isConstruct evd uop + ; classify_unop = classify_op (mkconvert_unop i1 i2) i1.EInjT.inj uop tuop + } let get_key = 3 end @@ -286,40 +482,48 @@ module EBinRel = struct let dest = function BinRel x -> Some x | _ -> None let mk_elt evd i a = - {source = a.(0); target = a.(1); inj = a.(3); brel = a.(4)} + let i = get_inj evd a.(3) in + let brel = a.(2) in + let tbrel = a.(4) in + { source = a.(0) + ; target = a.(1) + ; inj = get_inj evd a.(3) + ; brel + ; tbrel + ; brelinj = a.(5) + ; classify_rel = classify_op (mkconvert_rel i) i.EInjT.inj brel tbrel } let get_key = 2 end -module EPropOp = struct - type elt = EConstr.t +module EPropBinOp = struct + type elt = EPropBinOpT.t + + open EPropBinOpT let name = "PropBinOp" let table = table let cast x = PropOp x let dest = function PropOp x -> Some x | _ -> None - let mk_elt evd i a = i + let mk_elt evd i a = {op = a.(0); op_iff = a.(1)} let get_key = 0 end module EPropUnOp = struct - type elt = EConstr.t + type elt = EPropUnOpT.t + + open EPropUnOpT let name = "PropUnOp" let table = table let cast x = PropUnOp x let dest = function PropUnOp x -> Some x | _ -> None - let mk_elt evd i a = i + let mk_elt evd i a = {op = a.(0); op_iff = a.(1)} let get_key = 0 end let constr_of_term_kind = function Application c -> c | OtherTerm c -> c -let fold_declared_const f evd acc = - HConstr.fold - (fun _ (_, e) acc -> f (fst (EConstr.destConst evd (get_decl e))) acc) - !table_cache acc - module type S = sig val register : Constrexpr.constr_expr -> unit val print : unit -> unit @@ -417,118 +621,37 @@ module ESat = struct let get_key = 1 end +module ESpec = struct + open ESpecT + + type elt = ESpecT.t + + let name = "Spec" + let table = specs + let cast x = Spec x + let dest = function Spec x -> Some x | _ -> None + let mk_elt evd i a = {spec = a.(5)} + let get_key = 2 +end + module BinOp = MakeTable (EBinOp) module UnOp = MakeTable (EUnOp) module CstOp = MakeTable (ECstOp) module BinRel = MakeTable (EBinRel) -module PropOp = MakeTable (EPropOp) +module PropBinOp = MakeTable (EPropBinOp) module PropUnOp = MakeTable (EPropUnOp) module Saturate = MakeTable (ESat) +module Spec = MakeTable (ESpec) let init_cache () = table_cache := !table; - saturate_cache := !saturate - -(** The module [Spec] is used to register - the instances of [BinOpSpec], [UnOpSpec]. - They are not indexed and stored in a list. *) - -module Spec = struct - let table = Summary.ref ~name:"zify_Spec" [] - - let register_obj : Constr.constr -> Libobject.obj = - let cache_constr (_, c) = table := EConstr.of_constr c :: !table in - let subst_constr (subst, c) = Mod_subst.subst_mps subst c in - Libobject.declare_object - @@ Libobject.superglobal_object_nodischarge "register-zify-Spec" - ~cache:cache_constr ~subst:(Some subst_constr) - - let register c = - let env = Global.env () in - let evd = Evd.from_env env in - let _, c = Constrintern.interp_open_constr env evd c in - let _ = Lib.add_anonymous_leaf (register_obj (EConstr.to_constr evd c)) in - () - - let get () = !table - - let print () = - let env = Global.env () in - let evd = Evd.from_env env in - let constr_of_spec c = - let t = get_type_of env evd c in - match EConstr.kind evd t with - | App (intyp, args) -> pr_constr env evd args.(2) - | _ -> Pp.str "" - in - let l = - List.fold_left - (fun acc c -> Pp.(constr_of_spec c ++ str " " ++ acc)) - (Pp.str "") !table - in - Feedback.msg_notice l -end - -let unfold_decl evd = - let f cst acc = cst :: acc in - fold_declared_const f evd [] + saturate_cache := !saturate; + specs_cache := !specs open EInjT (** Get constr of lemma and projections in ZifyClasses. *) -let zify str = - EConstr.of_constr - (UnivGen.constr_of_monomorphic_global - (Coqlib.lib_ref ("ZifyClasses." ^ str))) - -let locate_const str = - let rf = "ZifyClasses." ^ str in - match Coqlib.lib_ref rf with - | GlobRef.ConstRef c -> c - | _ -> CErrors.anomaly Pp.(str rf ++ str " should be a constant") - -(* The following [constr] are necessary for constructing the proof terms *) -let mkapp2 = lazy (zify "mkapp2") -let mkapp = lazy (zify "mkapp") -let mkapp0 = lazy (zify "mkapp0") -let mkdp = lazy (zify "mkinjterm") -let eq_refl = lazy (zify "eq_refl") -let mkrel = lazy (zify "mkrel") -let mkprop_op = lazy (zify "mkprop_op") -let mkuprop_op = lazy (zify "mkuprop_op") -let mkdpP = lazy (zify "mkinjprop") -let iff_refl = lazy (zify "iff_refl") -let q = lazy (zify "target_prop") -let ieq = lazy (zify "injprop_ok") -let iff = lazy (zify "iff") - -(* A super-set of the previous are needed to unfold the generated proof terms. *) - -let to_unfold = - lazy - (List.rev_map locate_const - [ "source_prop" - ; "target_prop" - ; "uop_iff" - ; "op_iff" - ; "mkuprop_op" - ; "TUOp" - ; "inj_ok" - ; "TRInj" - ; "inj" - ; "source" - ; "injprop_ok" - ; "TR" - ; "TBOp" - ; "TCst" - ; "target" - ; "mkrel" - ; "mkapp2" - ; "mkapp" - ; "mkapp0" - ; "mkprop_op" ]) - (** Module [CstrTable] records terms [x] injected into [inj x] together with the corresponding type constraint. The terms are stored by side-effect during the traversal @@ -563,7 +686,10 @@ module CstrTable = struct List.iter (fun (_, (t : EConstr.types)) -> HConstr.add hyps_table t ()) (Tacmach.New.pf_hyps_types gl); - fun c -> HConstr.mem hyps_table c + fun c -> + let m = HConstr.mem hyps_table c in + if not m then HConstr.add hyps_table c (); + m in (* Add the constraint (cstr k) if it is not already present *) let gen k cstr = @@ -585,97 +711,183 @@ module CstrTable = struct Tacticals.New.tclIDTAC table) end -let mkvar red evd inj v = - ( if not red then - match inj.cstr with None -> () | Some ctr -> CstrTable.register evd v ctr ); - let iv = EConstr.mkApp (inj.inj, [|v|]) in - let iv = if red then Tacred.compute (Global.env ()) evd iv else iv in - EConstr.mkApp - ( force mkdp - , [| inj.source - ; inj.target - ; inj.inj - ; v - ; iv - ; EConstr.mkApp (force eq_refl, [|inj.target; iv|]) |] ) - -type texpr = - | Var of EInj.elt * EConstr.t - (** Var is a term that cannot be injected further *) - | Constant of EInj.elt * EConstr.t - (** Constant is a term that is solely built from constructors *) - | Injterm of EConstr.t - (** Injected is an injected term represented by a term of type [injterm] *) - -let is_constant = function Constant _ -> true | _ -> false - -let constr_of_texpr = function - | Constant (i, e) | Var (i, e) -> if i.isid then Some e else None - | _ -> None - -let inj_term_of_texpr evd = function - | Injterm e -> e - | Var (inj, e) -> mkvar false evd inj e - | Constant (inj, e) -> mkvar true evd inj e - -let mkapp2_id evd i (* InjTyp S3 T *) inj (* deriv i *) t (* S1 -> S2 -> S3 *) b - (* Binop S1 S2 S3 t ... *) dbop (* deriv b *) e1 e2 = - let default () = - let e1' = inj_term_of_texpr evd e1 in - let e2' = inj_term_of_texpr evd e2 in - EBinOpT.( - Injterm - (EConstr.mkApp - ( force mkapp2 - , [| dbop.source1 - ; dbop.source2 - ; dbop.source3 - ; dbop.target - ; t - ; dbop.inj1 - ; dbop.inj2 - ; dbop.inj3 - ; b - ; e1' - ; e2' |] ))) +type prf = + | Term (* source is built from constructors. + target = compute(inj source) + inj source == target *) + | Same (* target = source + inj source == inj target *) + | Conv of EConstr.t (* inj source == target *) + | Prf of EConstr.t * EConstr.t + +(** [eq_proof typ source target] returns (target = target : source = target) *) +let eq_proof typ source target = + EConstr.mkCast + ( EConstr.mkApp (force eq_refl, [|typ; target|]) + , DEFAULTcast + , EConstr.mkApp (force eq, [|typ; source; target|]) ) + +let interp_prf evd inj source prf = + let inj_source = + if inj.EInjT.isid then source else EConstr.mkApp (inj.EInjT.inj, [|source|]) in - if not inj.isid then default () - else - match (e1, e2) with - | Constant (_, e1), Constant (_, e2) - |Var (_, e1), Var (_, e2) - |Constant (_, e1), Var (_, e2) - |Var (_, e1), Constant (_, e2) -> - Var (inj, EConstr.mkApp (t, [|e1; e2|])) - | _, _ -> default () - -let mkapp_id evd i inj (unop, u) f e1 = - EUnOpT.( - if EConstr.eq_constr evd u.unop f then - (* Injection does nothing *) - match e1 with - | Constant (_, e) | Var (_, e) -> Var (inj, EConstr.mkApp (f, [|e|])) - | Injterm e1 -> - Injterm - (EConstr.mkApp - ( force mkapp - , [| u.source1 - ; u.source2 - ; u.target - ; f - ; u.inj1_t - ; u.inj2_t - ; unop - ; e1 |] )) + match prf with + | Term -> + let target = Tacred.compute (Global.env ()) evd inj_source in + (target, EConstr.mkApp (force eq_refl, [|inj.target; target|])) + | Same -> + (inj_source, EConstr.mkApp (force eq_refl, [|inj.target; inj_source|])) + | Conv trm -> (trm, eq_proof inj.target inj_source trm) + | Prf (target, prf) -> (target, prf) + +let pp_prf prf = + match prf with + | Term -> Pp.str "Term" + | Same -> Pp.str "Same" + | Conv t -> Pp.(str "Conv " ++ gl_pr_constr t) + | Prf (_, _) -> Pp.str "Prf " + +let interp_prf evd inj source prf = + let t, prf' = interp_prf evd inj source prf in + if debug then + Feedback.msg_debug + Pp.( + str "interp_prf " ++ gl_pr_constr inj.EInjT.inj ++ str " " + ++ gl_pr_constr source ++ str " = " ++ gl_pr_constr t ++ str " by " + ++ gl_pr_constr prf' ++ str " from " ++ pp_prf prf ++ fnl ()); + (t, prf') + +let mkvar evd inj e = + (match inj.cstr with None -> () | Some ctr -> CstrTable.register evd e ctr); + Same + +let pp_prf evd inj src prf = + let t, prf' = interp_prf evd inj src prf in + Pp.( + gl_pr_constr inj.EInjT.inj ++ str " " ++ gl_pr_constr src ++ str " = " + ++ gl_pr_constr t ++ str " by " + ++ + match prf with + | Term -> Pp.str "Term" + | Same -> Pp.str "Same" + | Conv t -> Pp.str "Conv" + | Prf (_, p) -> Pp.str "Prf " ++ gl_pr_constr p) + +let conv_of_term evd op isid arg = + Tacred.compute (Global.env ()) evd + (if isid then arg else EConstr.mkApp (op, [|arg|])) + +let app_unop evd src unop arg prf = + let cunop = unop.EUnOpT.classify_unop in + let default a' prf' = + let target = EConstr.mkApp (unop.EUnOpT.tuop, [|a'|]) in + EUnOpT.( + Prf + ( target + , EConstr.mkApp + ( force mkapp + , [| unop.source1 + ; unop.source2 + ; unop.target + ; unop.uop + ; unop.inj1_t.EInjT.inj + ; unop.inj2_t.EInjT.inj + ; unop.tuop + ; unop.tuopinj + ; arg + ; a' + ; prf' |] ) )) + in + match prf with + | Term -> ( + if unop.EUnOpT.is_construct then Term (* Keep rebuilding *) else - let e1 = inj_term_of_texpr evd e1 in - Injterm + match cunop with + | OpInj -> Conv (conv_of_term evd unop.EUnOpT.uop false arg) + | OpSame -> Same + | _ -> + let a', prf = interp_prf evd unop.EUnOpT.inj1_t arg prf in + default a' prf ) + | Same -> ( + match cunop with + | OpSame -> Same + | OpInj -> Same + | OpConv -> + Conv (EConstr.mkApp - ( force mkapp - , [|u.source1; u.source2; u.target; f; u.inj1_t; u.inj2_t; unop; e1|] - ))) - -type typed_constr = {constr : EConstr.t; typ : EConstr.t} + ( unop.EUnOpT.tuop + , [|EConstr.mkApp (unop.EUnOpT.inj1_t.EInjT.inj, [|arg|])|] )) + | OpOther -> + let a', prf' = interp_prf evd unop.EUnOpT.inj1_t arg prf in + default a' prf' ) + | Conv a' -> ( + match cunop with + | OpSame | OpConv -> Conv (EConstr.mkApp (unop.EUnOpT.tuop, [|a'|])) + | OpInj -> Conv a' + | _ -> + let a', prf = interp_prf evd unop.EUnOpT.inj1_t arg prf in + default a' prf ) + | Prf (a', prf') -> default a' prf' + +let app_unop evd src unop arg prf = + let res = app_unop evd src unop arg prf in + if debug then + Feedback.msg_debug + Pp.( + str "\napp_unop " + ++ pp_prf evd unop.EUnOpT.inj1_t arg prf + ++ str " => " + ++ pp_prf evd unop.EUnOpT.inj2_t src res); + res + +let app_binop evd src binop arg1 prf1 arg2 prf2 = + EBinOpT.( + let mkApp a1 a2 = EConstr.mkApp (binop.tbop, [|a1; a2|]) in + let to_conv inj arg = function + | Term -> conv_of_term evd inj.EInjT.inj inj.EInjT.isid arg + | Same -> + if inj.EInjT.isid then arg else EConstr.mkApp (inj.EInjT.inj, [|arg|]) + | Conv t -> t + | Prf _ -> failwith "Prf is not convertible" + in + let default a1 prf1 a2 prf2 = + let res = mkApp a1 a2 in + let prf = + EBinOpT.( + EConstr.mkApp + ( force mkapp2 + , [| binop.source1 + ; binop.source2 + ; binop.source3 + ; binop.target + ; binop.bop + ; binop.inj1.EInjT.inj + ; binop.inj2.EInjT.inj + ; binop.inj3.EInjT.inj + ; binop.tbop + ; binop.tbopinj + ; arg1 + ; a1 + ; prf1 + ; arg2 + ; a2 + ; prf2 |] )) + in + Prf (res, prf) + in + match (binop.EBinOpT.classify_binop, prf1, prf2) with + | OpSame, Same, Same -> Same + | OpSame, Term, Same | OpSame, Same, Term -> Same + | OpSame, (Term | Same | Conv _), (Term | Same | Conv _) -> + let t1 = to_conv binop.EBinOpT.inj1 arg1 prf1 in + let t2 = to_conv binop.EBinOpT.inj1 arg2 prf2 in + Conv (mkApp t1 t2) + | _, _, _ -> + let a1, prf1 = interp_prf evd binop.inj1 arg1 prf1 in + let a2, prf2 = interp_prf evd binop.inj2 arg2 prf2 in + default a1 prf1 a2 prf2) + +type typed_constr = {constr : EConstr.t; typ : EConstr.t; inj : EInjT.t} let get_injection env evd t = match snd (HConstr.find t !table_cache) with @@ -702,23 +914,68 @@ let is_prop env sigma term = let sort = Retyping.get_sort_of env sigma term in Sorts.is_prop sort -(** [get_application env evd e] expresses [e] as an application (c a) +let is_arrow env evd a p1 p2 = + is_prop env evd p1 + && is_prop + (EConstr.push_rel (Context.Rel.Declaration.LocalAssum (a, p1)) env) + evd p2 + && (a.Context.binder_name = Names.Anonymous || EConstr.Vars.noccurn evd 1 p2) + +(** [get_operator env evd e] expresses [e] as an application (c a) where c is the head symbol and [a] is the array of arguments. The function also transforms (x -> y) as (arrow x y) *) -let get_operator env evd e = - let is_arrow a p1 p2 = - is_prop env evd p1 - && is_prop - (EConstr.push_rel (Context.Rel.Declaration.LocalAssum (a, p1)) env) - evd p2 - && (a.Context.binder_name = Names.Anonymous || EConstr.Vars.noccurn evd 1 p2) - in +let get_operator barrow env evd e = match EConstr.kind evd e with - | Prod (a, p1, p2) when is_arrow a p1 p2 -> (arrow, [|p1; p2|]) + | Prod (a, p1, p2) -> + if barrow && is_arrow env evd a p1 p2 then (arrow, [|p1; p2|]) + else raise Not_found + | App (c, a) -> ( + match EConstr.kind evd c with + | Construct _ (* e.g. Z0 , Z.pos *) | Const _ (* e.g. Z.max *) | Proj _ + |Lambda _ (* e.g projections *) | Ind _ (* e.g. eq *) -> + (c, a) + | _ -> raise Not_found ) + | Construct _ -> (EConstr.whd_evar evd e, [||]) + | _ -> raise Not_found + +let decompose_app env evd e = + match EConstr.kind evd e with + | Prod (a, p1, p2) when is_arrow env evd a p1 p2 -> (arrow, [|p1; p2|]) | App (c, a) -> (c, a) - | _ -> (e, [||]) + | _ -> (EConstr.whd_evar evd e, [||]) + +type 'op propop = {op : 'op; op_constr : EConstr.t; op_iff : EConstr.t} -let is_convertible env evd k t = Reductionops.check_conv env evd k t +let mk_propop op c1 c2 = {op; op_constr = c1; op_iff = c2} + +type prop_binop = AND | OR | IFF | IMPL +type prop_unop = NOT + +type prop_op = + | BINOP of prop_binop propop * EConstr.t * EConstr.t + | UNOP of prop_unop propop * EConstr.t + | OTHEROP of EConstr.t * EConstr.t array + +let classify_prop env evd e = + match EConstr.kind evd e with + | Prod (a, p1, p2) when is_arrow env evd a p1 p2 -> + BINOP (mk_propop IMPL arrow (force op_impl_morph), p1, p2) + | App (c, a) -> ( + match Array.length a with + | 1 -> + if EConstr.eq_constr_nounivs evd (force op_not) c then + UNOP (mk_propop NOT c (force op_not_morph), a.(0)) + else OTHEROP (c, a) + | 2 -> + if EConstr.eq_constr_nounivs evd (force op_and) c then + BINOP (mk_propop AND c (force op_and_morph), a.(0), a.(1)) + else if EConstr.eq_constr_nounivs evd (force op_or) c then + BINOP (mk_propop OR c (force op_or_morph), a.(0), a.(1)) + else if EConstr.eq_constr_nounivs evd (force op_iff) c then + BINOP (mk_propop IFF c (force op_iff_morph), a.(0), a.(1)) + else OTHEROP (c, a) + | _ -> OTHEROP (c, a) ) + | _ -> OTHEROP (e, [||]) (** [match_operator env evd hd arg (t,d)] - hd is head operator of t @@ -744,223 +1001,242 @@ let match_operator env evd hd args (t, d) = | PropUnOp _ -> decomp t 1 | _ -> None ) +let pp_trans_expr env evd e res = + let {deriv = inj} = get_injection env evd e.typ in + if debug then + Feedback.msg_debug Pp.(str "\ntrans_expr " ++ pp_prf evd inj e.constr res); + res + let rec trans_expr env evd e = - (* Get the injection *) - let {decl = i; deriv = inj} = get_injection env evd e.typ in + let inj = e.inj in let e = e.constr in - if EConstr.isConstruct evd e then Constant (inj, e) (* Evaluate later *) - else - let c, a = get_operator env evd e in - try - let k, t = - find_option - (match_operator env evd c a) - (HConstr.find_all c !table_cache) + try + let c, a = get_operator false env evd e in + let k, t = + find_option (match_operator env evd c a) (HConstr.find_all c !table_cache) + in + let n = Array.length a in + match k with + | CstOp {deriv = c'} -> + ECstOpT.(if c'.is_construct then Term else Prf (c'.cst, c'.cstinj)) + | UnOp {deriv = unop} -> + let prf = + trans_expr env evd + { constr = a.(n - 1) + ; typ = unop.EUnOpT.source1 + ; inj = unop.EUnOpT.inj1_t } in - let n = Array.length a in - match k with - | CstOp {decl = c'} -> - Injterm - (EConstr.mkApp (force mkapp0, [|inj.source; inj.target; e; i; c'|])) - | UnOp {decl = unop; deriv = u} -> - let a' = - trans_expr env evd {constr = a.(n - 1); typ = u.EUnOpT.source1} - in - if is_constant a' && EConstr.isConstruct evd t then Constant (inj, e) - else mkapp_id evd i inj (unop, u) t a' - | BinOp {decl = binop; deriv = b} -> - let a0 = - trans_expr env evd {constr = a.(n - 2); typ = b.EBinOpT.source1} - in - let a1 = - trans_expr env evd {constr = a.(n - 1); typ = b.EBinOpT.source2} - in - if is_constant a0 && is_constant a1 && EConstr.isConstruct evd t then - Constant (inj, e) - else mkapp2_id evd i inj t binop b a0 a1 - | d -> Var (inj, e) - with Not_found -> Var (inj, e) + app_unop evd e unop a.(n - 1) prf + | BinOp {deriv = binop} -> + let prf1 = + trans_expr env evd + { constr = a.(n - 2) + ; typ = binop.EBinOpT.source1 + ; inj = binop.EBinOpT.inj1 } + in + let prf2 = + trans_expr env evd + { constr = a.(n - 1) + ; typ = binop.EBinOpT.source2 + ; inj = binop.EBinOpT.inj2 } + in + app_binop evd e binop a.(n - 2) prf1 a.(n - 1) prf2 + | d -> mkvar evd inj e + with Not_found -> + (* Feedback.msg_debug + Pp.(str "Not found " ++ Termops.Internal.debug_print_constr e); *) + mkvar evd inj e let trans_expr env evd e = - try trans_expr env evd e + try pp_trans_expr env evd e (trans_expr env evd e) with Not_found -> raise (CErrors.user_err ( Pp.str "Missing injection for type " ++ Printer.pr_leconstr_env env evd e.typ )) -type tprop = - | TProp of EConstr.t (** Transformed proposition *) - | IProp of EConstr.t (** Identical proposition *) - -let mk_iprop e = - EConstr.mkApp (force mkdpP, [|e; e; EConstr.mkApp (force iff_refl, [|e|])|]) - -let inj_prop_of_tprop = function TProp p -> p | IProp e -> mk_iprop e +type prfp = + | TProof of EConstr.t * EConstr.t (** Proof of tranformed proposition *) + | CProof of EConstr.t (** Transformed proposition is convertible *) + | IProof (** Transformed proposition is identical *) + +let pp_prfp = function + | TProof (t, prf) -> + Pp.str "TProof " ++ gl_pr_constr t ++ Pp.str " by " ++ gl_pr_constr prf + | CProof t -> Pp.str "CProof " ++ gl_pr_constr t + | IProof -> Pp.str "IProof" + +let trans_binrel evd src rop a1 prf1 a2 prf2 = + EBinRelT.( + match (rop.classify_rel, prf1, prf2) with + | OpSame, Same, Same -> IProof + | (OpSame | OpConv), Conv t1, Conv t2 -> + CProof (EConstr.mkApp (rop.tbrel, [|t1; t2|])) + | (OpSame | OpConv), (Same | Term | Conv _), (Same | Term | Conv _) -> + let a1', _ = interp_prf evd rop.inj a1 prf1 in + let a2', _ = interp_prf evd rop.inj a2 prf2 in + CProof (EConstr.mkApp (rop.tbrel, [|a1'; a2'|])) + | _, _, _ -> + let a1', prf1 = interp_prf evd rop.inj a1 prf1 in + let a2', prf2 = interp_prf evd rop.inj a2 prf2 in + TProof + ( EConstr.mkApp (rop.EBinRelT.tbrel, [|a1'; a2'|]) + , EConstr.mkApp + ( force mkrel + , [| rop.source + ; rop.target + ; rop.brel + ; rop.EBinRelT.inj.EInjT.inj + ; rop.EBinRelT.tbrel + ; rop.EBinRelT.brelinj + ; a1 + ; a1' + ; prf1 + ; a2 + ; a2' + ; prf2 |] ) )) + +let trans_binrel evd src rop a1 prf1 a2 prf2 = + let res = trans_binrel evd src rop a1 prf1 a2 prf2 in + if debug then Feedback.msg_debug Pp.(str "\ntrans_binrel " ++ pp_prfp res); + res + +let mkprf t p = + EConstr.( + match p with + | IProof -> (t, mkApp (force iff_refl, [|t|])) + | CProof t' -> (t', mkApp (force eq_iff, [|t; t'; eq_proof mkProp t t'|])) + | TProof (t', p) -> (t', p)) + +let mkprf t p = + let t', p = mkprf t p in + if debug then + Feedback.msg_debug + Pp.( + str "mkprf " ++ gl_pr_constr t ++ str " <-> " ++ gl_pr_constr t' + ++ str " by " ++ gl_pr_constr p); + (t', p) + +let trans_bin_prop op_constr op_iff t1 p1 t2 p2 = + match (p1, p2) with + | IProof, IProof -> IProof + | CProof t1', IProof -> CProof (EConstr.mkApp (op_constr, [|t1'; t2|])) + | IProof, CProof t2' -> CProof (EConstr.mkApp (op_constr, [|t1; t2'|])) + | CProof t1', CProof t2' -> CProof (EConstr.mkApp (op_constr, [|t1'; t2'|])) + | _, _ -> + let t1', p1 = mkprf t1 p1 in + let t2', p2 = mkprf t2 p2 in + TProof + ( EConstr.mkApp (op_constr, [|t1'; t2'|]) + , EConstr.mkApp (op_iff, [|t1; t2; t1'; t2'; p1; p2|]) ) + +let trans_bin_prop op_constr op_iff t1 p1 t2 p2 = + let prf = trans_bin_prop op_constr op_iff t1 p1 t2 p2 in + if debug then Feedback.msg_debug (pp_prfp prf); + prf + +let trans_un_prop op_constr op_iff p1 prf1 = + match prf1 with + | IProof -> IProof + | CProof p1' -> CProof (EConstr.mkApp (op_constr, [|p1'|])) + | TProof (p1', prf) -> + TProof + ( EConstr.mkApp (op_constr, [|p1'|]) + , EConstr.mkApp (op_iff, [|p1; p1'; prf|]) ) let rec trans_prop env evd e = - let c, a = get_operator env evd e in - try - let k, t = - find_option (match_operator env evd c a) (HConstr.find_all c !table_cache) - in - let n = Array.length a in - match k with - | PropOp {decl = rop} -> ( - try - let t1 = trans_prop env evd a.(n - 2) in - let t2 = trans_prop env evd a.(n - 1) in - match (t1, t2) with - | IProp _, IProp _ -> IProp e - | _, _ -> - let t1 = inj_prop_of_tprop t1 in - let t2 = inj_prop_of_tprop t2 in - TProp (EConstr.mkApp (force mkprop_op, [|t; rop; t1; t2|])) - with Not_found -> IProp e ) - | BinRel {decl = br; deriv = rop} -> ( - try + match classify_prop env evd e with + | BINOP ({op_constr; op_iff}, p1, p2) -> + let prf1 = trans_prop env evd p1 in + let prf2 = trans_prop env evd p2 in + trans_bin_prop op_constr op_iff p1 prf1 p2 prf2 + | UNOP ({op_constr; op_iff}, p1) -> + let prf1 = trans_prop env evd p1 in + trans_un_prop op_constr op_iff p1 prf1 + | OTHEROP (c, a) -> ( + try + let k, t = + find_option + (match_operator env evd c a) + (HConstr.find_all c !table_cache) + in + let n = Array.length a in + match k with + | BinRel {decl = br; deriv = rop} -> let a1 = - trans_expr env evd {constr = a.(n - 2); typ = rop.EBinRelT.source} + trans_expr env evd + { constr = a.(n - 2) + ; typ = rop.EBinRelT.source + ; inj = rop.EBinRelT.inj } in let a2 = - trans_expr env evd {constr = a.(n - 1); typ = rop.EBinRelT.source} + trans_expr env evd + { constr = a.(n - 1) + ; typ = rop.EBinRelT.source + ; inj = rop.EBinRelT.inj } in - if EConstr.eq_constr evd t rop.EBinRelT.brel then - match (constr_of_texpr a1, constr_of_texpr a2) with - | Some e1, Some e2 -> IProp (EConstr.mkApp (t, [|e1; e2|])) - | _, _ -> - let a1 = inj_term_of_texpr evd a1 in - let a2 = inj_term_of_texpr evd a2 in - TProp - (EConstr.mkApp - ( force mkrel - , [| rop.EBinRelT.source - ; rop.EBinRelT.target - ; t - ; rop.EBinRelT.inj - ; br - ; a1 - ; a2 |] )) - else - let a1 = inj_term_of_texpr evd a1 in - let a2 = inj_term_of_texpr evd a2 in - TProp - (EConstr.mkApp - ( force mkrel - , [| rop.EBinRelT.source - ; rop.EBinRelT.target - ; t - ; rop.EBinRelT.inj - ; br - ; a1 - ; a2 |] )) - with Not_found -> IProp e ) - | PropUnOp {decl = rop} -> ( - try - let t1 = trans_prop env evd a.(n - 1) in - match t1 with - | IProp _ -> IProp e - | _ -> - let t1 = inj_prop_of_tprop t1 in - TProp (EConstr.mkApp (force mkuprop_op, [|t; rop; t1|])) - with Not_found -> IProp e ) - | _ -> IProp e - with Not_found -> IProp e - -let unfold n env evd c = - let cbv l = - CClosure.RedFlags.( - Tacred.cbv_norm_flags - (mkflags - (fBETA :: fMATCH :: fFIX :: fCOFIX :: fZETA :: List.rev_map fCONST l))) - in - let unfold_decl = unfold_decl evd in - (* Unfold the let binding *) - let c = - match n with - | None -> c - | Some n -> - Tacred.unfoldn [(Locus.AllOccurrences, Names.EvalVarRef n)] env evd c - in - (* Reduce the term *) - let c = cbv (List.rev_append (force to_unfold) unfold_decl) env evd c in - c + trans_binrel evd e rop a.(n - 2) a1 a.(n - 1) a2 + | _ -> IProof + with Not_found -> IProof ) let trans_check_prop env evd t = - if is_prop env evd t then - (*let t = Tacred.unfoldn [Locus.AllOccurrences, Names.EvalConstRef coq_not] env evd t in*) - match trans_prop env evd t with IProp e -> None | TProp e -> Some e - else None + if is_prop env evd t then Some (trans_prop env evd t) else None + +let get_hyp_typ = function + | NamedDecl.LocalDef (h, _, ty) | NamedDecl.LocalAssum (h, ty) -> + (h.Context.binder_name, EConstr.of_constr ty) let trans_hyps env evd l = List.fold_left - (fun acc (h, p) -> - match trans_check_prop env evd p with + (fun acc decl -> + let h, ty = get_hyp_typ decl in + match trans_check_prop env evd ty with | None -> acc - | Some p' -> (h, p, p') :: acc) - [] (List.rev l) - -(* Only used if a direct rewrite fails *) -let trans_hyp h t = - Tactics.( + | Some p' -> (h, ty, p') :: acc) + [] l + +let trans_hyp h t0 prfp = + if debug then + Feedback.msg_debug Pp.(str "trans_hyp: " ++ pp_prfp prfp ++ fnl ()); + match prfp with + | IProof -> Tacticals.New.tclIDTAC (* Should detect before *) + | CProof t' -> + Proofview.Goal.enter (fun gl -> + let env = Tacmach.New.pf_env gl in + let evd = Tacmach.New.project gl in + let t' = Reductionops.nf_betaiota env evd t' in + Tactics.change_in_hyp ~check:true None + (Tactics.make_change_arg t') + (h, Locus.InHypTypeOnly)) + | TProof (t', prf) -> Tacticals.New.( Proofview.Goal.enter (fun gl -> let env = Tacmach.New.pf_env gl in - let n = - fresh_id_in_env Id.Set.empty (Names.Id.of_string "__zify") env + let evd = Tacmach.New.project gl in + let target = Reductionops.nf_betaiota env evd t' in + let h' = Tactics.fresh_id_in_env Id.Set.empty h env in + let prf = + EConstr.mkApp (force rew_iff, [|t0; target; prf; EConstr.mkVar h|]) in - let h' = fresh_id_in_env Id.Set.empty h env in - tclTHENLIST - [ letin_tac None (Names.Name n) t None - Locus.{onhyps = None; concl_occs = NoOccurrences} - ; assert_by (Name.Name h') - (EConstr.mkApp (force q, [|EConstr.mkVar n|])) - (tclTHEN - (Equality.rewriteRL - (EConstr.mkApp (force ieq, [|EConstr.mkVar n|]))) - (exact_check (EConstr.mkVar h))) - ; reduct_in_hyp ~check:true ~reorder:false (unfold (Some n)) - (h', Locus.InHyp) - ; clear [n] - ; (* [clear H] may fail if [h] has dependencies *) - tclTRY (clear [h]) ]))) - -let is_progress_rewrite evd t rew = - match EConstr.kind evd rew with - | App (c, [|lhs; rhs|]) -> - if EConstr.eq_constr evd (force iff) c then - (* This is a successful rewriting *) - not (EConstr.eq_constr evd lhs rhs) - else - CErrors.anomaly - Pp.( - str "is_progress_rewrite: not a rewrite" - ++ pr_constr (Global.env ()) evd rew) - | _ -> failwith "is_progress_rewrite: not even an application" - -let trans_hyp h t0 t = - Tacticals.New.( + tclTHEN + (Tactics.pose_proof (Name.Name h') prf) + (tclTRY + (tclTHEN (Tactics.clear [h]) (Tactics.rename_hyp [(h', h)]))))) + +let trans_concl prfp = + if debug then + Feedback.msg_debug Pp.(str "trans_concl: " ++ pp_prfp prfp ++ fnl ()); + match prfp with + | IProof -> Tacticals.New.tclIDTAC + | CProof t -> Proofview.Goal.enter (fun gl -> let env = Tacmach.New.pf_env gl in let evd = Tacmach.New.project gl in - let t' = unfold None env evd (EConstr.mkApp (force ieq, [|t|])) in - if is_progress_rewrite evd t0 (get_type_of env evd t') then - tclFIRST - [ Equality.general_rewrite_in true Locus.AllOccurrences true false h - t' false - ; trans_hyp h t ] - else tclIDTAC)) - -let trans_concl t = - Tacticals.New.( + let t' = Reductionops.nf_betaiota env evd t in + Tactics.change_concl t') + | TProof (t, prf) -> Proofview.Goal.enter (fun gl -> - let concl = Tacmach.New.pf_concl gl in - let env = Tacmach.New.pf_env gl in - let evd = Tacmach.New.project gl in - let t' = unfold None env evd (EConstr.mkApp (force ieq, [|t|])) in - if is_progress_rewrite evd concl (get_type_of env evd t') then - Equality.general_rewrite true Locus.AllOccurrences true false t' - else tclIDTAC)) + Equality.general_rewrite true Locus.AllOccurrences true false prf) let tclTHENOpt e tac tac' = match e with None -> tac' | Some e' -> Tacticals.New.tclTHEN (tac e') tac' @@ -976,6 +1252,16 @@ let assert_inj t = with Not_found -> Tacticals.New.tclFAIL 0 (Pp.str " InjTyp does not exist")) +let elim_binding x t ty = + Proofview.Goal.enter (fun gl -> + let env = Tacmach.New.pf_env gl in + let h = + Tactics.fresh_id_in_env Id.Set.empty (Nameops.add_prefix "heq_" x) env + in + Tacticals.New.tclTHEN + (Tactics.pose_proof (Name h) (eq_proof ty (EConstr.mkVar x) t)) + (Tacticals.New.tclTRY (Tactics.clear_body [x]))) + let do_let tac (h : Constr.named_declaration) = match h with | Context.Named.Declaration.LocalAssum _ -> Tacticals.New.tclIDTAC @@ -985,22 +1271,25 @@ let do_let tac (h : Constr.named_declaration) = let evd = Tacmach.New.project gl in try ignore (get_injection env evd (EConstr.of_constr ty)); - tac id.Context.binder_name t ty + tac id.Context.binder_name (EConstr.of_constr t) + (EConstr.of_constr ty) with Not_found -> Tacticals.New.tclIDTAC) -let iter_let tac = +let iter_let_aux tac = Proofview.Goal.enter (fun gl -> let env = Tacmach.New.pf_env gl in let sign = Environ.named_context env in + init_cache (); Tacticals.New.tclMAP (do_let tac) sign) let iter_let (tac : Ltac_plugin.Tacinterp.Value.t) = - init_cache (); - iter_let (fun (id : Names.Id.t) (t : Constr.types) (ty : Constr.types) -> + iter_let_aux (fun (id : Names.Id.t) t ty -> Ltac_plugin.Tacinterp.Value.apply tac [ Ltac_plugin.Tacinterp.Value.of_constr (EConstr.mkVar id) - ; Ltac_plugin.Tacinterp.Value.of_constr (EConstr.of_constr t) - ; Ltac_plugin.Tacinterp.Value.of_constr (EConstr.of_constr ty) ]) + ; Ltac_plugin.Tacinterp.Value.of_constr t + ; Ltac_plugin.Tacinterp.Value.of_constr ty ]) + +let elim_let = iter_let_aux elim_binding let zify_tac = Proofview.Goal.enter (fun gl -> @@ -1009,8 +1298,9 @@ let zify_tac = init_cache (); let evd = Tacmach.New.project gl in let env = Tacmach.New.pf_env gl in + let sign = Environ.named_context env in let concl = trans_check_prop env evd (Tacmach.New.pf_concl gl) in - let hyps = trans_hyps env evd (Tacmach.New.pf_hyps_types gl) in + let hyps = trans_hyps env evd sign in let l = CstrTable.get () in tclTHENOpt concl trans_concl (Tacticals.New.tclTHEN @@ -1018,14 +1308,101 @@ let zify_tac = (List.rev_map (fun (h, p, t) -> trans_hyp h p t) hyps)) (CstrTable.gen_cstr l))) -let iter_specs tac = - Tacticals.New.tclTHENLIST - (List.fold_left (fun acc d -> tac d :: acc) [] (Spec.get ())) +type pscript = Set of Names.Id.t * EConstr.t | Pose of Names.Id.t * EConstr.t + +type spec_env = + { map : Names.Id.t HConstr.t + ; spec_name : Names.Id.t + ; term_name : Names.Id.t + ; fresh : Nameops.Subscript.t + ; proofs : pscript list } + +let register_constr {map; spec_name; term_name; fresh; proofs} c thm = + let tname = Nameops.add_subscript term_name fresh in + let sname = Nameops.add_subscript spec_name fresh in + ( EConstr.mkVar tname + , { map = HConstr.add c tname map + ; spec_name + ; term_name + ; fresh = Nameops.Subscript.succ fresh + ; proofs = Set (tname, c) :: Pose (sname, thm) :: proofs } ) + +let fresh_subscript env = + let ctx = (Environ.named_context_val env).Environ.env_named_map in + Nameops.Subscript.succ + (Names.Id.Map.fold + (fun id _ s -> + let _, s' = Nameops.get_subscript id in + let cmp = Nameops.Subscript.compare s s' in + if cmp = 0 then s else if cmp < 0 then s' else s) + ctx Nameops.Subscript.zero) + +let init_env sname tname s = + { map = HConstr.empty + ; spec_name = sname + ; term_name = tname + ; fresh = s + ; proofs = [] } + +let rec spec_of_term env evd (senv : spec_env) t = + let get_name t env = + try EConstr.mkVar (HConstr.find t senv.map) with Not_found -> t + in + let c, a = decompose_app env evd t in + if a = [||] then (* The term cannot be decomposed. *) + (get_name t senv, senv) + else + (* recursively analyse the sub-terms *) + let a', senv' = + Array.fold_right + (fun e (l, senv) -> + let r, senv = spec_of_term env evd senv e in + (r :: l, senv)) + a ([], senv) + in + let a' = Array.of_list a' in + let t' = EConstr.mkApp (c, a') in + try (EConstr.mkVar (HConstr.find t' senv'.map), senv') + with Not_found -> ( + try + match snd (HConstr.find c !specs_cache) with + | Spec s -> + let thm = EConstr.mkApp (s.deriv.ESpecT.spec, a') in + register_constr senv' t' thm + | _ -> (get_name t' senv', senv') + with Not_found -> (t', senv') ) + +let interp_pscript s = + match s with + | Set (id, c) -> + Tacticals.New.tclTHEN + (Tactics.letin_tac None (Names.Name id) c None + {Locus.onhyps = None; Locus.concl_occs = Locus.AllOccurrences}) + (Tactics.clear_body [id]) + | Pose (id, c) -> Tactics.pose_proof (Names.Name id) c + +let rec interp_pscripts l = + match l with + | [] -> Tacticals.New.tclIDTAC + | s :: l -> Tacticals.New.tclTHEN (interp_pscript s) (interp_pscripts l) -let iter_specs (tac : Ltac_plugin.Tacinterp.Value.t) = - iter_specs (fun c -> - Ltac_plugin.Tacinterp.Value.apply tac - [Ltac_plugin.Tacinterp.Value.of_constr c]) +let spec_of_hyps = + Proofview.Goal.enter (fun gl -> + let terms = + Tacmach.New.pf_concl gl :: List.map snd (Tacmach.New.pf_hyps_types gl) + in + let env = Tacmach.New.pf_env gl in + let evd = Tacmach.New.project gl in + let s = fresh_subscript env in + let env = + List.fold_left + (fun acc t -> snd (spec_of_term env evd acc t)) + (init_env (Names.Id.of_string "H") (Names.Id.of_string "z") s) + terms + in + interp_pscripts (List.rev env.proofs)) + +let iter_specs = spec_of_hyps let find_hyp evd t l = try Some (fst (List.find (fun (h, t') -> EConstr.eq_constr evd t t') l)) diff --git a/plugins/micromega/zify.mli b/plugins/micromega/zify.mli index 4930a845c9..2cec9d6f91 100644 --- a/plugins/micromega/zify.mli +++ b/plugins/micromega/zify.mli @@ -19,13 +19,14 @@ module UnOp : S module BinOp : S module CstOp : S module BinRel : S -module PropOp : S +module PropBinOp : S module PropUnOp : S module Spec : S module Saturate : S val zify_tac : unit Proofview.tactic val saturate : unit Proofview.tactic -val iter_specs : Ltac_plugin.Tacinterp.Value.t -> unit Proofview.tactic +val iter_specs : unit Proofview.tactic val assert_inj : EConstr.constr -> unit Proofview.tactic val iter_let : Ltac_plugin.Tacinterp.Value.t -> unit Proofview.tactic +val elim_let : unit Proofview.tactic diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index f95672a15d..6ff79ebb9b 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -1095,11 +1095,11 @@ let tclDO n tac = try tac gl with | CErrors.UserError (l, s) as e -> - let _, info = CErrors.push e in - let e' = CErrors.UserError (l, prefix i ++ s) in - Util.iraise (e', info) + let _, info = Exninfo.capture e in + let e' = CErrors.UserError (l, prefix i ++ s) in + Exninfo.iraise (e', info) | Gramlib.Ploc.Exc(loc, CErrors.UserError (l, s)) -> - raise (Gramlib.Ploc.Exc(loc, CErrors.UserError (l, prefix i ++ s))) in + raise (Gramlib.Ploc.Exc(loc, CErrors.UserError (l, prefix i ++ s))) in let rec loop i gl = if i = n then tac_err_at i gl else (tclTHEN (tac_err_at i) (loop (i + 1))) gl in diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index f6fbdaa958..fa824a88ee 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -134,7 +134,7 @@ let r_of_rawnum ?loc (sign,n) = | '+' -> Bigint.of_string (String.sub e 2 (String.length e - 2)) | '-' -> Bigint.(neg (of_string (String.sub e 2 (String.length e - 2)))) | _ -> Bigint.of_string (String.sub e 1 (String.length e - 1)) in - Bigint.(sub e (of_int (String.length f))) in + Bigint.(sub e (of_int (String.length (String.concat "" (String.split_on_char '_' f))))) in if Bigint.is_strictly_pos e then rmult n (izr (pow10 e)) else if Bigint.is_strictly_neg e then rdiv n (izr (pow10 (neg e))) else n (* e = 0 *) diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 55c1f41c2c..afe776dced 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -73,11 +73,11 @@ let error_wrong_numarg_inductive ?loc env c n = let list_try_compile f l = let rec aux errors = function - | [] -> if errors = [] then anomaly (str "try_find_f.") else iraise (List.last errors) + | [] -> if errors = [] then anomaly (str "try_find_f.") else Exninfo.iraise (List.last errors) | h::t -> try f h with UserError _ | TypeError _ | PretypeError _ | PatternMatchingError _ as e -> - let e = CErrors.push e in + let e = Exninfo.capture e in aux (e::errors) t in aux [] l diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index aafd662f7d..c9ccd668ca 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -78,9 +78,9 @@ let get_polymorphic_positions env sigma f = match EConstr.kind sigma f with | Ind (ind, u) | Construct ((ind, _), u) -> let mib,oib = Inductive.lookup_mind_specif env ind in - (match oib.mind_arity with - | RegularArity _ -> assert false - | TemplateArity templ -> templ.template_param_levels) + (match mib.mind_template with + | None -> assert false + | Some templ -> templ.template_param_levels) | _ -> assert false let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) ?(refreshset=false) diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index a4406aeba1..01994a35c7 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -681,13 +681,17 @@ let type_of_inductive_knowing_conclusion env sigma ((mib,mip),u) conclty = match mip.mind_arity with | RegularArity s -> sigma, EConstr.of_constr (subst_instance_constr u s.mind_user_arity) | TemplateArity ar -> + let templ = match mib.mind_template with + | None -> assert false + | Some t -> t + in let _,scl = splay_arity env sigma conclty in let scl = EConstr.ESorts.kind sigma scl in let ctx = List.rev mip.mind_arity_ctxt in let evdref = ref sigma in let ctx = instantiate_universes - env evdref scl ar.template_level (ctx,ar.template_param_levels) in + env evdref scl ar.template_level (ctx,templ.template_param_levels) in !evdref, EConstr.of_constr (mkArity (List.rev ctx,scl)) let type_of_projection_constant env (p,u) = diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index ac1a4e88ef..1269488af3 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -87,9 +87,9 @@ let search_guard ?loc env possible_indexes fixdefs = let fix = ((indexes, 0),fixdefs) in (try check_fix env fix with reraise -> - let (e, info) = CErrors.push reraise in + let (e, info) = Exninfo.capture reraise in let info = Option.cata (fun loc -> Loc.add_loc info loc) info loc in - iraise (e, info)); + Exninfo.iraise (e, info)); indexes else (* we now search recursively among all combinations *) @@ -266,8 +266,8 @@ let apply_heuristics env sigma fail_evar = let flags = default_flags_of (Typeclasses.classes_transparent_state ()) in try solve_unif_constraints_with_heuristics ~flags env sigma with e when CErrors.noncritical e -> - let e = CErrors.push e in - if fail_evar then iraise e else sigma + let e = Exninfo.capture e in + if fail_evar then Exninfo.iraise e else sigma let check_typeclasses_instances_are_solved ~program_mode env current_sigma frozen = (* Naive way, call resolution again with failure flag *) @@ -753,9 +753,9 @@ struct let cofix = (i, fixdecls) in (try check_cofix !!env (i, nf_fix sigma fixdecls) with reraise -> - let (e, info) = CErrors.push reraise in + let (e, info) = Exninfo.capture reraise in let info = Option.cata (Loc.add_loc info) info loc in - iraise (e, info)); + Exninfo.iraise (e, info)); make_judge (mkCoFix cofix) ftys.(i) in discard_trace @@ inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma fixj tycon @@ -946,9 +946,9 @@ struct try judge_of_product !!env name j j' with TypeError _ as e -> - let (e, info) = CErrors.push e in + let (e, info) = Exninfo.capture e in let info = Option.cata (Loc.add_loc info) info loc in - iraise (e, info) in + Exninfo.iraise (e, info) in discard_trace @@ inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma resj tycon let pretype_letin self (name, c1, t, c2) = diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 98eb33273f..b07ae8788a 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -1465,7 +1465,7 @@ let report_anomaly (e, info) = UserError (None, msg) else e in - iraise (e, info) + Exninfo.iraise (e, info) let f_conv ?l2r ?reds env ?evars x y = let inj = EConstr.Unsafe.to_constr in diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 4afed07eda..fdf0db9909 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -1009,11 +1009,11 @@ let change_map_constr_with_binders_left_to_right g f (env, l as acc) sigma c = let app = (mkApp (hdf, Array.sub al 0 (Array.length al - 1))) in let app' = f acc app in let a' = f acc a in - (match EConstr.kind sigma app' with - | App (hdf', al') when hdf' == hdf -> - (* Still the same projection, we ignore the change in parameters *) - mkProj (p, a') - | _ -> mkApp (app', [| a' |])) + let hdf', _ = decompose_app_vect sigma app' in + if hdf' == hdf then + (* Still the same projection, we ignore the change in parameters *) + mkProj (p, a') + else mkApp (app', [| a' |]) | _ -> map_constr_with_binders_left_to_right sigma g f acc c let e_contextually byhead (occs,c) f = begin fun env sigma t -> diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 5b87603d54..1df377b20e 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -1149,10 +1149,9 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e if !debug_unification then Feedback.msg_debug (str "Leaving unification with success"); a with e -> - let e = CErrors.push e in + let e = Exninfo.capture e in if !debug_unification then Feedback.msg_debug (str "Leaving unification with failure"); - iraise e - + Exninfo.iraise e let unify_0 env sigma = unify_0_with_initial_metas (sigma,[],[]) true env diff --git a/proofs/refiner.ml b/proofs/refiner.ml index 832a749ef2..fd73ab1b5a 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -209,8 +209,8 @@ let catch_failerror (e, info) = | FailError (0,_) -> Control.check_for_interrupt () | FailError (lvl,s) -> - iraise (FailError (lvl - 1, s), info) - | e -> iraise (e, info) + Exninfo.iraise (FailError (lvl - 1, s), info) + | e -> Exninfo.iraise (e, info) (** FIXME: do we need to add a [Errors.push] here? *) (* ORELSE0 t1 t2 tries to apply t1 and if it fails, applies t2 *) @@ -219,7 +219,7 @@ let tclORELSE0 t1 t2 g = t1 g with (* Breakpoint *) | e when CErrors.noncritical e -> - let e = CErrors.push e in catch_failerror e; t2 g + let e = Exninfo.capture e in catch_failerror e; t2 g (* ORELSE t1 t2 tries to apply t1 and if it fails or does not progress, then applies t2 *) @@ -232,7 +232,7 @@ let tclORELSE_THEN t1 t2then t2else gls = match try Some(tclPROGRESS t1 gls) with e when CErrors.noncritical e -> - let e = CErrors.push e in catch_failerror e; None + let e = Exninfo.capture e in catch_failerror e; None with | None -> t2else gls | Some sgl -> diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index fd689602df..9eb0924bd6 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -372,7 +372,7 @@ module Make(T : Task) () = struct 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 + with e -> let e = Exninfo.capture e in destroy q; Exninfo.iraise e let n_workers { active } = Pool.n_workers active diff --git a/stm/stm.ml b/stm/stm.ml index 95c58b9043..a5b868343d 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -1014,7 +1014,7 @@ end = struct (* {{{ *) if PG_compat.there_are_pending_proofs () then VCS.goals id (PG_compat.get_open_goals ()) with e -> - let (e, info) = CErrors.push e in + let (e, info) = Exninfo.capture e in let good_id = !cur_id in invalidate_cur_state (); VCS.reached id; @@ -1046,7 +1046,7 @@ end = struct (* {{{ *) unfreeze st; res with e -> - let e = CErrors.push e in + let e = Exninfo.capture e in Vernacstate.invalidate_cache (); unfreeze st; Exninfo.iraise e @@ -1540,7 +1540,7 @@ end = struct (* {{{ *) RespBuiltProof(proof,time) with | e when CErrors.noncritical e || e = Stack_overflow -> - let (e, info) = CErrors.push e in + let (e, info) = Exninfo.capture e in (* This can happen if the proof is broken. The error has also been * signalled as a feedback, hence we can silently recover *) let e_error_at, e_safe_id = match Stateid.get info with @@ -1687,7 +1687,7 @@ end = struct (* {{{ *) `OK proof end with e -> - let (e, info) = CErrors.push e in + let (e, info) = Exninfo.capture e in (try match Stateid.get info with | None -> msg_warning Pp.( @@ -2092,7 +2092,7 @@ end = struct (* {{{ *) ignore(stm_vernac_interp r_for st { r_what with verbose = true }); feedback ~id:r_for Processed with e when CErrors.noncritical e -> - let e = CErrors.push e in + let e = Exninfo.capture e in let msg = iprint e in feedback ~id:r_for (Message (Error, None, msg)) @@ -2337,7 +2337,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = else try f () with e when CErrors.noncritical e -> - let ie = CErrors.push e in + let ie = Exninfo.capture e in error_absorbing_tactic id blockname ie in (* Absorb errors from f x *) let resilient_command f x = @@ -2435,7 +2435,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp id st x); with e when CErrors.noncritical e -> - let (e, info) = CErrors.push e in + let (e, info) = Exninfo.capture e in let info = Stateid.add info ~valid:prev id in Exninfo.iraise (e, info)); wall_clock_last_fork := Unix.gettimeofday () @@ -2569,28 +2569,32 @@ end (* }}} *) (********************************* STM API ************************************) (******************************************************************************) -(* Main initialization routine *) -type stm_init_options = { - (* The STM will set some internal flags differently depending on the - specified [doc_type]. This distinction should disappear at some - some point. *) - doc_type : stm_doc_type; +(** STM initialization options: *) +type stm_init_options = + { doc_type : stm_doc_type + (** The STM does set some internal flags differently depending on + the specified [doc_type]. This distinction should disappear at + some some point. *) - (* Initial load path in scope for the document. Usually extracted - from -R options / _CoqProject *) - iload_path : Loadpath.coq_path list; + ; ml_load_path : CUnix.physical_path list + (** OCaml load paths for the document. *) - (* Require [require_libs] before the initial state is + ; vo_load_path : Loadpath.vo_path list + (** [vo] load paths for the document. Usually extracted from -R + options / _CoqProject *) + + ; require_libs : (string * string option * bool option) list + (** Require [require_libs] before the initial state is ready. Parameters follow [Library], that is to say, [lib,prefix,import_export] means require library [lib] from optional [prefix] and [import_export] if [Some false/Some true] is used. *) - require_libs : (string * string option * bool option) list; - (* STM options that apply to the current document. *) - stm_options : AsyncOpts.stm_opt; -} -(* fb_handler : Feedback.feedback -> unit; *) + ; stm_options : AsyncOpts.stm_opt + (** Low-level STM options *) + } + + (* fb_handler : Feedback.feedback -> unit; *) (* let doc_type_module_name (std : stm_doc_type) = @@ -2615,7 +2619,7 @@ let dirpath_of_file f = let ldir = Libnames.add_dirpath_suffix ldir0 id in ldir -let new_doc { doc_type ; iload_path; require_libs; stm_options } = +let new_doc { doc_type ; ml_load_path; vo_load_path; require_libs; stm_options } = let require_file (dir, from, exp) = let mp = Libnames.qualid_of_string dir in @@ -2633,7 +2637,8 @@ let new_doc { doc_type ; iload_path; require_libs; stm_options } = (* Set load path; important, this has to happen before we declare the library below as [Declaremods/Library] will infer the module name by looking at the load path! *) - List.iter Loadpath.add_coq_path iload_path; + List.iter Mltop.add_ml_dir ml_load_path; + List.iter Loadpath.add_vo_path vo_load_path; Safe_typing.allow_delayed_constants := !cur_opt.async_proofs_mode <> APoff; @@ -2688,7 +2693,7 @@ let observe ~doc id = VCS.print (); doc with e -> - let e = CErrors.push e in + let e = Exninfo.capture e in VCS.print (); VCS.restore vcs; Exninfo.iraise e @@ -2763,7 +2768,7 @@ let finish_tasks name u p (t,rcbackup as tasks) = let a, _ = List.fold_left finish_task u (info_tasks tasks) in (a,true), p with e -> - let e = CErrors.push e in + let e = Exninfo.capture e in msg_warning (str"File " ++ str name ++ str ":" ++ spc () ++ iprint e); exit 1 @@ -2987,7 +2992,7 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) VCS.print (); rc with e -> - let e = CErrors.push e in + let e = Exninfo.capture e in handle_failure e vcs let get_ast ~doc id = @@ -3197,7 +3202,7 @@ let edit_at ~doc id = VCS.print (); doc, rc with e -> - let (e, info) = CErrors.push e in + let (e, info) = Exninfo.capture e in match Stateid.get info with | None -> VCS.print (); diff --git a/stm/stm.mli b/stm/stm.mli index 841adcf05b..e56bac6e0f 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -52,38 +52,30 @@ type stm_doc_type = | VioDoc of string (* file path *) | Interactive of interactive_top (* module path *) -(** Coq initialization options: - - - [doc_type]: Type of document being created. - - - [require_libs]: list of libraries/modules to be pre-loaded at - startup. A tuple [(modname,modfrom,import)] is equivalent to [From - modfrom Require modname]; [import] works similarly to - [Library.require_library_from_dirpath], [Some false] will import - the module, [Some true] will additionally export it. - -*) -type stm_init_options = { - (* The STM will set some internal flags differently depending on the - specified [doc_type]. This distinction should disappear at some - some point. *) - doc_type : stm_doc_type; - - (* Initial load path in scope for the document. Usually extracted - from -R options / _CoqProject *) - iload_path : Loadpath.coq_path list; - - (* Require [require_libs] before the initial state is +(** STM initialization options: *) +type stm_init_options = + { doc_type : stm_doc_type + (** The STM does set some internal flags differently depending on + the specified [doc_type]. This distinction should disappear at + some some point. *) + + ; ml_load_path : CUnix.physical_path list + (** OCaml load paths for the document. *) + + ; vo_load_path : Loadpath.vo_path list + (** [vo] load paths for the document. Usually extracted from -R + options / _CoqProject *) + + ; require_libs : (string * string option * bool option) list + (** Require [require_libs] before the initial state is ready. Parameters follow [Library], that is to say, [lib,prefix,import_export] means require library [lib] from optional [prefix] and [import_export] if [Some false/Some true] is used. *) - require_libs : (string * string option * bool option) list; - (* STM options that apply to the current document. *) - stm_options : AsyncOpts.stm_opt; -} -(* fb_handler : Feedback.feedback -> unit; *) + ; stm_options : AsyncOpts.stm_opt + (** Low-level STM options *) + } (** The type of a STM document *) type doc diff --git a/tactics/abstract.ml b/tactics/abstract.ml index 1e18028e7b..86e6a92a22 100644 --- a/tactics/abstract.ml +++ b/tactics/abstract.ml @@ -97,8 +97,8 @@ let cache_term_by_tactic_then ~opaque ~name_op ?(goal_type=None) tac tacK = which is an error irrelevant to the proof system (in fact it means that [e] comes from [tac] failing to yield enough success). Hence it reraises [e]. *) - let (_, info) = CErrors.push src in - iraise (e, info) + let (_, info) = Exninfo.capture src in + Exninfo.iraise (e, info) in let body, effs = Future.force const.Declare.proof_entry_body in (* We drop the side-effects from the entry, they already exist in the ambient environment *) diff --git a/tactics/auto.ml b/tactics/auto.ml index 1dde820075..d68f9271ec 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -303,7 +303,9 @@ let hintmap_of sigma secvars hdc concl = | None -> Hint_db.map_none ~secvars | Some hdc -> if occur_existential sigma concl then - Hint_db.map_existential sigma ~secvars hdc concl + (fun db -> match Hint_db.map_existential sigma ~secvars hdc concl db with + | ModeMatch l -> l + | ModeMismatch -> []) else Hint_db.map_auto sigma ~secvars hdc concl let exists_evaluable_reference env = function @@ -366,11 +368,14 @@ and my_find_search_delta sigma db_list local_db secvars hdc concl = let st = Hint_db.transparent_state db in let flags, l = let l = - match hdc with None -> Hint_db.map_none ~secvars db + match hdc with + | None -> Hint_db.map_none ~secvars db | Some hdc -> if TransparentState.is_empty st then Hint_db.map_auto sigma ~secvars hdc concl db - else Hint_db.map_existential sigma ~secvars hdc concl db + else match Hint_db.map_existential sigma ~secvars hdc concl db with + | ModeMatch l -> l + | ModeMismatch -> [] in auto_flags_of_state st, l in List.map (fun x -> (Some flags,x)) l) (local_db::db_list) diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 28feeecb86..25bd9cc8a8 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -236,7 +236,7 @@ let unify_resolve_refine poly flags gl clenv = Tacticals.New.tclZEROMSG (str "Unable to unify") | e when CErrors.noncritical e -> Tacticals.New.tclZEROMSG (str "Unexpected error") - | _ -> iraise ie) + | _ -> Exninfo.iraise ie) (** Dealing with goals of the form A -> B and hints of the form C -> A -> B. @@ -309,12 +309,12 @@ let shelve_dependencies gls = let hintmap_of sigma hdc secvars concl = match hdc with - | None -> fun db -> Hint_db.map_none ~secvars db + | None -> fun db -> ModeMatch (Hint_db.map_none ~secvars db) | Some hdc -> fun db -> - if Hint_db.use_dn db then (* Using dnet *) - Hint_db.map_eauto sigma ~secvars hdc concl db - else Hint_db.map_existential sigma ~secvars hdc concl db + if Hint_db.use_dn db then (* Using dnet *) + Hint_db.map_eauto sigma ~secvars hdc concl db + else Hint_db.map_existential sigma ~secvars hdc concl db (** Hack to properly solve dependent evars that are typeclasses *) let rec e_trivial_fail_db only_classes db_list local_db secvars = @@ -362,15 +362,6 @@ and e_my_find_search db_list local_db secvars hdc complete only_classes env sigm | _ -> AllowAll with e when CErrors.noncritical e -> AllowAll in - let hint_of_db = hintmap_of sigma hdc secvars concl in - let hintl = - List.map_append - (fun db -> - let tacs = hint_of_db db in - let flags = auto_unif_flags ~allowed_evars (Hint_db.transparent_state db) in - List.map (fun x -> (flags, x)) tacs) - (local_db::db_list) - in let tac_of_hint = fun (flags, {pri = b; pat = p; poly = poly; code = t; secvars; name = name}) -> let tac = function @@ -428,19 +419,40 @@ and e_my_find_search db_list local_db secvars hdc complete only_classes env sigm match repr_hint t with | Extern _ -> (tac, b, true, name, lazy (pr_hint env sigma t ++ pp)) | _ -> (tac, b, false, name, lazy (pr_hint env sigma t ++ pp)) - in List.map tac_of_hint hintl + in + let hint_of_db = hintmap_of sigma hdc secvars concl in + let hintl = List.map_filter (fun db -> match hint_of_db db with + | ModeMatch l -> Some (db, l) + | ModeMismatch -> None) + (local_db :: db_list) + in + (* In case there is a mode mismatch in all the databases we get stuck. + Otherwise we consider the hints that match. + Recall the local database uses the union of all the modes in the other databases. *) + if List.is_empty hintl then ModeMismatch + else + let hintl = + CList.map_append + (fun (db, tacs) -> + let flags = auto_unif_flags ~allowed_evars (Hint_db.transparent_state db) in + List.map (fun x -> (flags, x)) tacs) + hintl + in + ModeMatch (List.map tac_of_hint hintl) and e_trivial_resolve db_list local_db secvars only_classes env sigma concl = let hd = try Some (decompose_app_bound sigma concl) with Bound -> None in try - e_my_find_search db_list local_db secvars hd true only_classes env sigma concl + (match e_my_find_search db_list local_db secvars hd true only_classes env sigma concl with + | ModeMatch l -> l + | ModeMismatch -> []) with Not_found -> [] let e_possible_resolve db_list local_db secvars only_classes env sigma concl = let hd = try Some (decompose_app_bound sigma concl) with Bound -> None in try e_my_find_search db_list local_db secvars hd false only_classes env sigma concl - with Not_found -> [] + with Not_found -> ModeMatch [] let cut_of_hints h = List.fold_left (fun cut db -> PathOr (Hint_db.cut db, cut)) PathEmpty h @@ -528,9 +540,10 @@ let make_resolve_hyp env sigma st flags only_classes pri decl = let hints = build_subclasses ~check:false env sigma (GlobRef.VarRef id) empty_hint_info in (List.map_append (fun (path,info,c) -> + let h = IsConstr (EConstr.of_constr c,Univ.ContextSet.empty) [@ocaml.warning "-3"] in make_resolves env sigma ~name:(PathHints path) (true,false,not !Flags.quiet) info ~poly:false - (IsConstr (EConstr.of_constr c,Univ.ContextSet.empty))) + h) hints) else [] in @@ -605,6 +618,7 @@ module Search = struct (** In the proof engine failures are represented as exceptions *) exception ReachedLimitEx exception NoApplicableEx + exception StuckClass (** ReachedLimitEx has priority over NoApplicableEx to handle iterative deepening: it should fail when no hints are applicable, @@ -643,8 +657,11 @@ module Search = struct (if backtrack then str" with backtracking" else str" without backtracking")); let secvars = compute_secvars gl in - let poss = - e_possible_resolve hints info.search_hints secvars info.search_only_classes env sigma concl in + match e_possible_resolve hints info.search_hints secvars + info.search_only_classes env sigma concl with + | ModeMismatch -> + Proofview.tclZERO StuckClass + | ModeMatch poss -> (* If no goal depends on the solution of this one or the instances are irrelevant/assumed to be unique, then we don't need to backtrack, as long as no evar appears in the goal @@ -770,7 +787,7 @@ module Search = struct (fun e' -> if CErrors.noncritical (fst e') then (pr_error e'; aux (merge_exceptions e e') tl) - else iraise e') + else Exninfo.iraise e') and aux e = function | x :: xs -> onetac e x xs | [] -> @@ -782,6 +799,7 @@ module Search = struct str" possibilities"); match e with | (ReachedLimitEx,ie) -> Proofview.tclZERO ~info:ie ReachedLimitEx + | (StuckClass,ie) -> Proofview.tclZERO ~info:ie StuckClass | (_,ie) -> Proofview.tclZERO ~info:ie NoApplicableEx in if backtrack then aux (NoApplicableEx,Exninfo.null) poss @@ -840,11 +858,21 @@ module Search = struct begin fun gl -> search_tac_gl mst only_classes dep hints depth (succ i) sigma gls gl end in + let tac_or_stuck sigma gls i = + Proofview.tclOR + (tac sigma gls i) + (function (StuckClass, _) -> + if !typeclasses_debug > 1 then + Feedback.msg_debug + Pp.(str "Proof search got stuck on a constraint, postponing it."); + Proofview.tclUNIT () + | (e, ie) -> Proofview.tclZERO ~info:ie e) + in Proofview.Unsafe.tclGETGOALS >>= fun gls -> let gls = CList.map Proofview.drop_state gls in Proofview.tclEVARMAP >>= fun sigma -> let j = List.length gls in - (tclDISPATCH (List.init j (fun i -> tac sigma gls i))) + (tclDISPATCH (List.init j (fun i -> tac_or_stuck sigma gls i))) let fix_iterative t = let rec aux depth = @@ -863,7 +891,7 @@ module Search = struct | (e,ie) -> Proofview.tclZERO ~info:ie e) in aux 1 - let eauto_tac mst ?(unique=false) + let eauto_tac_stuck mst ?(unique=false) ~only_classes ?strategy ~depth ~dep hints = let open Proofview in let tac = @@ -901,6 +929,37 @@ module Search = struct Proofview.tclEXACTLY_ONCE Proofview.MoreThanOneSuccess tac else tac in + let rec fixpoint step laststuck = + tac <*> + Proofview.tclEVARMAP >>= fun sigma -> + Proofview.Unsafe.tclGETGOALS >>= fun stuck -> + begin + if !typeclasses_debug > 0 then + Feedback.msg_debug Pp.(str "Finished run " ++ int step ++ str " of resolution."); + let stuck = List.map Proofview_monad.drop_state stuck in + let stuckset = Evar.Set.of_list stuck in + let () = + if !typeclasses_debug > 1 then + if Evar.Set.cardinal stuckset > 0 then + Feedback.msg_debug Pp.(str "Stuck goals after resolution: " ++ fnl () ++ + Pp.prlist_with_sep spc (fun ev -> Printer.pr_goal {it = ev; sigma}) stuck) + else Feedback.msg_debug Pp.(str "No stuck goals after resolution.") + in + if Evar.Set.is_empty stuckset then tclUNIT () + else if Evar.Set.equal laststuck stuckset then + begin + if !typeclasses_debug > 1 then Feedback.msg_debug Pp.(str "No progress made."); + tclUNIT () + end + else begin + assert(Evar.Set.subset stuckset laststuck); + (* Progress was made *) + if !typeclasses_debug > 1 then + Feedback.msg_debug Pp.(str "Progress made, restarting resolution on stuck goals."); + fixpoint (succ step) stuckset + end + end + in with_shelf numgoals >>= fun (initshelf, i) -> (if !typeclasses_debug > 1 then Feedback.msg_debug (str"Starting resolution with " ++ int i ++ @@ -909,24 +968,28 @@ module Search = struct (if only_classes then str " in only_classes mode" else str " in regular mode") ++ match depth with None -> str ", unbounded" | Some i -> str ", with depth limit " ++ int i)); - tac + Proofview.Unsafe.tclGETGOALS >>= fun gls -> + let gls = CList.map Proofview.drop_state gls in + fixpoint 1 (Evar.Set.of_list gls) let eauto_tac mst ?unique ~only_classes ?strategy ~depth ~dep hints = - Hints.wrap_hint_warning @@ eauto_tac mst ?unique ~only_classes ?strategy ~depth ~dep hints + Hints.wrap_hint_warning @@ eauto_tac_stuck mst ?unique ~only_classes ?strategy ~depth ~dep hints let run_on_evars env evm p tac = match evars_to_goals p evm with | None -> None (* This happens only because there's no evar having p *) | Some (goals, nongoals) -> - let goals = + let goalsl = if !typeclasses_dependency_order then top_sort evm goals else Evar.Set.elements goals in + let tac = tac <*> Proofview.Unsafe.tclGETGOALS >>= + fun stuck -> Proofview.shelve_goals (List.map Proofview_monad.drop_state stuck) in let evm = Evd.set_typeclass_evars evm Evar.Set.empty in let fgoals = Evd.save_future_goals evm in let _, pv = Proofview.init evm [] in - let pv = Proofview.unshelve goals pv in + let pv = Proofview.unshelve goalsl pv in try (* Instance may try to call this before a proof is set up! Thus, give_me_the_proof will fail. Beware! *) @@ -937,35 +1000,35 @@ module Search = struct * with | Proof_global.NoCurrentProof -> *) Id.of_string "instance", false in - let (), pv', (unsafe, shelved, gaveup), _ = - Proofview.apply ~name ~poly env tac pv - in - if not (List.is_empty gaveup) then - CErrors.anomaly (Pp.str "run_on_evars not assumed to apply tactics generating given up goals."); - if Proofview.finished pv' then + let finish pv' shelved = let evm' = Proofview.return pv' in - assert(Evd.fold_undefined (fun ev _ acc -> - let okev = Evd.mem evm ev || List.mem ev shelved in - if not okev then - Feedback.msg_debug - (str "leaking evar " ++ int (Evar.repr ev) ++ - spc () ++ pr_ev evm' ev); - acc && okev) evm' true); + assert(Evd.fold_undefined (fun ev _ acc -> + let okev = Evd.mem evm ev || List.mem ev shelved in + if not okev then + Feedback.msg_debug + (str "leaking evar " ++ int (Evar.repr ev) ++ + spc () ++ pr_ev evm' ev); + acc && okev) evm' true); let fgoals = Evd.shelve_on_future_goals shelved fgoals in let evm' = Evd.restore_future_goals evm' fgoals in let nongoals' = Evar.Set.fold (fun ev acc -> match Evarutil.advance evm' ev with | Some ev' -> Evar.Set.add ev acc - | None -> acc) nongoals (Evd.get_typeclass_evars evm') + | None -> acc) (Evar.Set.union goals nongoals) (Evd.get_typeclass_evars evm') in let evm' = evars_reset_evd ~with_conv_pbs:true ~with_univs:false evm' evm in let evm' = Evd.set_typeclass_evars evm' nongoals' in - Some evm' - else raise Not_found + Some evm' + in + let (), pv', (unsafe, shelved, gaveup), _ = Proofview.apply ~name ~poly env tac pv in + if not (List.is_empty gaveup) then + CErrors.anomaly (Pp.str "run_on_evars not assumed to apply tactics generating given up goals."); + if Proofview.finished pv' then finish pv' shelved + else raise Not_found with Logic_monad.TacticFailure _ -> raise Not_found let evars_eauto env evd depth only_classes unique dep mst hints p = - let eauto_tac = eauto_tac mst ~unique ~only_classes ~depth ~dep:(unique || dep) hints in + let eauto_tac = eauto_tac_stuck mst ~unique ~only_classes ~depth ~dep:(unique || dep) hints in let res = run_on_evars env evd p eauto_tac in match res with | None -> evd @@ -995,7 +1058,11 @@ let typeclasses_eauto ?(only_classes=false) ?(st=TransparentState.full) let modes = List.map Hint_db.modes dbs in let modes = List.fold_left (GlobRef.Map.union (fun _ m1 m2 -> Some (m1@m2))) GlobRef.Map.empty modes in let depth = match depth with None -> get_typeclasses_depth () | Some l -> Some l in - Search.eauto_tac (modes,st) ~only_classes ?strategy ~depth ~dep:true dbs + Proofview.tclIGNORE + (Search.eauto_tac (modes,st) ~only_classes ?strategy ~depth ~dep:true dbs) + (* Stuck goals can remain here, we could shelve them, but this way + the user can use `solve [typeclasses eauto]` to check there are + no stuck goals remaining, or use [typeclasses eauto; shelve] himself. *) (** We compute dependencies via a union-find algorithm. Beware of the imperative effects on the partition structure, diff --git a/tactics/class_tactics.mli b/tactics/class_tactics.mli index dc94e6a6fb..02b24bc145 100644 --- a/tactics/class_tactics.mli +++ b/tactics/class_tactics.mli @@ -66,4 +66,6 @@ module Search : sig -> Hints.hint_db list (** The list of hint databases to use *) -> unit Proofview.tactic + (** Note: there might be stuck goals due to mode declarations + remaining even in case of success of the tactic. *) end diff --git a/tactics/eauto.ml b/tactics/eauto.ml index 9a1e6a6736..9715661985 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -124,7 +124,10 @@ let hintmap_of sigma secvars hdc concl = | None -> fun db -> Hint_db.map_none ~secvars db | Some hdc -> if occur_existential sigma concl then - (fun db -> Hint_db.map_existential sigma ~secvars hdc concl db) + (fun db -> + match Hint_db.map_existential sigma ~secvars hdc concl db with + | ModeMatch l -> l + | ModeMismatch -> []) else (fun db -> Hint_db.map_auto sigma ~secvars hdc concl db) (* FIXME: should be (Hint_db.map_eauto hdc concl db) *) @@ -235,7 +238,7 @@ module SearchProblem = struct (* msg (hov 1 (pptac ++ str" gives: \n" ++ pr_goals lgls ++ str"\n")); *) (lgls, cost, pptac) :: aux tacl with e when CErrors.noncritical e -> - let e = CErrors.push e in + let e = Exninfo.capture e in Refiner.catch_failerror e; aux tacl in aux l diff --git a/tactics/hints.ml b/tactics/hints.ml index 86aa046586..e9ed43e3de 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -499,6 +499,10 @@ let rec subst_hints_path subst hp = type hint_db_name = string +type 'a with_mode = + | ModeMatch of 'a + | ModeMismatch + module Hint_db : sig type t @@ -507,9 +511,9 @@ val find : GlobRef.t -> t -> search_entry val map_none : secvars:Id.Pred.t -> t -> full_hint list val map_all : secvars:Id.Pred.t -> GlobRef.t -> t -> full_hint list val map_existential : evar_map -> secvars:Id.Pred.t -> - (GlobRef.t * constr array) -> constr -> t -> full_hint list + (GlobRef.t * constr array) -> constr -> t -> full_hint list with_mode val map_eauto : evar_map -> secvars:Id.Pred.t -> - (GlobRef.t * constr array) -> constr -> t -> full_hint list + (GlobRef.t * constr array) -> constr -> t -> full_hint list with_mode val map_auto : evar_map -> secvars:Id.Pred.t -> (GlobRef.t * constr array) -> constr -> t -> full_hint list val add_one : env -> evar_map -> hint_entry -> t -> t @@ -528,7 +532,6 @@ val add_modes : hint_mode array list GlobRef.Map.t -> t -> t val modes : t -> hint_mode array list GlobRef.Map.t val fold : (GlobRef.t option -> hint_mode array list -> full_hint list -> 'a -> 'a) -> t -> 'a -> 'a - end = struct @@ -618,8 +621,8 @@ struct let map_existential sigma ~secvars (k,args) concl db = let se = find k db in if matches_modes sigma args se.sentry_mode then - merge_entry secvars db se.sentry_nopat se.sentry_pat - else merge_entry secvars db [] [] + ModeMatch (merge_entry secvars db se.sentry_nopat se.sentry_pat) + else ModeMismatch (* [c] contains an existential *) let map_eauto sigma ~secvars (k,args) concl db = @@ -627,8 +630,8 @@ struct if matches_modes sigma args se.sentry_mode then let st = if db.use_dn then Some db.hintdb_state else None in let pat = lookup_tacs sigma concl st se in - merge_entry secvars db [] pat - else merge_entry secvars db [] [] + ModeMatch (merge_entry secvars db [] pat) + else ModeMismatch let is_exact = function | Give_exact _ -> true @@ -1325,6 +1328,13 @@ let project_hint ~poly pri l2r r = let info = {Typeclasses.hint_priority = pri; hint_pattern = None} in (info,false,true,PathAny, IsGlobRef (GlobRef.ConstRef c)) +let warn_deprecated_hint_constr = + CWarnings.create ~name:"deprecated-hint-constr" ~category:"deprecated" + (fun () -> + Pp.strbrk + "Declaring arbitrary terms as hints is deprecated; declare a global reference instead" + ) + let interp_hints ~poly = fun h -> let env = Global.env () in @@ -1349,7 +1359,9 @@ let interp_hints ~poly = | HintsReference c -> let gr = global_with_alias c in (PathHints [gr], poly, IsGlobRef gr) - | HintsConstr c -> (PathAny, poly, f poly c) + | HintsConstr c -> + let () = warn_deprecated_hint_constr () in + (PathAny, poly, f poly c) in let fp = Constrintern.intern_constr_pattern env sigma in let fres (info, b, r) = @@ -1510,7 +1522,9 @@ let pr_hint_term env sigma cl = let fn = try let hdc = decompose_app_bound sigma cl in if occur_existential sigma cl then - Hint_db.map_existential sigma ~secvars:Id.Pred.full hdc cl + (fun db -> match Hint_db.map_existential sigma ~secvars:Id.Pred.full hdc cl db with + | ModeMatch l -> l + | ModeMismatch -> []) else Hint_db.map_auto sigma ~secvars:Id.Pred.full hdc cl with Bound -> Hint_db.map_none ~secvars:Id.Pred.full in diff --git a/tactics/hints.mli b/tactics/hints.mli index 9c9f0b7708..2663f65851 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -125,6 +125,10 @@ val glob_hints_path_atom : val glob_hints_path : Libnames.qualid hints_path_gen -> GlobRef.t hints_path_gen +type 'a with_mode = + | ModeMatch of 'a + | ModeMismatch + module Hint_db : sig type t @@ -140,16 +144,20 @@ module Hint_db : val map_all : secvars:Id.Pred.t -> GlobRef.t -> t -> full_hint list (** All hints associated to the reference, respecting modes if evars appear in the - arguments, _not_ using the discrimination net. *) + arguments, _not_ using the discrimination net. + Returns a [ModeMismatch] if there are declared modes and none matches. + *) val map_existential : evar_map -> secvars:Id.Pred.t -> - (GlobRef.t * constr array) -> constr -> t -> full_hint list + (GlobRef.t * constr array) -> constr -> t -> full_hint list with_mode (** All hints associated to the reference, respecting modes if evars appear in the - arguments and using the discrimination net. *) - val map_eauto : evar_map -> secvars:Id.Pred.t -> (GlobRef.t * constr array) -> constr -> t -> full_hint list + arguments and using the discrimination net. + Returns a [ModeMismatch] if there are declared modes and none matches. *) + val map_eauto : evar_map -> secvars:Id.Pred.t -> (GlobRef.t * constr array) -> constr -> t -> full_hint list with_mode - (** All hints associated to the reference, respecting modes if evars appear in the - arguments. *) + (** All hints associated to the reference. + Precondition: no evars should appear in the arguments, so no modes + are checked. *) val map_auto : evar_map -> secvars:Id.Pred.t -> (GlobRef.t * constr array) -> constr -> t -> full_hint list @@ -181,7 +189,7 @@ type hnf = bool type hint_term = | IsGlobRef of GlobRef.t - | IsConstr of constr * Univ.ContextSet.t + | IsConstr of constr * Univ.ContextSet.t [@ocaml.deprecated "Declare a hint constant instead"] type hints_entry = | HintsResolveEntry of (hint_info * bool * hnf * hints_path_atom * hint_term) list diff --git a/tactics/pfedit.ml b/tactics/pfedit.ml index dbabc4e4e0..a7ba12bb1f 100644 --- a/tactics/pfedit.ml +++ b/tactics/pfedit.ml @@ -120,18 +120,14 @@ let build_constant_by_tactic ~name ?(opaque=Proof_global.Transparent) ctx sign ~ let evd = Evd.from_ctx ctx in let goals = [ (Global.env_of_context sign , typ) ] in let pf = Proof_global.start_proof ~name ~poly ~udecl:UState.default_univ_decl evd goals in - try - let pf, status = by tac pf in - let open Proof_global in - let { entries; universes } = close_proof ~opaque ~keep_body_ucst_separate:false (fun x -> x) pf in - match entries with - | [entry] -> - entry, status, universes - | _ -> - CErrors.anomaly Pp.(str "[build_constant_by_tactic] close_proof returned more than one proof term") - with reraise -> - let reraise = CErrors.push reraise in - iraise reraise + let pf, status = by tac pf in + let open Proof_global in + let { entries; universes } = close_proof ~opaque ~keep_body_ucst_separate:false (fun x -> x) pf in + match entries with + | [entry] -> + entry, status, universes + | _ -> + CErrors.anomaly Pp.(str "[build_constant_by_tactic] close_proof returned more than one proof term") let build_by_tactic ?(side_eff=true) env sigma ~poly typ tac = let name = Id.of_string ("temporary_proof"^string_of_int (next())) in @@ -160,8 +156,8 @@ let refine_by_tactic ~name ~poly env sigma ty tac = try Proof.run_tactic env tac prf with Logic_monad.TacticFailure e as src -> (* Catch the inner error of the monad tactic *) - let (_, info) = CErrors.push src in - iraise (e, info) + let (_, info) = Exninfo.capture src in + Exninfo.iraise (e, info) in (* Plug back the retrieved sigma *) let Proof.{ goals; stack; shelf; given_up; sigma; entry } = Proof.data prf in diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 4b93b81d1c..5fde6d2178 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -144,7 +144,7 @@ module New : sig (** [catch_failerror e] fails and decreases the level if [e] is an Ltac error with level more than 0. Otherwise succeeds. *) - val catch_failerror : Util.iexn -> unit tactic + val catch_failerror : Exninfo.iexn -> unit tactic val tclIDTAC : unit tactic val tclTHEN : unit tactic -> unit tactic -> unit tactic diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 8371da76b2..ef50c56dc4 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1848,12 +1848,12 @@ let apply_in_once_main flags innerclause env sigma (loc,d,lbind) = let rec aux clause = try progress_with_clause flags innerclause clause with e when CErrors.noncritical e -> - let e' = CErrors.push e in + let e' = Exninfo.capture e in try aux (clenv_push_prod clause) with NotExtensibleClause -> match e with | UnableToApply -> explain_unable_to_apply_lemma ?loc env sigma thm innerclause - | _ -> iraise e' + | _ -> Exninfo.iraise e' in aux (make_clenv_binding env sigma (d,thm) lbind) @@ -1886,7 +1886,7 @@ let apply_in_once ?(respect_opaque = false) with_delta tac id ]) with e when with_destruct && CErrors.noncritical e -> - let (e, info) = CErrors.push e in + let (e, info) = Exninfo.capture e in (descend_in_conjunctions (Id.Set.singleton targetid) (fun b id -> aux (id::idstoclear) b (mkVar id)) (e, info) c) @@ -3155,7 +3155,7 @@ let clear_for_destruct ids = (clear_gen (fun env sigma id err inglobal -> raise (ClearDependencyError (id,err,inglobal))) ids) (function | ClearDependencyError (id,err,inglobal),_ -> warn_cannot_remove_as_expected (id,inglobal); Proofview.tclUNIT () - | e -> iraise e) + | e -> Exninfo.iraise e) (* Either unfold and clear if defined or simply clear if not a definition *) let expand_hyp id = @@ -4246,25 +4246,26 @@ type eliminator_source = | ElimOver of bool * Id.t let find_induction_type isrec elim hyp0 gl = - let sigma, scheme,elim = + let sigma, indref, nparams, elim = match elim with | None -> let sort = Tacticals.New.elimination_sort_of_goal gl in - let sigma, (elimc,elimt),_ = guess_elim isrec false sort hyp0 gl in - let scheme = compute_elim_sig sigma ~elimc elimt in - (* We drop the scheme waiting to know if it is dependent *) - sigma, scheme, ElimOver (isrec,hyp0) + let sigma', (elimc,elimt),_ = guess_elim isrec false sort hyp0 gl in + let scheme = compute_elim_sig sigma' ~elimc elimt in + (* We drop the scheme and elimc/elimt waiting to know if it is dependent, this + needs no update to sigma at this point. *) + Tacmach.New.project gl, scheme.indref, scheme.nparams, ElimOver (isrec,hyp0) | Some e -> let sigma, (elimc,elimt),ind_guess = given_elim hyp0 e gl in let scheme = compute_elim_sig sigma ~elimc elimt in if Option.is_empty scheme.indarg then error "Cannot find induction type"; let indsign = compute_scheme_signature sigma scheme hyp0 ind_guess in let elim = ({ elimindex = Some(-1); elimbody = elimc },elimt) in - sigma, scheme, ElimUsing (elim,indsign) + sigma, scheme.indref, scheme.nparams, ElimUsing (elim,indsign) in - match scheme.indref with + match indref with | None -> error_ind_scheme "" - | Some ref -> sigma, (ref, scheme.nparams, elim) + | Some ref -> sigma, (ref, nparams, elim) let get_elim_signature elim hyp0 gl = compute_elim_signature (given_elim hyp0 elim gl) hyp0 diff --git a/test-suite/.csdp.cache b/test-suite/.csdp.cache Binary files differindex b3bcb5b056..046cb067c5 100644 --- a/test-suite/.csdp.cache +++ b/test-suite/.csdp.cache diff --git a/test-suite/bugs/closed/bug_11722.v b/test-suite/bugs/closed/bug_11722.v new file mode 100644 index 0000000000..d4bd5f48b2 --- /dev/null +++ b/test-suite/bugs/closed/bug_11722.v @@ -0,0 +1,20 @@ +Require Import Program. +Set Universe Polymorphism. + +Inductive paths@{i} (A : Type@{i}) (a : A) : A -> Type@{i} := + idpath : paths A a a. + +Inductive nat := + | O : nat + | S : nat -> nat. + +Axiom cheat : forall {A}, A. + +Program Definition foo@{i} : forall x : nat, paths@{i} nat x x := _. +Next Obligation. + destruct x. + constructor. + apply cheat. +Defined. (* FIXED: Universe unbound error *) + +Check foo@{_}. diff --git a/test-suite/bugs/closed/bug_11730.v b/test-suite/bugs/closed/bug_11730.v new file mode 100644 index 0000000000..f788636f9c --- /dev/null +++ b/test-suite/bugs/closed/bug_11730.v @@ -0,0 +1,6 @@ +Set Mangle Names. + +Infix "&&&" := andb (at level 40, left associativity). +(* Error: Variable _0 occurs more than once. *) + +Check (_ &&& _). diff --git a/test-suite/bugs/closed/bug_11811.v b/test-suite/bugs/closed/bug_11811.v new file mode 100644 index 0000000000..a73494b630 --- /dev/null +++ b/test-suite/bugs/closed/bug_11811.v @@ -0,0 +1,13 @@ + +Unset Positivity Checking. + +Inductive foo : Type -> Type := +| bar : foo (foo unit) +| baz : foo nat. + +Definition toto : forall A, foo A -> {A = foo unit} + {A = nat}. +Proof. + intros A x. destruct x; intuition. +Defined. + +Check (eq_refl : toto _ baz = right eq_refl). diff --git a/test-suite/bugs/closed/bug_9058.v b/test-suite/bugs/closed/bug_9058.v new file mode 100644 index 0000000000..6de8324641 --- /dev/null +++ b/test-suite/bugs/closed/bug_9058.v @@ -0,0 +1,16 @@ +Class A (X : Type) := {}. +Hint Mode A ! : typeclass_instances. + +Class B X {aX: A X} Y := { opB: X -> Y -> Y }. +Hint Mode B - - ! : typeclass_instances. + +Section Section. + +Context X {aX: A X} Y {bY: B X Y}. + +(* Set Typeclasses Debug. *) + +Let ok := fun (x : X) (y : Y) => opB x y. +Let ok' := fun x (y : Y) => opB x y. + +End Section. diff --git a/test-suite/bugs/closed/bug_9512.v b/test-suite/bugs/closed/bug_9512.v index 25285622a9..bad9d64f65 100644 --- a/test-suite/bugs/closed/bug_9512.v +++ b/test-suite/bugs/closed/bug_9512.v @@ -4,9 +4,10 @@ Set Primitive Projections. Record params := { width : Z }. Definition p : params := Build_params 64. +Definition width' := width. Set Printing All. -Goal width p = 0%Z -> width p = 0%Z. +Lemma foo : width p = 0%Z -> width p = 0%Z. intros. assert_succeeds (enough True; [omega|]). @@ -16,7 +17,9 @@ Goal width p = 0%Z -> width p = 0%Z. (* ============================ *) (* @eq Z (width p) Z0 *) - change tt with tt in H. + change (width' p = 0%Z) in H;cbv [width'] in H. + (* check that we correctly got the compat constant in H *) + Fail match goal with H : ?l = _ |- ?l' = _ => constr_eq l l' end. (* H : @eq Z (width p) Z0 *) (* ============================ *) diff --git a/test-suite/bugs/closed/bug_9930.v b/test-suite/bugs/closed/bug_9930.v new file mode 100644 index 0000000000..042cd69fbe --- /dev/null +++ b/test-suite/bugs/closed/bug_9930.v @@ -0,0 +1,14 @@ +Set Primitive Projections. +Record params := { width : nat }. +Definition p : params := Build_params 64. + +Lemma foo : width p = 0 -> width p = 0. + intros. + let e := lazymatch type of H with ?e = 0 => e end in + change tt with tt in H; + let E := lazymatch type of H with ?E = 0 => E end in + idtac "before:" e; idtac "after :" E; + (* before: (width p) *) + (* after : (width p) *) + tryif constr_eq e E then exact H else idtac. +Qed. diff --git a/test-suite/coq-makefile/camldep/run.sh b/test-suite/coq-makefile/camldep/run.sh index aa62ee56eb..465677a4bf 100755 --- a/test-suite/coq-makefile/camldep/run.sh +++ b/test-suite/coq-makefile/camldep/run.sh @@ -13,5 +13,9 @@ mkdir src echo '{ let foo = () }' > src/file1.mlg echo 'let bar = File1.foo' > src/file2.ml coq_makefile -f _CoqProject -o Makefile -make src/file2.cmx -[ -f src/file2.cmx ] +if which ocamlopt >/dev/null 2>&1; then + make src/file2.cmx + [ -f src/file2.cmx ] +fi +make src/file2.cmo +[ -f src/file2.cmo ] diff --git a/test-suite/coq-makefile/findlib-package-unpacked/run.sh b/test-suite/coq-makefile/findlib-package-unpacked/run.sh index e53a7ed0f7..6d7ae15ee2 100755 --- a/test-suite/coq-makefile/findlib-package-unpacked/run.sh +++ b/test-suite/coq-makefile/findlib-package-unpacked/run.sh @@ -16,5 +16,7 @@ coq_makefile -f _CoqProject -o Makefile cat Makefile.conf cat Makefile.local make -C findlib/foo -make +if which ocamlopt >/dev/null 2>&1; then + make +fi make byte diff --git a/test-suite/ide/debug_ltac.fake b/test-suite/ide/debug_ltac.fake index aa68fad39e..38c610a5a6 100644 --- a/test-suite/ide/debug_ltac.fake +++ b/test-suite/ide/debug_ltac.fake @@ -1,2 +1,3 @@ +ADD { Comments "fakeide doesn't support fail as the first sentence". } FAILADD { Debug On. } ADD { Set Debug On. } diff --git a/test-suite/ide/undo002.fake b/test-suite/ide/undo002.fake index 5284c5d3a5..eb553f9dfa 100644 --- a/test-suite/ide/undo002.fake +++ b/test-suite/ide/undo002.fake @@ -3,6 +3,7 @@ # # Simple backtrack by 2 before two global definitions # +ADD initial { Comments "initial sentence". } ADD { Definition foo := 0. } ADD { Definition bar := 1. } EDIT_AT initial diff --git a/test-suite/ltac2/example2.v b/test-suite/ltac2/example2.v index c953d25061..ac92ca34ef 100644 --- a/test-suite/ltac2/example2.v +++ b/test-suite/ltac2/example2.v @@ -261,6 +261,25 @@ assert (H : 0 + 0 = 0) by reflexivity. intros x; exact x. Qed. +Goal True. +Proof. +enough (H := 0 + 0). +constructor. +Qed. + +Goal True. +Proof. +enough (exists n, n = 0) as [n Hn]. ++ exact I. ++ exists 0; reflexivity. +Qed. + +Goal True -> True. +Proof. +enough (H : 0 + 0 = 0) by (intros x; exact x). +reflexivity. +Qed. + Goal 1 + 1 = 2. Proof. change (?a + 1 = 2) with (2 = $a + 1). diff --git a/test-suite/misc/side-eff-leak-univs.sh b/test-suite/misc/side-eff-leak-univs.sh new file mode 100755 index 0000000000..a0f7a8587c --- /dev/null +++ b/test-suite/misc/side-eff-leak-univs.sh @@ -0,0 +1,19 @@ +#!/usr/bin/env bash + +set -e + +export COQBIN=$BIN +export PATH=$COQBIN:$PATH + +cd misc/side-eff-leak-univs/ + +coq_makefile -f _CoqProject -o Makefile + +make clean + +make src/evil_plugin.cma + +if make; then + >&2 echo 'Should have failed!' + exit 1 +fi diff --git a/test-suite/misc/side-eff-leak-univs/.gitignore b/test-suite/misc/side-eff-leak-univs/.gitignore new file mode 100644 index 0000000000..2a6a6bc68d --- /dev/null +++ b/test-suite/misc/side-eff-leak-univs/.gitignore @@ -0,0 +1,2 @@ +/Makefile* +/src/evil.ml diff --git a/test-suite/misc/side-eff-leak-univs/_CoqProject b/test-suite/misc/side-eff-leak-univs/_CoqProject new file mode 100644 index 0000000000..2099d862b2 --- /dev/null +++ b/test-suite/misc/side-eff-leak-univs/_CoqProject @@ -0,0 +1,6 @@ +-Q theories Evil +-I src + +src/evil.mlg +src/evil_plugin.mlpack +theories/evil.v diff --git a/test-suite/misc/side-eff-leak-univs/src/evil.mlg b/test-suite/misc/side-eff-leak-univs/src/evil.mlg new file mode 100644 index 0000000000..d89ab887a8 --- /dev/null +++ b/test-suite/misc/side-eff-leak-univs/src/evil.mlg @@ -0,0 +1,13 @@ +DECLARE PLUGIN "evil_plugin" + +{ +open Ltac_plugin +open Stdarg +} + +TACTIC EXTEND magic +| [ "magic" ident(i) ident(j) ] -> { + let open Glob_term in + DeclareUniv.do_constraint ~poly:false [ GType (Libnames.qualid_of_ident i), Univ.Lt, GType (Libnames.qualid_of_ident j)]; Proofview.tclUNIT() +} +END diff --git a/test-suite/misc/side-eff-leak-univs/src/evil_plugin.mlpack b/test-suite/misc/side-eff-leak-univs/src/evil_plugin.mlpack new file mode 100644 index 0000000000..6382aa69e1 --- /dev/null +++ b/test-suite/misc/side-eff-leak-univs/src/evil_plugin.mlpack @@ -0,0 +1 @@ +Evil diff --git a/test-suite/misc/side-eff-leak-univs/theories/evil.v b/test-suite/misc/side-eff-leak-univs/theories/evil.v new file mode 100644 index 0000000000..d138091fa9 --- /dev/null +++ b/test-suite/misc/side-eff-leak-univs/theories/evil.v @@ -0,0 +1,10 @@ +Declare ML Module "evil_plugin". + +Universes i j. + +Lemma foo@{} : Type@{j}. +Proof. + magic i j; transparent_abstract exact_no_check Type@{i}. +Defined. + +Definition bar : Type@{i} := Type@{j}. diff --git a/test-suite/output/Inductive.out b/test-suite/output/Inductive.out index 8ff571ae55..ff2556c5dc 100644 --- a/test-suite/output/Inductive.out +++ b/test-suite/output/Inductive.out @@ -5,3 +5,5 @@ Inductive foo (A : Type) (x : A) (y : A := x) : Prop := Foo : foo A x Arguments foo _%type_scope Arguments Foo _%type_scope +myprod unit bool + : Set diff --git a/test-suite/output/Inductive.v b/test-suite/output/Inductive.v index 9eec9a7dad..db1276cb6c 100644 --- a/test-suite/output/Inductive.v +++ b/test-suite/output/Inductive.v @@ -5,3 +5,11 @@ Fail Inductive list' (A:Set) : Set := (* Check printing of let-ins *) #[universes(template)] Inductive foo (A : Type) (x : A) (y := x) := Foo. Print foo. + +(* Check where clause *) +Reserved Notation "x ** y" (at level 40, left associativity). +Inductive myprod A B := + mypair : A -> B -> A ** B + where "A ** B" := (myprod A B) (only parsing). + +Check unit ** bool. diff --git a/test-suite/output/RealSyntax.out b/test-suite/output/RealSyntax.out index 2d877bd813..2b14ca7069 100644 --- a/test-suite/output/RealSyntax.out +++ b/test-suite/output/RealSyntax.out @@ -2,6 +2,8 @@ : R (-31)%R : R +15e-1%R + : R eq_refl : 102e-2 = 102e-2 : 102e-2 = 102e-2 eq_refl : 102e-1 = 102e-1 diff --git a/test-suite/output/RealSyntax.v b/test-suite/output/RealSyntax.v index cb3bce70d4..7be8b18ac8 100644 --- a/test-suite/output/RealSyntax.v +++ b/test-suite/output/RealSyntax.v @@ -2,6 +2,8 @@ Require Import Reals.Rdefinitions. Check 32%R. Check (-31)%R. +Check 1.5_%R. + Open Scope R_scope. Check (eq_refl : 1.02 = IZR 102 / IZR (Z.pow_pos 10 2)). diff --git a/test-suite/output/bug_8206.out b/test-suite/output/bug_8206.out new file mode 100644 index 0000000000..6015fe32f9 --- /dev/null +++ b/test-suite/output/bug_8206.out @@ -0,0 +1,5 @@ +File "stdin", line 11, characters 0-23: +Error: Signature components for label homework do not match: expected type +"forall a b : nat, bug_8206.M.add a b = bug_8206.M.add b a" but found type +"nat -> forall b : nat, bug_8206.M.add 0 b = bug_8206.M.add b 0". + diff --git a/test-suite/output/bug_8206.v b/test-suite/output/bug_8206.v new file mode 100644 index 0000000000..8d4e73dfac --- /dev/null +++ b/test-suite/output/bug_8206.v @@ -0,0 +1,11 @@ +Module Type Sig. + Parameter add: nat -> nat -> nat. + Axiom homework: forall (a b: nat), add a b = add b a. +End Sig. + +Module Impl. + Definition add(a b: nat) := plus a b. + Axiom homework: forall (a b: nat), add 0 b = add b 0. +End Impl. + +Module M : Sig := Impl. diff --git a/test-suite/success/HintMode.v b/test-suite/success/HintMode.v new file mode 100644 index 0000000000..decddb73d1 --- /dev/null +++ b/test-suite/success/HintMode.v @@ -0,0 +1,20 @@ +Module Postponing. + +Class In A T := { IsIn : A -> T -> Prop }. +Class Empty T := { empty : T }. +Class EmptyIn (A T : Type) `{In A T} `{Empty T} := + { isempty : forall x, IsIn x empty -> False }. + +Hint Mode EmptyIn ! ! - - : typeclass_instances. +Hint Mode Empty ! : typeclass_instances. +Hint Mode In ! - : typeclass_instances. +Existing Class IsIn. +Goal forall A T `{In A T} `{Empty T} `{EmptyIn A T}, forall x : A, IsIn x empty -> False. + Proof. + intros. + eapply @isempty. (* Second goal needs to be solved first, to un-stuck the first one + (hence the Existing Class IsIn to allow finding the assumption of IsIn here) *) + all:typeclasses eauto. +Qed. + +End Postponing. diff --git a/test-suite/success/Typeclasses.v b/test-suite/success/Typeclasses.v index 3f96bf2c35..66305dfefa 100644 --- a/test-suite/success/Typeclasses.v +++ b/test-suite/success/Typeclasses.v @@ -1,3 +1,64 @@ +Module applydestruct. + Class Foo (A : Type) := + { bar : nat -> A; + baz : A -> nat }. + Hint Mode Foo + : typeclass_instances. + + Class C (A : Type). + Hint Mode C + : typeclass_instances. + + Variable fool : forall {A} {F : Foo A} (x : A), C A -> bar 0 = x. + (* apply leaves non-dependent subgoals of typeclass type + alone *) + Goal forall {A} {F : Foo A} (x : A), bar 0 = x. + Proof. + intros. apply fool. + match goal with + |[ |- C A ] => idtac + end. + Abort. + + Variable fooli : forall {A} {F : Foo A} {c : C A} (x : A), bar 0 = x. + (* apply tries to resolve implicit argument typeclass + constraints. *) + Goal forall {A} {F : Foo A} (x : A), bar 0 = x. + Proof. + intros. + Fail apply fooli. + Fail unshelve eapply fooli; solve [typeclasses eauto]. + eapply fooli. + Abort. + + (* It applies resolution after unification of the goal *) + Goal forall {A} {F : Foo A} {C : C A} (x : A), bar 0 = x. + Proof. + intros. apply fooli. + Abort. + Set Typeclasses Debug Verbosity 2. + + Inductive bazdestr {A} (F : Foo A) : nat -> Prop := + | isbas : bazdestr F 1. + + Variable fooinv : forall {A} {F : Foo A} (x : A), + bazdestr F (baz x). + + (* Destruct applies resolution early, before finding + occurrences to abstract. *) + Goal forall {A} {F : Foo A} {C : C A} (x : A), baz x = 0. + Proof. + intros. Fail destruct (fooinv _). + destruct (fooinv x). + Abort. + + Goal forall {A} {F : Foo A} (x y : A), x = y. + Proof. + intros. rewrite <- (fool x). rewrite <- (fool y). reflexivity. + match goal with + |[ |- C A ] => idtac + end. + Abort. +End applydestruct. + Module onlyclasses. (* In 8.6 we still allow non-class subgoals *) diff --git a/test-suite/success/pose.v b/test-suite/success/pose.v new file mode 100644 index 0000000000..17007915fe --- /dev/null +++ b/test-suite/success/pose.v @@ -0,0 +1,9 @@ +(* Test syntax *) + +Goal 0=0. +pose proof (a := I). +Fail clearbody a. +epose proof (b := fun _ => eq_refl). +Fail clearbody b. +exact (b a). +Qed. diff --git a/theories/Arith/Lt.v b/theories/Arith/Lt.v index 918b0efc5a..8904f3f936 100644 --- a/theories/Arith/Lt.v +++ b/theories/Arith/Lt.v @@ -41,11 +41,15 @@ Proof. apply Nat.lt_succ_r. Qed. +Register lt_n_Sm_le as num.nat.lt_n_Sm_le. + Theorem le_lt_n_Sm n m : n <= m -> n < S m. Proof. apply Nat.lt_succ_r. Qed. +Register le_lt_n_Sm as num.nat.le_lt_n_Sm. + Hint Immediate lt_le_S: arith. Hint Immediate lt_n_Sm_le: arith. Hint Immediate le_lt_n_Sm: arith. @@ -99,6 +103,8 @@ Proof. apply Nat.succ_lt_mono. Qed. +Register lt_S_n as num.nat.lt_S_n. + Hint Resolve lt_n_Sn lt_S lt_n_S : arith. Hint Immediate lt_S_n : arith. @@ -133,6 +139,8 @@ Notation lt_trans := Nat.lt_trans (only parsing). Notation lt_le_trans := Nat.lt_le_trans (only parsing). Notation le_lt_trans := Nat.le_lt_trans (only parsing). +Register le_lt_trans as num.nat.le_lt_trans. + Hint Resolve lt_trans lt_le_trans le_lt_trans: arith. (** * Large = strict or equal *) diff --git a/theories/Arith/PeanoNat.v b/theories/Arith/PeanoNat.v index f12785029a..4657b7f46d 100644 --- a/theories/Arith/PeanoNat.v +++ b/theories/Arith/PeanoNat.v @@ -764,6 +764,9 @@ Infix "mod" := Nat.modulo (at level 40, no associativity) : nat_scope. Hint Unfold Nat.le : core. Hint Unfold Nat.lt : core. +Register Nat.le_trans as num.nat.le_trans. +Register Nat.nlt_0_r as num.nat.nlt_0_r. + (** [Nat] contains an [order] tactic for natural numbers *) (** Note that [Nat.order] is domain-agnostic: it will not prove diff --git a/theories/Arith/Wf_nat.v b/theories/Arith/Wf_nat.v index 1c183930f9..c5a6651c05 100644 --- a/theories/Arith/Wf_nat.v +++ b/theories/Arith/Wf_nat.v @@ -34,6 +34,8 @@ Proof. intros a. apply (H (S (f a))). auto with arith. Defined. +Register well_founded_ltof as num.nat.well_founded_ltof. + Theorem well_founded_gtof : well_founded gtof. Proof. exact well_founded_ltof. diff --git a/theories/Init/Peano.v b/theories/Init/Peano.v index 149a7a0cc5..beb06ea912 100644 --- a/theories/Init/Peano.v +++ b/theories/Init/Peano.v @@ -159,6 +159,8 @@ Inductive le (n:nat) : nat -> Prop := where "n <= m" := (le n m) : nat_scope. +Register le_n as num.nat.le_n. + Hint Constructors le: core. (*i equivalent to : "Hints Resolve le_n le_S : core." i*) diff --git a/theories/Init/Wf.v b/theories/Init/Wf.v index 998bbc7047..bd5185fdb0 100644 --- a/theories/Init/Wf.v +++ b/theories/Init/Wf.v @@ -32,11 +32,14 @@ Section Well_founded. Inductive Acc (x: A) : Prop := Acc_intro : (forall y:A, R y x -> Acc y) -> Acc x. + Register Acc as core.wf.acc. + Lemma Acc_inv : forall x:A, Acc x -> forall y:A, R y x -> Acc y. destruct 1; trivial. Defined. Global Arguments Acc_inv [x] _ [y] _, [x] _ y _. + Register Acc_inv as core.wf.acc_inv. (** A relation is well-founded if every element is accessible *) diff --git a/theories/micromega/Lia.v b/theories/micromega/Lia.v index e53800d07d..5d97fc46ef 100644 --- a/theories/micromega/Lia.v +++ b/theories/micromega/Lia.v @@ -14,11 +14,8 @@ (* *) (************************************************************************) -Require Import ZMicromega. -Require Import ZArith_base. -Require Import RingMicromega. -Require Import VarMap. -Require Import DeclConstant. +Require Import ZMicromega RingMicromega VarMap DeclConstant. +Require Import BinNums. Require Coq.micromega.Tauto. Declare ML Module "micromega_plugin". @@ -29,9 +26,9 @@ Ltac zchecker := (@eq_refl bool true <: @eq bool (ZTautoChecker __ff __wit) true) (@find Z Z0 __varmap)). -Ltac lia := PreOmega.zify; xlia zchecker. +Ltac lia := Zify.zify; xlia zchecker. -Ltac nia := PreOmega.zify; xnlia zchecker. +Ltac nia := Zify.zify; xnlia zchecker. (* Local Variables: *) diff --git a/theories/micromega/ZMicromega.v b/theories/micromega/ZMicromega.v index 9bedb47371..38f3d3e0c0 100644 --- a/theories/micromega/ZMicromega.v +++ b/theories/micromega/ZMicromega.v @@ -1549,7 +1549,7 @@ Proof. apply H ; auto. unfold ltof in *. simpl in *. - PreOmega.zify. + Zify.zify. intuition subst. assumption. eapply Z.lt_le_trans. eassumption. apply Z.add_le_mono_r. assumption. diff --git a/theories/micromega/Zify.v b/theories/micromega/Zify.v index 18cd196148..494d5e5623 100644 --- a/theories/micromega/Zify.v +++ b/theories/micromega/Zify.v @@ -8,83 +8,16 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -Require Import ZifyClasses. -Require Export ZifyInst. -Require Import InitialRing. - -(** From PreOmega *) - -(** I) translation of Z.max, Z.min, Z.abs, Z.sgn into recognized equations *) - -Ltac zify_unop_core t thm a := - (* Let's introduce the specification theorem for t *) - pose proof (thm a); - (* Then we replace (t a) everywhere with a fresh variable *) - let z := fresh "z" in set (z:=t a) in *; clearbody z. - -Ltac zify_unop_var_or_term t thm a := - (* If a is a variable, no need for aliasing *) - let za := fresh "z" in - (rename a into za; rename za into a; zify_unop_core t thm a) || - (* Otherwise, a is a complex term: we alias it. *) - (remember a as za; zify_unop_core t thm za). - -Ltac zify_unop t thm a := - (* If a is a scalar, we can simply reduce the unop. *) - (* Note that simpl wasn't enough to reduce [Z.max 0 0] (#5439) *) - let isz := isZcst a in - match isz with - | true => - let u := eval compute in (t a) in - change (t a) with u in * - | _ => zify_unop_var_or_term t thm a - end. - -Ltac zify_unop_nored t thm a := - (* in this version, we don't try to reduce the unop (that can be (Z.add x)) *) - let isz := isZcst a in - match isz with - | true => zify_unop_core t thm a - | _ => zify_unop_var_or_term t thm a - end. - -Ltac zify_binop t thm a b:= - (* works as zify_unop, except that we should be careful when - dealing with b, since it can be equal to a *) - let isza := isZcst a in - match isza with - | true => zify_unop (t a) (thm a) b - | _ => - let za := fresh "z" in - (rename a into za; rename za into a; zify_unop_nored (t a) (thm a) b) || - (remember a as za; match goal with - | H : za = b |- _ => zify_unop_nored (t za) (thm za) za - | _ => zify_unop_nored (t za) (thm za) b - end) - end. - -(* end from PreOmega *) - -Ltac applySpec S := - let t := type of S in - match t with - | @BinOpSpec _ _ ?Op _ => - let Spec := (eval unfold S, BSpec in (@BSpec _ _ Op _ S)) in - repeat - match goal with - | H : context[Op ?X ?Y] |- _ => zify_binop Op Spec X Y - | |- context[Op ?X ?Y] => zify_binop Op Spec X Y - end - | @UnOpSpec _ _ ?Op _ => - let Spec := (eval unfold S, USpec in (@USpec _ _ Op _ S)) in - repeat - match goal with - | H : context[Op ?X] |- _ => zify_unop Op Spec X - | |- context[Op ?X ] => zify_unop Op Spec X - end - end. +Require Import ZifyClasses ZifyInst. +Declare ML Module "zify_plugin". (** [zify_post_hook] is there to be redefined. *) Ltac zify_post_hook := idtac. -Ltac zify := zify_op ; (zify_iter_specs applySpec) ; zify_post_hook. +Ltac iter_specs := zify_iter_specs. + +Ltac zify := intros; + zify_elim_let ; + zify_op ; + (zify_iter_specs) ; + zify_saturate ; zify_post_hook. diff --git a/theories/micromega/ZifyClasses.v b/theories/micromega/ZifyClasses.v index d3f7f91074..988205a891 100644 --- a/theories/micromega/ZifyClasses.v +++ b/theories/micromega/ZifyClasses.v @@ -73,6 +73,7 @@ Class BinRel {S:Type} {T:Type} (R : S -> S -> Prop) {I : InjTyp S T} := (** [PropOp Op] declares morphisms for [<->]. This will be used to deal with e.g. [and], [or],... *) + Class PropOp (Op : Prop -> Prop -> Prop) := mkprop { op_iff : forall (p1 p2 q1 q2:Prop), (p1 <-> q1) -> (p2 <-> q2) -> (Op p1 p2 <-> Op q1 q2) @@ -80,7 +81,7 @@ Class PropOp (Op : Prop -> Prop -> Prop) := Class PropUOp (Op : Prop -> Prop) := mkuprop { - uop_iff : forall (p1 q1 :Prop), (p1 <-> q1) -> (Op p1 <-> Op q1) + uop_iff : forall (p1 q1 :Prop), (p1 <-> q1) -> (Op p1 <-> Op q1) }. @@ -131,7 +132,7 @@ Class Saturate {T: Type} (Op : T -> T -> T) := are used to store source and target expressions together with a correctness proof. *) -Record injterm {S T: Type} {I : S -> T} := +Record injterm {S T: Type} (I : S -> T) := mkinjterm { source : S ; target : T ; inj_ok : I source = target}. Record injprop := @@ -139,82 +140,104 @@ Record injprop := source_prop : Prop ; target_prop : Prop ; injprop_ok : source_prop <-> target_prop}. -(** Lemmas for building [injterm] and [injprop]. *) -Definition mkprop_op (Op : Prop -> Prop -> Prop) (POp : PropOp Op) - (p1 :injprop) (p2: injprop) : injprop := - {| source_prop := (Op (source_prop p1) (source_prop p2)) ; - target_prop := (Op (target_prop p1) (target_prop p2)) ; - injprop_ok := (op_iff (source_prop p1) (source_prop p2) (target_prop p1) (target_prop p2) - (injprop_ok p1) (injprop_ok p2)) - |}. -Definition mkuprop_op (Op : Prop -> Prop) (POp : PropUOp Op) - (p1 :injprop) : injprop := - {| source_prop := (Op (source_prop p1)) ; - target_prop := (Op (target_prop p1)) ; - injprop_ok := (uop_iff (source_prop p1) (target_prop p1) (injprop_ok p1)) - |}. +(** Lemmas for building rewrite rules. *) + +Definition PropOp_iff (Op : Prop -> Prop -> Prop) := + forall (p1 p2 q1 q2:Prop), (p1 <-> q1) -> (p2 <-> q2) -> (Op p1 p2 <-> Op q1 q2). + +Definition PropUOp_iff (Op : Prop -> Prop) := + forall (p1 q1 :Prop), (p1 <-> q1) -> (Op p1 <-> Op q1). Lemma mkapp2 (S1 S2 S3 T : Type) (Op : S1 -> S2 -> S3) - {I1 : InjTyp S1 T} {I2 : InjTyp S2 T} {I3 : InjTyp S3 T} - (B : @BinOp S1 S2 S3 T Op I1 I2 I3) - (t1 : @injterm S1 T inj) (t2 : @injterm S2 T inj) - : @injterm S3 T inj. + (I1 : S1 -> T) (I2 : S2 -> T) (I3 : S3 -> T) + (TBOP : T -> T -> T) + (TBOPINJ : forall n m, I3 (Op n m) = TBOP (I1 n) (I2 m)) + (s1 : S1) (t1 : T) (P1: I1 s1 = t1) + (s2 : S2) (t2 : T) (P2: I2 s2 = t2): I3 (Op s1 s2) = TBOP t1 t2. Proof. - apply (mkinjterm _ _ inj (Op (source t1) (source t2)) (TBOp (target t1) (target t2))). - (rewrite <- inj_ok; - rewrite <- inj_ok; - apply TBOpInj). -Defined. + subst. apply TBOPINJ. +Qed. -Lemma mkapp (S1 S2 T : Type) (Op : S1 -> S2) - {I1 : InjTyp S1 T} - {I2 : InjTyp S2 T} - (B : @UnOp S1 S2 T Op I1 I2 ) - (t1 : @injterm S1 T inj) - : @injterm S2 T inj. +Lemma mkapp (S1 S2 T : Type) (OP : S1 -> S2) + (I1 : S1 -> T) + (I2 : S2 -> T) + (TUOP : T -> T) + (TUOPINJ : forall n, I2 (OP n) = TUOP (I1 n)) + (s1: S1) (t1: T) (P1: I1 s1 = t1): I2 (OP s1) = TUOP t1. Proof. - apply (mkinjterm _ _ inj (Op (source t1)) (TUOp (target t1))). - (rewrite <- inj_ok; apply TUOpInj). -Defined. + subst. apply TUOPINJ. +Qed. + +Lemma mkrel (S T : Type) (R : S -> S -> Prop) + (I : S -> T) + (TR : T -> T -> Prop) + (TRINJ : forall n m : S, R n m <-> TR (I n) (I m)) + (s1 : S) (t1 : T) (P1 : I s1 = t1) + (s2 : S) (t2 : T) (P2 : I s2 = t2): + R s1 s2 <-> TR t1 t2. +Proof. + subst. + apply TRINJ. +Qed. + +(** Hardcoded support and lemma for propositional logic *) -Lemma mkapp0 (S T : Type) (Op : S) - {I : InjTyp S T} - (B : @CstOp S T Op I) - : @injterm S T inj. +Lemma and_morph : forall (s1 s2 t1 t2:Prop), s1 <-> t1 -> s2 <-> t2 -> ((s1 /\ s2) <-> (t1 /\ t2)). Proof. - apply (mkinjterm _ _ inj Op TCst). - (apply TCstInj). -Defined. + intros. tauto. +Qed. -Lemma mkrel (S T : Type) (R : S -> S -> Prop) - {Inj : InjTyp S T} - (B : @BinRel S T R Inj) - (t1 : @injterm S T inj) (t2 : @injterm S T inj) - : @injprop. +Lemma or_morph : forall (s1 s2 t1 t2:Prop), s1 <-> t1 -> s2 <-> t2 -> ((s1 \/ s2) <-> (t1 \/ t2)). +Proof. + intros. tauto. +Qed. + +Lemma impl_morph : forall (s1 s2 t1 t2:Prop), s1 <-> t1 -> s2 <-> t2 -> ((s1 -> s2) <-> (t1 -> t2)). +Proof. + intros. tauto. +Qed. + +Lemma iff_morph : forall (s1 s2 t1 t2:Prop), s1 <-> t1 -> s2 <-> t2 -> ((s1 <-> s2) <-> (t1 <-> t2)). +Proof. + intros. tauto. +Qed. + +Lemma not_morph : forall (s1 t1:Prop), s1 <-> t1 -> (not s1) <-> (not t1). +Proof. + intros. tauto. +Qed. + +Lemma eq_iff : forall (P Q : Prop), P = Q -> (P <-> Q). Proof. - apply (mkinjprop (R (source t1) (source t2)) (TR (target t1) (target t2))). - (rewrite <- inj_ok; rewrite <- inj_ok;apply TRInj). + intros. + rewrite H. + apply iff_refl. Defined. +Lemma rew_iff (P Q : Prop) (IFF : P <-> Q) : P -> Q. +Proof. + exact (fun H => proj1 IFF H). +Qed. + +Definition identity (A : Type) : A -> A := fun x => x. + (** Registering constants for use by the plugin *) +Register eq_iff as ZifyClasses.eq_iff. Register target_prop as ZifyClasses.target_prop. Register mkrel as ZifyClasses.mkrel. Register target as ZifyClasses.target. Register mkapp2 as ZifyClasses.mkapp2. Register mkapp as ZifyClasses.mkapp. -Register mkapp0 as ZifyClasses.mkapp0. Register op_iff as ZifyClasses.op_iff. Register uop_iff as ZifyClasses.uop_iff. Register TR as ZifyClasses.TR. Register TBOp as ZifyClasses.TBOp. Register TUOp as ZifyClasses.TUOp. Register TCst as ZifyClasses.TCst. -Register mkprop_op as ZifyClasses.mkprop_op. -Register mkuprop_op as ZifyClasses.mkuprop_op. Register injprop_ok as ZifyClasses.injprop_ok. Register inj_ok as ZifyClasses.inj_ok. Register source as ZifyClasses.source. @@ -225,8 +248,26 @@ Register TUOpInj as ZifyClasses.TUOpInj. Register not as ZifyClasses.not. Register mkinjterm as ZifyClasses.mkinjterm. Register eq_refl as ZifyClasses.eq_refl. +Register eq as ZifyClasses.eq. Register mkinjprop as ZifyClasses.mkinjprop. Register iff_refl as ZifyClasses.iff_refl. +Register rew_iff as ZifyClasses.rew_iff. Register source_prop as ZifyClasses.source_prop. Register injprop_ok as ZifyClasses.injprop_ok. Register iff as ZifyClasses.iff. +Register BinOpSpec as ZifyClasses.BinOpSpec. +Register UnOpSpec as ZifyClasses.UnOpSpec. + +(** Propositional logic *) +Register and as ZifyClasses.and. +Register and_morph as ZifyClasses.and_morph. +Register or as ZifyClasses.or. +Register or_morph as ZifyClasses.or_morph. +Register iff as ZifyClasses.iff. +Register iff_morph as ZifyClasses.iff_morph. +Register impl_morph as ZifyClasses.impl_morph. +Register not as ZifyClasses.not. +Register not_morph as ZifyClasses.not_morph. + +(** Identify function *) +Register identity as ZifyClasses.identity. diff --git a/theories/micromega/ZifyInst.v b/theories/micromega/ZifyInst.v index edfb5a2a94..fa486f3abc 100644 --- a/theories/micromega/ZifyInst.v +++ b/theories/micromega/ZifyInst.v @@ -17,44 +17,10 @@ Require Import ZifyClasses. Declare ML Module "zify_plugin". Local Open Scope Z_scope. -(** Propositional logic *) -Instance PropAnd : PropOp and. -Proof. - constructor. - tauto. -Defined. -Add PropOp PropAnd. - -Instance PropOr : PropOp or. -Proof. - constructor. - tauto. -Defined. -Add PropOp PropOr. - -Instance PropArrow : PropOp (fun x y => x -> y). -Proof. - constructor. - intros. - tauto. -Defined. -Add PropOp PropArrow. - -Instance PropIff : PropOp iff. -Proof. - constructor. - intros. - tauto. -Defined. -Add PropOp PropIff. - -Instance PropNot : PropUOp not. -Proof. - constructor. - intros. - tauto. -Defined. -Add PropUOp PropNot. +Ltac refl := + abstract (intros ; match goal with + | |- context[@inj _ _ ?X] => unfold X, inj + end ; reflexivity). Instance Inj_Z_Z : InjTyp Z Z := @@ -162,13 +128,18 @@ Instance Op_pos_le : BinRel Pos.le := {| TR := Z.le; TRInj := fun x y => iff_refl (Z.pos x <= Z.pos y) |}. Add BinRel Op_pos_le. +Lemma eq_pos_inj : forall (x y:positive), x = y <-> Z.pos x = Z.pos y. +Proof. + intros. + apply (iff_sym (Pos2Z.inj_iff x y)). +Qed. + Instance Op_eq_pos : BinRel (@eq positive) := - {| TR := @eq Z ; TRInj := fun x y => iff_sym (Pos2Z.inj_iff x y) |}. + { TR := @eq Z ; TRInj := eq_pos_inj }. Add BinRel Op_eq_pos. (* zify_positive_op *) - Instance Op_Z_of_N : UnOp Z.of_N := { TUOp := (fun x => x) ; TUOpInj := fun x => eq_refl (Z.of_N x) }. Add UnOp Op_Z_of_N. @@ -189,8 +160,11 @@ Instance Op_pos_succ : UnOp Pos.succ := { TUOp := fun x => x + 1; TUOpInj := Pos2Z.inj_succ }. Add UnOp Op_pos_succ. + + + Instance Op_pos_pred_double : UnOp Pos.pred_double := - { TUOp := fun x => 2 * x - 1; TUOpInj := ltac:(reflexivity) }. +{ TUOp := fun x => 2 * x - 1; TUOpInj := ltac:(refl) }. Add UnOp Op_pos_pred_double. Instance Op_pos_pred : UnOp Pos.pred := @@ -217,7 +191,7 @@ Instance Op_pos_of_nat : UnOp Pos.of_nat := Add UnOp Op_pos_of_nat. Instance Op_pos_add : BinOp Pos.add := - { TBOp := Z.add ; TBOpInj := ltac: (reflexivity) }. + { TBOp := Z.add ; TBOpInj := ltac: (refl) }. Add BinOp Op_pos_add. Instance Op_pos_add_carry : BinOp Pos.add_carry := @@ -230,7 +204,7 @@ Instance Op_pos_sub : BinOp Pos.sub := Add BinOp Op_pos_sub. Instance Op_pos_mul : BinOp Pos.mul := - { TBOp := Z.mul ; TBOpInj := ltac: (reflexivity) }. + { TBOp := Z.mul ; TBOpInj := ltac: (refl) }. Add BinOp Op_pos_mul. Instance Op_pos_min : BinOp Pos.min := @@ -250,19 +224,19 @@ Instance Op_pos_square : UnOp Pos.square := Add UnOp Op_pos_square. Instance Op_xO : UnOp xO := - { TUOp := fun x => 2 * x ; TUOpInj := ltac: (reflexivity) }. + { TUOp := fun x => 2 * x ; TUOpInj := ltac: (refl) }. Add UnOp Op_xO. Instance Op_xI : UnOp xI := - { TUOp := fun x => 2 * x + 1 ; TUOpInj := ltac: (reflexivity) }. + { TUOp := fun x => 2 * x + 1 ; TUOpInj := ltac: (refl) }. Add UnOp Op_xI. Instance Op_xH : CstOp xH := - { TCst := 1%Z ; TCstInj := ltac:(reflexivity)}. + { TCst := 1%Z ; TCstInj := ltac:(refl)}. Add CstOp Op_xH. Instance Op_Z_of_nat : UnOp Z.of_nat:= - { TUOp := fun x => x ; TUOpInj := ltac:(reflexivity) }. + { TUOp := fun x => x ; TUOpInj := (fun x : nat => @eq_refl Z (Z.of_nat x)) }. Add UnOp Op_Z_of_nat. (* zify_N_rel *) @@ -287,6 +261,14 @@ Instance Op_eq_N : BinRel (@eq N) := Add BinRel Op_eq_N. (* zify_N_op *) +Instance Op_N_N0 : CstOp N0 := + { TCst := Z0 ; TCstInj := eq_refl }. +Add CstOp Op_N_N0. + +Instance Op_N_Npos : UnOp Npos := + { TUOp := (fun x => x) ; TUOpInj := ltac:(refl) }. +Add UnOp Op_N_Npos. + Instance Op_N_of_nat : UnOp N.of_nat := { TUOp := fun x => x ; TUOpInj := nat_N_Z }. Add UnOp Op_N_of_nat. @@ -296,7 +278,7 @@ Instance Op_Z_abs_N : UnOp Z.abs_N := Add UnOp Op_Z_abs_N. Instance Op_N_pos : UnOp N.pos := - { TUOp := fun x => x ; TUOpInj := ltac:(reflexivity)}. + { TUOp := fun x => x ; TUOpInj := ltac:(refl)}. Add UnOp Op_N_pos. Instance Op_N_add : BinOp N.add := @@ -360,68 +342,72 @@ Instance Op_eqZ : BinRel (@eq Z) := { TR := @eq Z ; TRInj := fun x y => iff_refl (x = y) }. Add BinRel Op_eqZ. +Instance Op_Z_Z0 : CstOp Z0 := + { TCst := Z0 ; TCstInj := eq_refl }. +Add CstOp Op_Z_Z0. + Instance Op_Z_add : BinOp Z.add := - { TBOp := Z.add ; TBOpInj := ltac:(reflexivity) }. + { TBOp := Z.add ; TBOpInj := ltac:(refl) }. Add BinOp Op_Z_add. Instance Op_Z_min : BinOp Z.min := - { TBOp := Z.min ; TBOpInj := ltac:(reflexivity) }. + { TBOp := Z.min ; TBOpInj := ltac:(refl) }. Add BinOp Op_Z_min. Instance Op_Z_max : BinOp Z.max := - { TBOp := Z.max ; TBOpInj := ltac:(reflexivity) }. + { TBOp := Z.max ; TBOpInj := ltac:(refl) }. Add BinOp Op_Z_max. Instance Op_Z_mul : BinOp Z.mul := - { TBOp := Z.mul ; TBOpInj := ltac:(reflexivity) }. + { TBOp := Z.mul ; TBOpInj := ltac:(refl) }. Add BinOp Op_Z_mul. Instance Op_Z_sub : BinOp Z.sub := - { TBOp := Z.sub ; TBOpInj := ltac:(reflexivity) }. + { TBOp := Z.sub ; TBOpInj := ltac:(refl) }. Add BinOp Op_Z_sub. Instance Op_Z_div : BinOp Z.div := - { TBOp := Z.div ; TBOpInj := ltac:(reflexivity) }. + { TBOp := Z.div ; TBOpInj := ltac:(refl) }. Add BinOp Op_Z_div. Instance Op_Z_mod : BinOp Z.modulo := - { TBOp := Z.modulo ; TBOpInj := ltac:(reflexivity) }. + { TBOp := Z.modulo ; TBOpInj := ltac:(refl) }. Add BinOp Op_Z_mod. Instance Op_Z_rem : BinOp Z.rem := - { TBOp := Z.rem ; TBOpInj := ltac:(reflexivity) }. + { TBOp := Z.rem ; TBOpInj := ltac:(refl) }. Add BinOp Op_Z_rem. Instance Op_Z_quot : BinOp Z.quot := - { TBOp := Z.quot ; TBOpInj := ltac:(reflexivity) }. + { TBOp := Z.quot ; TBOpInj := ltac:(refl) }. Add BinOp Op_Z_quot. Instance Op_Z_succ : UnOp Z.succ := - { TUOp := fun x => x + 1 ; TUOpInj := ltac:(reflexivity) }. + { TUOp := fun x => x + 1 ; TUOpInj := ltac:(refl) }. Add UnOp Op_Z_succ. Instance Op_Z_pred : UnOp Z.pred := - { TUOp := fun x => x - 1 ; TUOpInj := ltac:(reflexivity) }. + { TUOp := fun x => x - 1 ; TUOpInj := ltac:(refl) }. Add UnOp Op_Z_pred. Instance Op_Z_opp : UnOp Z.opp := - { TUOp := Z.opp ; TUOpInj := ltac:(reflexivity) }. + { TUOp := Z.opp ; TUOpInj := ltac:(refl) }. Add UnOp Op_Z_opp. Instance Op_Z_abs : UnOp Z.abs := - { TUOp := Z.abs ; TUOpInj := ltac:(reflexivity) }. + { TUOp := Z.abs ; TUOpInj := ltac:(refl) }. Add UnOp Op_Z_abs. Instance Op_Z_sgn : UnOp Z.sgn := - { TUOp := Z.sgn ; TUOpInj := ltac:(reflexivity) }. + { TUOp := Z.sgn ; TUOpInj := ltac:(refl) }. Add UnOp Op_Z_sgn. Instance Op_Z_pow : BinOp Z.pow := - { TBOp := Z.pow ; TBOpInj := ltac:(reflexivity) }. + { TBOp := Z.pow ; TBOpInj := ltac:(refl) }. Add BinOp Op_Z_pow. Instance Op_Z_pow_pos : BinOp Z.pow_pos := - { TBOp := Z.pow ; TBOpInj := ltac:(reflexivity) }. + { TBOp := Z.pow ; TBOpInj := ltac:(refl) }. Add BinOp Op_Z_pow_pos. Instance Op_Z_double : UnOp Z.double := diff --git a/theories/omega/PreOmega.v b/theories/omega/PreOmega.v index 34533670f8..bd9caa801c 100644 --- a/theories/omega/PreOmega.v +++ b/theories/omega/PreOmega.v @@ -573,16 +573,4 @@ Ltac zify_N := repeat zify_N_rel; repeat zify_N_op; unfold Z_of_N' in *. Require Import ZifyClasses ZifyInst. Require Zify. -(* [elim_let] replaces a let binding (x := e : t) - by an equation (x = e) if t is an injected type *) - -Ltac elim_binding x t ty := - let h := fresh "heq_" x in - pose proof (@eq_refl ty x : @eq ty x t) as h; - try clearbody x. - -Ltac elim_let := zify_iter_let elim_binding. - -Ltac zify := - intros ; elim_let ; - Zify.zify ; ZifyInst.zify_saturate. +Ltac zify := Zify.zify. diff --git a/toplevel/ccompile.ml b/toplevel/ccompile.ml index dceb811d66..f75a706041 100644 --- a/toplevel/ccompile.ml +++ b/toplevel/ccompile.ml @@ -104,7 +104,7 @@ let compile opts copts ~echo ~f_in ~f_out = |> prlist_with_sep pr_comma Names.Id.print) ++ str ".") in - let iload_path = build_load_path opts in + let ml_load_path, vo_load_path = build_load_path opts in let require_libs = require_libs opts in let stm_options = opts.config.stm_flags in let output_native_objects = match opts.config.native_compiler with @@ -129,8 +129,8 @@ let compile opts copts ~echo ~f_in ~f_out = | BuildVo | BuildVok -> let doc, sid = Topfmt.(in_phase ~phase:LoadingPrelude) Stm.new_doc - Stm.{ doc_type = VoDoc long_f_dot_out; - iload_path; require_libs; stm_options; + Stm.{ doc_type = VoDoc long_f_dot_out; ml_load_path; + vo_load_path; require_libs; stm_options; } in let state = { doc; sid; proof = None; time = opts.config.time } in let state = load_init_vernaculars opts ~state in @@ -181,8 +181,8 @@ let compile opts copts ~echo ~f_in ~f_out = let doc, sid = Topfmt.(in_phase ~phase:LoadingPrelude) Stm.new_doc - Stm.{ doc_type = VioDoc long_f_dot_out; - iload_path; require_libs; stm_options; + Stm.{ doc_type = VioDoc long_f_dot_out; ml_load_path; + vo_load_path; require_libs; stm_options; } in let state = { doc; sid; proof = None; time = opts.config.time } in @@ -252,8 +252,9 @@ let do_vio opts copts = (* We must initialize the loadpath here as the vio scheduling process happens outside of the STM *) if copts.vio_files <> [] || copts.vio_tasks <> [] then - let iload_path = build_load_path opts in - List.iter Loadpath.add_coq_path iload_path; + let ml_lp, vo_lp = build_load_path opts in + List.iter Mltop.add_ml_dir ml_lp; + List.iter Loadpath.add_vo_path vo_lp; (* Vio compile pass *) if copts.vio_files <> [] then schedule_vio copts; diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index 949a13974c..ef97e57a5c 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -70,8 +70,8 @@ type coqargs_pre = { load_init : bool; load_rcfile : bool; - ml_includes : Loadpath.coq_path list; - vo_includes : Loadpath.coq_path list; + ml_includes : string list; + vo_includes : Loadpath.vo_path list; vo_requires : (string * string option * bool option) list; (* None = No Import; Some false = Import; Some true = Export *) @@ -164,14 +164,13 @@ let default = { (* Functional arguments *) (******************************************************************************) let add_ml_include opts s = - Loadpath.{ opts with pre = { opts.pre with ml_includes = {recursive = false; path_spec = MlPath s} :: opts.pre.ml_includes }} + { opts with pre = { opts.pre with ml_includes = 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 pre = { opts.pre with vo_includes = { - recursive = true; - path_spec = VoPath { unix_path; coq_path; has_ml = AddNoML; implicit } } :: opts.pre.vo_includes }} + unix_path; coq_path; has_ml = false; implicit; recursive = true } :: opts.pre.vo_includes }} let add_vo_require opts d p export = { opts with pre = { opts.pre with vo_requires = (d, p, export) :: opts.pre.vo_requires }} @@ -582,9 +581,11 @@ let prelude_data = "Prelude", Some "Coq", Some false let require_libs opts = if opts.pre.load_init then prelude_data :: opts.pre.vo_requires else opts.pre.vo_requires -let cmdline_load_path opts = - opts.pre.ml_includes @ opts.pre.vo_includes - let build_load_path opts = - (if opts.pre.boot then [] else Coqinit.libs_init_load_path ()) @ - cmdline_load_path opts + let ml_path, vo_path = + if opts.pre.boot then [],[] + else + let coqlib = Envars.coqlib () in + Coqinit.libs_init_load_path ~coqlib in + ml_path @ opts.pre.ml_includes , + vo_path @ opts.pre.vo_includes diff --git a/toplevel/coqargs.mli b/toplevel/coqargs.mli index aba6811f43..88de48967a 100644 --- a/toplevel/coqargs.mli +++ b/toplevel/coqargs.mli @@ -46,8 +46,8 @@ type coqargs_pre = { load_init : bool; load_rcfile : bool; - ml_includes : Loadpath.coq_path list; - vo_includes : Loadpath.coq_path list; + ml_includes : CUnix.physical_path list; + vo_includes : Loadpath.vo_path list; vo_requires : (string * string option * bool option) list; (* None = No Import; Some false = Import; Some true = Export *) @@ -83,4 +83,4 @@ val parse_args : help:Usage.specific_usage -> init:t -> string list -> t * strin 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 +val build_load_path : t -> CUnix.physical_path list * Loadpath.vo_path list diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml index 7f3d4b570f..4041d02953 100644 --- a/toplevel/coqinit.ml +++ b/toplevel/coqinit.ml @@ -47,66 +47,46 @@ let load_rcfile ~rcfile ~state = " found. Skipping rcfile loading.")) *) with reraise -> - let reraise = CErrors.push reraise in + let reraise = Exninfo.capture reraise in let () = Feedback.msg_info (str"Load of rcfile failed.") in - iraise reraise + Exninfo.iraise reraise -(* Recursively puts `.v` files in the LoadPath if -nois was not passed *) +(* Recursively puts `.v` files in the LoadPath *) let build_stdlib_vo_path ~unix_path ~coq_path = let open Loadpath in - { recursive = true; - path_spec = VoPath { unix_path; coq_path ; has_ml = AddNoML; implicit = true } - } - -let build_stdlib_ml_path ~dir = - let open Loadpath in - { recursive = true - ; path_spec = MlPath dir - } + { unix_path; coq_path ; has_ml = false; implicit = true; recursive = true } let build_userlib_path ~unix_path = let open Loadpath in - { recursive = true; - path_spec = VoPath { - unix_path; - coq_path = Libnames.default_root_prefix; - has_ml = AddRecML; - implicit = false; - } + { unix_path + ; coq_path = Libnames.default_root_prefix + ; has_ml = true + ; implicit = false + ; recursive = true } -let ml_path_if c p = - let open Loadpath in - let f x = { recursive = false; path_spec = MlPath x } in - if c then List.map f p else [] - -(* LoadPath for developers *) -let toplevel_init_load_path () = - let coqlib = Envars.coqlib () in - (* NOTE: These directories are searched from last to first *) - (* first, developer specific directory to open *) - ml_path_if Coq_config.local [coqlib/"dev"] - (* LoadPath for Coq user libraries *) -let libs_init_load_path () = +let libs_init_load_path ~coqlib = let open Loadpath in - let coqlib = Envars.coqlib () in let user_contrib = coqlib/"user-contrib" in let xdg_dirs = Envars.xdg_dirs ~warn:(fun x -> Feedback.msg_warning (str x)) in let coqpath = Envars.coqpath in let coq_path = Names.DirPath.make [Libnames.coq_root] in + (* ML includes *) + let plugins_dirs = System.all_subdirs ~unix_path:(coqlib/"plugins") in + List.map fst plugins_dirs, + (* current directory (not recursively!) *) - [ { recursive = false; - path_spec = VoPath { unix_path = "."; - coq_path = Libnames.default_root_prefix; - implicit = false; - has_ml = AddTopML } + [ { unix_path = "." + ; coq_path = Libnames.default_root_prefix + ; implicit = false + ; has_ml = true + ; recursive = false } ] @ (* then standard library *) - [build_stdlib_ml_path ~dir:(coqlib/"plugins")] @ [build_stdlib_vo_path ~unix_path:(coqlib/"theories") ~coq_path] @ (* then user-contrib *) @@ -116,14 +96,3 @@ let libs_init_load_path () = (* then directories in XDG_DATA_DIRS and XDG_DATA_HOME and COQPATH *) List.map (fun s -> build_userlib_path ~unix_path:s) (xdg_dirs @ coqpath) - -(* Initialises the Ocaml toplevel before launching it, so that it can - find the "include" file in the *source* directory *) -let init_ocaml_path () = - let open Loadpath in - let lp s = { recursive = false; path_spec = MlPath s } in - let add_subdir dl = - Loadpath.add_coq_path (lp (List.fold_left (/) (Envars.coqlib()) [dl])) - in - Loadpath.add_coq_path (lp (Envars.coqlib ())); - List.iter add_subdir Coq_config.all_src_dirs diff --git a/toplevel/coqinit.mli b/toplevel/coqinit.mli index f3a007d987..eb6b37000e 100644 --- a/toplevel/coqinit.mli +++ b/toplevel/coqinit.mli @@ -14,10 +14,7 @@ val set_debug : unit -> unit val load_rcfile : rcfile:(string option) -> state:Vernac.State.t -> Vernac.State.t -val init_ocaml_path : unit -> unit - -(* LoadPath for toploop toplevels *) -val toplevel_init_load_path : unit -> Loadpath.coq_path list - (* LoadPath for Coq user libraries *) -val libs_init_load_path : unit -> Loadpath.coq_path list +val libs_init_load_path + : coqlib:CUnix.physical_path + -> CUnix.physical_path list * Loadpath.vo_path list diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index e4508e9bfc..7ff58039d4 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -265,7 +265,7 @@ let read_sentence ~state input = let open Vernac.State in try Stm.parse_sentence ~doc:state.doc state.sid ~entry:G_toplevel.vernac_toplevel input with reraise -> - let reraise = CErrors.push reraise in + let reraise = Exninfo.capture reraise in discard_to_dot (); (* The caller of read_sentence does the error printing now, this should be re-enabled once we rely on the feedback error @@ -360,7 +360,7 @@ let top_goal_print ~doc c oldp newp = end with | exn -> - let (e, info) = CErrors.push exn in + let (e, info) = Exninfo.capture exn in let loc = Loc.get_loc info in let msg = CErrors.iprint (e, info) in TopErr.print_error_for_buffer ?loc Feedback.Error msg top_buffer @@ -484,7 +484,7 @@ let read_and_execute ~state = TopErr.print_error_for_buffer Feedback.Error msg top_buffer; exit 1 | any -> - let (e, info) = CErrors.push any in + let (e, info) = Exninfo.capture any in let loc = Loc.get_loc info in let msg = CErrors.iprint (e, info) in TopErr.print_error_for_buffer ?loc Feedback.Error msg top_buffer; @@ -501,10 +501,16 @@ let rec vernac_loop ~state = let state, drop = read_and_execute ~state in if drop then state else vernac_loop ~state -(* Default toplevel loop *) +(* Default toplevel loop, machinery for drop is below *) let drop_args = ref None +(* Initialises the Ocaml toplevel before launching it, so that it can + find the "include" file in the *source* directory *) +let init_ocaml_path ~coqlib = + let add_subdir dl = Mltop.add_ml_dir (Filename.concat coqlib dl) in + List.iter add_subdir ("dev" :: Coq_config.all_src_dirs) + let loop ~opts ~state = drop_args := Some opts; let open Coqargs in @@ -517,7 +523,8 @@ let loop ~opts ~state = (* Call the main loop *) let _ : Vernac.State.t = vernac_loop ~state in (* Initialise and launch the Ocaml toplevel *) - Coqinit.init_ocaml_path(); + let coqlib = Envars.coqlib () in + init_ocaml_path ~coqlib; Mltop.ocaml_toploop(); (* We delete the feeder after the OCaml toploop has ended so users of Drop can see the feedback. *) diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 1ea48ee766..876388092d 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -155,19 +155,22 @@ let print_style_tags opts = let () = List.iter iter tags in flush_all () -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_coqlib opts = match opts.config.coqlib with + | None when opts.pre.boot -> () + | None -> + Envars.set_coqlib ~fail:(fun msg -> CErrors.user_err Pp.(str msg)); + | Some s -> + Envars.set_user_coqlib s let print_query opts = function | PrintVersion -> Usage.version () | PrintMachineReadableVersion -> Usage.machine_readable_version () | PrintWhere -> - let () = init_setup opts.config.coqlib in + let () = init_coqlib opts in print_endline (Envars.coqlib ()) | PrintHelp h -> Usage.print_usage stderr h | PrintConfig -> - let () = init_setup opts.config.coqlib in + let () = init_coqlib opts in Envars.print_config stdout Coq_config.all_src_dirs | PrintTags -> print_style_tags opts.config @@ -217,16 +220,12 @@ let init_parse parse_extra help init_opts = end; opts, customopts +(** Coq's init process, phase 2: Basic Coq environment, plugins. *) let init_execution opts custom_init = - (* Coq's init process, phase 2: - Basic Coq environment, load-path, plugins. - *) (* 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 (); 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; CoqworkmgrApi.(init opts.config.stm_flags.Stm.AsyncOpts.async_proofs_worker_priority); Mltop.init_known_plugins (); (* Configuration *) @@ -268,7 +267,7 @@ let init_toplevel custom = match opts.main with | Queries q -> List.iter (print_query opts) q; exit 0 | Run -> - let () = init_setup opts.config.coqlib in + let () = init_coqlib opts in let customstate = init_execution opts (custom.init customopts) in opts, customopts, customstate @@ -281,14 +280,14 @@ let init_document opts = *) (* Next line allows loading .vos files when in interactive mode *) Flags.load_vos_libraries := true; - let iload_path = build_load_path opts in + let ml_load_path, vo_load_path = build_load_path opts in let require_libs = require_libs opts in let stm_options = opts.config.stm_flags in let open Vernac.State in let doc, sid = Stm.(new_doc { doc_type = Interactive opts.config.logic.toplevel_name; - iload_path; require_libs; stm_options; + ml_load_path; vo_load_path; require_libs; stm_options; }) in { doc; sid; proof = None; time = opts.config.time } diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index adcce67b0d..8e6cd8f4c7 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -69,7 +69,7 @@ let interp_vernac ~check ~interactive ~state ({CAst.loc;_} as com) = let new_proof = Vernacstate.Proof_global.give_me_the_proof_opt () [@ocaml.warning "-3"] in { state with doc = ndoc; sid = nsid; proof = new_proof; } with reraise -> - let (reraise, info) = CErrors.push reraise in + let (reraise, info) = Exninfo.capture reraise in (* XXX: In non-interactive mode edit_at seems to do very weird things, so we better avoid it while we investigate *) if interactive then ignore(Stm.edit_at ~doc:state.doc state.sid); @@ -77,7 +77,8 @@ let interp_vernac ~check ~interactive ~state ({CAst.loc;_} as com) = match Loc.get_loc info with | None -> Option.cata (Loc.add_loc info) info loc | Some _ -> info - end in iraise (reraise, info) + end in + Exninfo.iraise (reraise, info) (* Load a vernac file. CErrors are annotated with file and location *) let load_vernac_core ~echo ~check ~interactive ~state file = @@ -113,9 +114,9 @@ let load_vernac_core ~echo ~check ~interactive ~state file = in try loop state [] with any -> (* whatever the exception *) - let (e, info) = CErrors.push any in + let (e, info) = Exninfo.capture any in input_cleanup (); - iraise (e, info) + Exninfo.iraise (e, info) let process_expr ~state loc_ast = interp_vernac ~interactive:true ~check:true ~state loc_ast diff --git a/user-contrib/Ltac2/Notations.v b/user-contrib/Ltac2/Notations.v index b650c1a2ec..d6bf4a28ba 100644 --- a/user-contrib/Ltac2/Notations.v +++ b/user-contrib/Ltac2/Notations.v @@ -265,6 +265,19 @@ Ltac2 Notation "assert" ast(thunk(assert)) := assert0 false ast. Ltac2 Notation "eassert" ast(thunk(assert)) := assert0 true ast. +Ltac2 enough_from_assertion(a : Std.assertion) := + match a with + | Std.AssertType ip_opt term tac_opt => Std.enough term (Some tac_opt) ip_opt + | Std.AssertValue ident constr => Std.pose (Some ident) constr + end. + +Ltac2 enough0 ev ast := + enter_h ev (fun _ ast => enough_from_assertion ast) ast. + +Ltac2 Notation "enough" ast(thunk(assert)) := enough0 false ast. + +Ltac2 Notation "eenough" ast(thunk(assert)) := enough0 true ast. + Ltac2 default_everywhere cl := match cl with | None => { Std.on_hyps := None; Std.on_concl := Std.AllOccurrences } diff --git a/user-contrib/Ltac2/tac2core.ml b/user-contrib/Ltac2/tac2core.ml index 196b28b274..f66ed7b4cf 100644 --- a/user-contrib/Ltac2/tac2core.ml +++ b/user-contrib/Ltac2/tac2core.ml @@ -573,7 +573,7 @@ let () = define1 "constr_check" constr begin fun c -> Proofview.Unsafe.tclEVARS sigma >>= fun () -> return (of_result Value.of_constr (Inl c)) with e when CErrors.noncritical e -> - let e = CErrors.push e in + let e = Exninfo.capture e in return (of_result Value.of_constr (Inr e)) end end @@ -1079,7 +1079,7 @@ let interp_constr flags ist c = Proofview.Unsafe.tclEVARS sigma >>= fun () -> Proofview.tclUNIT c with e when catchable_exception e -> - let (e, info) = CErrors.push e in + let (e, info) = Exninfo.capture e in set_bt info >>= fun info -> match Exninfo.get info fatal_flag with | None -> Proofview.tclZERO ~info e diff --git a/user-contrib/Ltac2/tac2entries.ml b/user-contrib/Ltac2/tac2entries.ml index 2a0c109a42..2820d3e3ad 100644 --- a/user-contrib/Ltac2/tac2entries.ml +++ b/user-contrib/Ltac2/tac2entries.ml @@ -862,7 +862,7 @@ let () = CErrors.register_additional_error_info begin fun info -> let bt = str "Backtrace:" ++ fnl () ++ prlist_with_sep fnl pr_frame bt ++ fnl () in - Some (Loc.tag @@ Some bt) + Some (Loc.tag bt) else None end diff --git a/vernac/classes.ml b/vernac/classes.ml index b92c9e9b71..16b9e07fb2 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -60,7 +60,9 @@ let add_instance check inst = let local = is_local_for_hint inst in add_instance_hint (Hints.IsGlobRef inst.is_impl) [inst.is_impl] local inst.is_info poly; - List.iter (fun (path, pri, c) -> add_instance_hint (Hints.IsConstr (EConstr.of_constr c, Univ.ContextSet.empty)) path + List.iter (fun (path, pri, c) -> + let h = Hints.IsConstr (EConstr.of_constr c, Univ.ContextSet.empty) [@ocaml.warning "-3"] in + add_instance_hint h path local pri poly) (build_subclasses ~check:(check && not (isVarRef inst.is_impl)) (Global.env ()) (Evd.from_env (Global.env ())) inst.is_impl inst.is_info) diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index d97bf6724c..2e9f0283ca 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -277,18 +277,3 @@ let context ~poly l = if Global.sections_are_opened () then context_insection sigma ~poly ctx else context_nosection sigma ~poly ctx - -(* Deprecated *) -let declare_assumption is_coe ~poly ~scope ~kind typ univs pl imps impl nl name = -let open DeclareDef in -match scope with -| Discharge -> - let univs = match univs with - | Monomorphic_entry univs -> univs - | Polymorphic_entry (_, univs) -> Univ.ContextSet.of_context univs - in - let () = Declare.declare_universe_context ~poly univs in - declare_variable is_coe ~kind typ imps impl name; - GlobRef.VarRef name.CAst.v, Univ.Instance.empty -| Global local -> - declare_axiom is_coe ~poly ~local ~kind typ (univs, pl) imps nl name diff --git a/vernac/comAssumption.mli b/vernac/comAssumption.mli index ae9edefcac..f5192fc696 100644 --- a/vernac/comAssumption.mli +++ b/vernac/comAssumption.mli @@ -50,19 +50,3 @@ val context : poly:bool -> local_binder_expr list -> unit - -(** Deprecated *) -val declare_assumption - : coercion_flag - -> poly:bool - -> scope:DeclareDef.locality - -> kind:Decls.assumption_object_kind - -> Constr.types - -> Entries.universes_entry - -> UnivNames.universe_binders - -> Impargs.manual_implicits - -> Glob_term.binding_kind - -> Declaremods.inline - -> variable CAst.t - -> GlobRef.t * Univ.Instance.t -[@@ocaml.deprecated "Use declare_variable or declare_axiom instead."] diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index b6843eab33..65dffb3c0b 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -255,8 +255,8 @@ let declare_fixpoint_interactive_generic ?indexes ~scope ~poly ((fixnames,_fixrs | None -> Decls.CoFixpoint, true, [] in let thms = - List.map3 (fun name t (ctx,impargs,_) -> - { Lemmas.Recthm.name; typ = EConstr.of_constr t + List.map3 (fun name typ (ctx,impargs,_) -> + { Lemmas.Recthm.name; typ ; args = List.map RelDecl.get_name ctx; impargs}) fixnames fixtypes fiximps in let init_tac = @@ -272,8 +272,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, Decls.Fixpoint - | None -> [], true, Decls.CoFixpoint + | Some indexes -> indexes, false, Decls.(IsDefinition Fixpoint) + | None -> [], true, Decls.(IsDefinition CoFixpoint) in (* We shortcut the proof process *) let fixdefs = List.map Option.get fixdefs in @@ -294,11 +294,13 @@ let declare_fixpoint_generic ?indexes ~scope ~poly ((fixnames,fixrs,fixdefs,fixt let evd = Evd.from_ctx ctx in let evd = Evd.restrict_universe_context evd vars in let ctx = Evd.check_univ_decl ~poly evd pl in - let pl = Evd.universe_binders evd in - let mk_pure c = (c, Univ.ContextSet.empty), Evd.empty_side_effects in - let fixdecls = List.map mk_pure fixdecls in - ignore (List.map4 (fun name -> DeclareDef.declare_fix ~name ~scope ~kind:fix_kind pl ctx) - fixnames fixdecls fixtypes fiximps); + let udecl = Evd.universe_binders evd in + let _ : GlobRef.t list = + List.map4 (fun name body types imps -> + let ce = Declare.definition_entry ~opaque:false ~types ~univs:ctx body in + DeclareDef.declare_definition ~name ~scope ~kind:fix_kind udecl ce imps) + fixnames fixdecls fixtypes fiximps + in recursive_message (not cofix) gidx fixnames; List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns; () diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index edb03a5c89..718e62b9b7 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -329,10 +329,7 @@ let template_polymorphism_candidate ~ctor_levels uctx params concl = if not concltemplate then false else let conclu = Option.cata Sorts.univ_of_sort Univ.type0m_univ concl in - let params, conclunivs = - IndTyping.template_polymorphic_univs ~ctor_levels uctx params conclu - in - not (Univ.LSet.is_empty conclunivs) + Option.has_some @@ IndTyping.template_polymorphic_univs ~ctor_levels uctx params conclu | Entries.Polymorphic_entry _ -> false let check_param = function @@ -370,6 +367,14 @@ let interp_mutual_inductive_constr ~sigma ~template ~udecl ~ctx_params ~indnames (* Build the inductive entries *) let entries = List.map4 (fun indname (templatearity, arity) concl (cnames,ctypes) -> + { mind_entry_typename = indname; + mind_entry_arity = arity; + mind_entry_consnames = cnames; + mind_entry_lc = ctypes + }) + indnames arities arityconcl constructors + in + let template = List.map4 (fun indname (templatearity, _) concl (_, ctypes) -> let template_candidate () = templatearity || let ctor_levels = @@ -385,22 +390,17 @@ let interp_mutual_inductive_constr ~sigma ~template ~udecl ~ctx_params ~indnames in template_polymorphism_candidate ~ctor_levels uctx ctx_params concl in - let template = match template with + match template with | Some template -> if poly && template then user_err Pp.(strbrk "Template-polymorphism and universe polymorphism are not compatible."); template | None -> should_auto_template indname (template_candidate ()) - in - { mind_entry_typename = indname; - mind_entry_arity = arity; - mind_entry_template = template; - mind_entry_consnames = cnames; - mind_entry_lc = ctypes - }) + ) indnames arities arityconcl constructors in + let is_template = List.for_all (fun t -> t) template in (* Build the mutual inductive entry *) let mind_ent = { mind_entry_params = ctx_params; @@ -409,6 +409,7 @@ let interp_mutual_inductive_constr ~sigma ~template ~udecl ~ctx_params ~indnames mind_entry_inds = entries; mind_entry_private = if private_ind then Some false else None; mind_entry_universes = uctx; + mind_entry_template = is_template; mind_entry_cumulative = poly && cumulative; } in diff --git a/vernac/declareDef.ml b/vernac/declareDef.ml index e57c324c9a..39fd332184 100644 --- a/vernac/declareDef.ml +++ b/vernac/declareDef.ml @@ -37,40 +37,59 @@ module Hook = struct let call ?hook ?fix_exn x = try Option.iter (fun hook -> CEphemeron.get hook x) hook with e when CErrors.noncritical e -> - let e = CErrors.push e in + let e = Exninfo.capture e in let e = Option.cata (fun fix -> fix e) e fix_exn in - Util.iraise e + Exninfo.iraise e end (* Locality stuff *) let declare_definition ~name ~scope ~kind ?hook_data udecl ce imps = let fix_exn = Declare.Internal.get_fix_exn ce in - let gr = match scope with + let should_suggest = ce.Declare.proof_entry_opaque && + Option.is_empty ce.Declare.proof_entry_secctx in + let dref = match scope with | Discharge -> - let () = - declare_variable ~name ~kind (SectionLocalDef ce) - in - Names.GlobRef.VarRef name + let () = declare_variable ~name ~kind (SectionLocalDef ce) in + if should_suggest then Proof_using.suggest_variable (Global.env ()) name; + Names.GlobRef.VarRef name | Global local -> - let kn = declare_constant ~name ~local ~kind (DefinitionEntry ce) in - let gr = Names.GlobRef.ConstRef kn in - let () = DeclareUniv.declare_univ_binders gr udecl in - gr + let kn = declare_constant ~name ~local ~kind (DefinitionEntry ce) in + let gr = Names.GlobRef.ConstRef kn in + if should_suggest then Proof_using.suggest_constant (Global.env ()) kn; + let () = DeclareUniv.declare_univ_binders gr udecl in + gr in - let () = maybe_declare_manual_implicits false gr imps in + let () = maybe_declare_manual_implicits false dref imps in let () = definition_message name in begin match hook_data with | None -> () | Some (hook, uctx, obls) -> - Hook.call ~fix_exn ~hook { Hook.S.uctx; obls; scope; dref = gr } + Hook.call ~fix_exn ~hook { Hook.S.uctx; obls; scope; dref } end; - gr + dref -let declare_fix ?(opaque = false) ?hook_data ~name ~scope ~kind udecl univs ((def,_),eff) t imps = - let ce = definition_entry ~opaque ~types:t ~univs ~eff def in - let kind = Decls.IsDefinition kind in - declare_definition ~name ~scope ~kind ?hook_data udecl ce imps +let warn_let_as_axiom = + CWarnings.create ~name:"let-as-axiom" ~category:"vernacular" + Pp.(fun id -> strbrk "Let definition" ++ spc () ++ Names.Id.print id ++ + spc () ++ strbrk "declared as an axiom.") + +let declare_assumption ?fix_exn ~name ~scope ~hook ~impargs ~uctx pe = + let local = match scope with + | Discharge -> warn_let_as_axiom name; Declare.ImportNeedQualified + | Global local -> local + in + let kind = Decls.(IsAssumption Conjectural) in + let decl = Declare.ParameterEntry pe in + let kn = Declare.declare_constant ~name ~local ~kind decl in + let dref = Names.GlobRef.ConstRef kn in + let () = Impargs.maybe_declare_manual_implicits false dref impargs in + let () = Declare.assumption_message name in + let () = DeclareUniv.declare_univ_binders dref (UState.universe_binders uctx) in + let () = Hook.(call ?fix_exn ?hook { S.uctx; obls = []; scope; dref}) in + dref + +(* Preparing proof entries *) let check_definition_evars ~allow_evars sigma = let env = Global.env () in diff --git a/vernac/declareDef.mli b/vernac/declareDef.mli index 1bb6620886..c668ab2ac4 100644 --- a/vernac/declareDef.mli +++ b/vernac/declareDef.mli @@ -49,17 +49,14 @@ val declare_definition -> Impargs.manual_implicits -> GlobRef.t -val declare_fix - : ?opaque:bool - -> ?hook_data:(Hook.t * UState.t * (Id.t * Constr.t) list) +val declare_assumption + : ?fix_exn:(Exninfo.iexn -> Exninfo.iexn) -> name:Id.t -> scope:locality - -> kind:Decls.definition_object_kind - -> UnivNames.universe_binders - -> Entries.universes_entry - -> Evd.side_effects Entries.proof_output - -> Constr.types - -> Impargs.manual_implicits + -> hook:Hook.t option + -> impargs:Impargs.manual_implicits + -> uctx:UState.t + -> Entries.parameter_entry -> GlobRef.t val prepare_definition diff --git a/vernac/declareObl.ml b/vernac/declareObl.ml index dcb28b898f..eb9b896ec6 100644 --- a/vernac/declareObl.ml +++ b/vernac/declareObl.ml @@ -376,9 +376,6 @@ let compute_possible_guardness_evidences n fixbody fixtype = let ctx = fst (Term.decompose_prod_n_assum m fixtype) in List.map_i (fun i _ -> i) 0 ctx -let mk_proof c = - ((c, Univ.ContextSet.empty), Evd.empty_side_effects) - let declare_mutual_definition l = let len = List.length l in let first = List.hd l in @@ -410,7 +407,6 @@ 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 Decls.Fixpoint else Decls.CoFixpoint in let indexes, fixdecls = match fixkind with | IsFixpoint wfl -> @@ -421,20 +417,23 @@ let declare_mutual_definition l = Pretyping.search_guard (Global.env ()) possible_indexes fixdecls in ( Some indexes - , List.map_i (fun i _ -> mk_proof (mkFix ((indexes, i), fixdecls))) 0 l + , List.map_i (fun i _ -> mkFix ((indexes, i), fixdecls)) 0 l ) | IsCoFixpoint -> - (None, List.map_i (fun i _ -> mk_proof (mkCoFix (i, fixdecls))) 0 l) + (None, List.map_i (fun i _ -> mkCoFix (i, fixdecls)) 0 l) in (* Declare the recursive definitions *) let poly = first.prg_poly in let scope = first.prg_scope in let univs = UState.univ_entry ~poly first.prg_ctx in let fix_exn = Hook.get get_fix_exn () in + let kind = Decls.IsDefinition (if fixkind != IsCoFixpoint then Decls.Fixpoint else Decls.CoFixpoint) in + let udecl = UnivNames.empty_binders in let kns = List.map4 - (fun name -> DeclareDef.declare_fix ~name ~opaque ~scope ~kind - UnivNames.empty_binders univs) + (fun name body types imps -> + let ce = Declare.definition_entry ~opaque ~types ~univs body in + DeclareDef.declare_definition ~name ~scope ~kind udecl ce imps) fixnames fixdecls fixtypes fiximps in (* Declare notations *) diff --git a/vernac/declaremods.ml b/vernac/declaremods.ml index c816a4eb4f..e645fc552b 100644 --- a/vernac/declaremods.ml +++ b/vernac/declaremods.ml @@ -935,9 +935,9 @@ let protect_summaries f = try f fs with reraise -> (* Something wrong: undo the whole process *) - let reraise = CErrors.push reraise in + let reraise = Exninfo.capture reraise in let () = Summary.unfreeze_summaries fs in - iraise reraise + Exninfo.iraise reraise let start_module export id args res = protect_summaries (RawModOps.start_module export id args res) diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 8486de3aed..c1414c552a 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -44,11 +44,12 @@ let quoted_attributes = Entry.create "vernac:quoted_attributes" let class_rawexpr = Entry.create "vernac:class_rawexpr" let thm_token = Entry.create "vernac:thm_token" let def_body = Entry.create "vernac:def_body" -let decl_notation = Entry.create "vernac:decl_notation" +let decl_notations = Entry.create "vernac:decl_notations" let record_field = Entry.create "vernac:record_field" let of_type_with_opt_coercion = Entry.create "vernac:of_type_with_opt_coercion" let section_subset_expr = Entry.create "vernac:section_subset_expr" let scope_delimiter = Entry.create "vernac:scope_delimiter" +let only_parsing = Entry.create "vernac:only_parsing" let make_bullet s = let open Proof_bullet in @@ -176,7 +177,7 @@ let name_of_ident_decl : ident_decl -> name_decl = (* Gallina declarations *) GRAMMAR EXTEND Gram GLOBAL: gallina gallina_ext thm_token def_body of_type_with_opt_coercion - record_field decl_notation rec_definition ident_decl univ_decl; + record_field decl_notations rec_definition ident_decl univ_decl; gallina: (* Definition, Theorem, Variable, Axiom, ... *) @@ -376,15 +377,17 @@ GRAMMAR EXTEND Gram [ [ IDENT "Eval"; r = red_expr; "in" -> { Some r } | -> { None } ] ] ; - one_decl_notation: - [ [ ntn = ne_lstring; ":="; c = constr; - scopt = OPT [ ":"; sc = IDENT -> { sc } ] -> { (ntn,c,scopt) } ] ] + decl_notation: + [ [ ntn = ne_lstring; ":="; c = constr; b = only_parsing; + scopt = OPT [ ":"; sc = IDENT -> { sc } ] -> + { { decl_ntn_string = ntn; decl_ntn_interp = c; + decl_ntn_only_parsing = b; decl_ntn_scope = scopt } } ] ] ; decl_sep: [ [ IDENT "and" -> { () } ] ] ; - decl_notation: - [ [ "where"; l = LIST1 one_decl_notation SEP decl_sep -> { l } + decl_notations: + [ [ "where"; l = LIST1 decl_notation SEP decl_sep -> { l } | -> { [] } ] ] ; (* Inductives and records *) @@ -396,7 +399,7 @@ GRAMMAR EXTEND Gram [ [ oc = opt_coercion; id = ident_decl; indpar = binders; extrapar = OPT [ "|"; p = binders -> { p } ]; c = OPT [ ":"; c = lconstr -> { c } ]; - lc=opt_constructors_or_fields; ntn = decl_notation -> + lc=opt_constructors_or_fields; ntn = decl_notations -> { (((oc,id),(indpar,extrapar),c,lc),ntn) } ] ] ; constructor_list_or_record_decl: @@ -423,14 +426,14 @@ GRAMMAR EXTEND Gram [ [ id_decl = ident_decl; bl = binders_fixannot; rtype = type_cstr; - body_def = OPT [":="; def = lconstr -> { def } ]; notations = decl_notation -> + body_def = OPT [":="; def = lconstr -> { def } ]; notations = decl_notations -> { let binders, rec_order = bl in {fname = fst id_decl; univs = snd id_decl; rec_order; binders; rtype; body_def; notations} } ] ] ; corec_definition: [ [ id_decl = ident_decl; binders = binders; rtype = type_cstr; - body_def = OPT [":="; def = lconstr -> { def }]; notations = decl_notation -> + body_def = OPT [":="; def = lconstr -> { def }]; notations = decl_notations -> { {fname = fst id_decl; univs = snd id_decl; rec_order = (); binders; rtype; body_def; notations} } ]] ; @@ -466,7 +469,7 @@ GRAMMAR EXTEND Gram record_field: [ [ attr = LIST0 quoted_attributes ; bd = record_binder; rf_priority = OPT [ "|"; n = natural -> { n } ]; - rf_notation = decl_notation -> { + rf_notation = decl_notations -> { let rf_canonical = attr |> List.flatten |> parse canonical_field in let rf_subclass, rf_decl = bd in rf_decl, { rf_subclass ; rf_priority ; rf_notation ; rf_canonical } } ] ] @@ -912,10 +915,11 @@ GRAMMAR EXTEND Gram | IDENT "Locate"; l = locatable -> { VernacLocate l } (* Managing load paths *) - | IDENT "Add"; IDENT "LoadPath"; dir = ne_string; alias = as_dirpath -> - { VernacAddLoadPath (false, dir, alias) } - | IDENT "Add"; IDENT "Rec"; IDENT "LoadPath"; dir = ne_string; - alias = as_dirpath -> { VernacAddLoadPath (true, dir, alias) } + | IDENT "Add"; IDENT "LoadPath"; physical_path = ne_string; "as"; logical_path = dirpath -> + { VernacAddLoadPath { implicit = false; logical_path; physical_path } } + | IDENT "Add"; IDENT "Rec"; IDENT "LoadPath"; physical_path = ne_string; "as"; logical_path = dirpath -> + { VernacAddLoadPath { implicit = true; logical_path; physical_path } } + | IDENT "Remove"; IDENT "LoadPath"; dir = ne_string -> { VernacRemoveLoadPath dir } @@ -934,9 +938,7 @@ GRAMMAR EXTEND Gram | IDENT "Inspect"; n = natural -> { VernacPrint (PrintInspect n) } | IDENT "Add"; IDENT "ML"; IDENT "Path"; dir = ne_string -> - { VernacAddMLPath (false, dir) } - | IDENT "Add"; IDENT "Rec"; IDENT "ML"; IDENT "Path"; dir = ne_string -> - { VernacAddMLPath (true, dir) } + { VernacAddMLPath dir } (* For acting on parameter tables *) | "Set"; table = option_table; v = option_setting -> @@ -1070,9 +1072,6 @@ GRAMMAR EXTEND Gram option_table: [ [ fl = LIST1 [ x = IDENT -> { x } ] -> { fl } ]] ; - as_dirpath: - [ [ d = OPT [ "as"; d = dirpath -> { d } ] -> { d } ] ] - ; ne_in_or_out_modules: [ [ IDENT "inside"; l = LIST1 global -> { SearchInside l } | IDENT "outside"; l = LIST1 global -> { SearchOutside l } ] ] @@ -1149,7 +1148,7 @@ GRAMMAR EXTEND Gram (* Grammar extensions *) GRAMMAR EXTEND Gram - GLOBAL: syntax; + GLOBAL: syntax only_parsing; syntax: [ [ IDENT "Open"; IDENT "Scope"; sc = IDENT -> diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index 227d2f1554..80616ecc2a 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -118,7 +118,7 @@ let alarm what internal msg = let try_declare_scheme what f internal names kn = try f internal names kn with e -> - let e = CErrors.push e in + let e = Exninfo.capture e in let rec extract_exn = function Logic_monad.TacticFailure e -> extract_exn e | e -> e in let msg = match extract_exn (fst e) with | ParameterWithoutEquality cst -> @@ -166,11 +166,11 @@ let try_declare_scheme what f internal names kn = | e when CErrors.noncritical e -> alarm what internal (str "Unexpected error during scheme creation: " ++ CErrors.print e) - | _ -> iraise e + | _ -> Exninfo.iraise e in match msg with | None -> () - | Some msg -> iraise (UserError (None, msg), snd e) + | Some msg -> Exninfo.iraise (UserError (None, msg), snd e) let beq_scheme_msg mind = let mib = Global.lookup_mind mind in diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index f7606f4ede..231bdafce9 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -11,15 +11,8 @@ (* Created by Hugo Herbelin from contents related to lemma proofs in file command.ml, Aug 2009 *) -open CErrors open Util -open Pp open Names -open Constr -open Declareops -open Nameops -open Pretyping -open Impargs module NamedDecl = Context.Named.Declaration @@ -49,7 +42,7 @@ end module Recthm = struct type t = { name : Id.t - ; typ : EConstr.t + ; typ : Constr.t ; args : Name.t list ; impargs : Impargs.manual_implicits } @@ -136,7 +129,7 @@ let start_dependent_lemma ~name ~poly let rec_tac_initializer finite guard thms snl = if finite then - match List.map (fun { Recthm.name; typ } -> name,typ) thms with + match List.map (fun { Recthm.name; typ } -> name, (EConstr.of_constr typ)) thms with | (id,_)::l -> Tactics.mutual_cofix id l 0 | _ -> assert false else @@ -144,7 +137,7 @@ let rec_tac_initializer finite guard thms snl = let nl = match snl with | None -> List.map succ (List.map List.last guard) | Some nl -> nl - in match List.map2 (fun { Recthm.name; typ } n -> (name, n, typ)) thms nl with + in match List.map2 (fun { Recthm.name; typ } n -> (name, n, (EConstr.of_constr typ))) thms nl with | (id,n,_)::l -> Tactics.mutual_fix id n l 0 | _ -> assert false @@ -164,7 +157,7 @@ let start_lemma_with_initialization ?hook ~poly ~scope ~kind ~udecl sigma recgua let () = match thms with [_] -> () | _ -> assert false in Some (intro_tac (List.hd thms)), [] in match thms with - | [] -> anomaly (Pp.str "No proof to start.") + | [] -> CErrors.anomaly (Pp.str "No proof to start.") | { Recthm.name; typ; impargs; _}::other_thms -> let info = Info.{ hook @@ -175,7 +168,7 @@ let start_lemma_with_initialization ?hook ~poly ~scope ~kind ~udecl sigma recgua ; scope ; kind } in - let lemma = start_lemma ~name ~poly ~udecl ~info sigma typ in + let lemma = start_lemma ~name ~poly ~udecl ~info sigma (EConstr.of_constr typ) in pf_map (Proof_global.map_proof (fun p -> match init_tac with | None -> p @@ -185,132 +178,167 @@ let start_lemma_with_initialization ?hook ~poly ~scope ~kind ~udecl sigma recgua (* Commom constant saving path, for both Qed and Admitted *) (************************************************************************) -(* Helper for process_recthms *) -let retrieve_first_recthm uctx = function - | 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 - -(* Helper for process_recthms *) -let save_remaining_recthms env sigma ~poly ~scope ~udecl uctx body opaq i { Recthm.name; typ; impargs } = - let norm c = EConstr.to_constr (Evd.from_ctx uctx) c in - let body = Option.map EConstr.of_constr body in - let univs = UState.check_univ_decl ~poly uctx udecl in - let t_i = norm typ in - let kind = Decls.(IsAssumption Conjectural) in - match body with - | None -> - let open DeclareDef in - (match scope with - | Discharge -> - (* Let Fixpoint + Admitted gets turned into axiom so scope is Global, - see finish_admitted *) - assert false - | Global local -> - 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 - | Fix ((nv,0),decls) -> mkFix ((nv,i),decls) - | CoFix (0,decls) -> mkCoFix (i,decls) - | LetIn(na,t1,ty,t2) -> mkLetIn (na,t1,ty, body_i t2) - | Lambda(na,ty,t) -> mkLambda(na,ty,body_i t) - | App (t, args) -> mkApp (body_i t, args) - | _ -> - anomaly Pp.(str "Not a proof by induction: " ++ Printer.pr_constr_env env sigma body ++ str ".") in - let body_i = body_i body in - let open DeclareDef in - match scope with - | Discharge -> - 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.declare_constant ~name ~local ~kind (Declare.DefinitionEntry const) in - GlobRef.ConstRef kn, impargs - -(* 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 = - let other_thms_data = - if List.is_empty other_thms then [] else - (* there are several theorems defined mutually *) - let body,opaq = retrieve_first_recthm uctx dref in - List.map_i (save_remaining_recthms env sigma ~poly ~scope ~udecl uctx body opaq) 1 other_thms in - let thms_data = (dref,imps)::other_thms_data in - List.iter (fun (dref,imps) -> - maybe_declare_manual_implicits false dref imps; - DeclareDef.Hook.(call ?fix_exn ?hook { S.uctx; obls = []; scope; dref})) thms_data +(* Support for mutually proved theorems *) + +(* XXX: Most of this does belong to Declare, due to proof_entry manip *) +module MutualEntry : sig + + (* We keep this type abstract and to avoid uncontrolled hacks *) + type t + + val variable : info:Info.t -> Entries.parameter_entry -> t + + val adjust_guardness_conditions + : info:Info.t + -> Evd.side_effects Declare.proof_entry + -> t + + val declare_mutdef + (* Common to all recthms *) + : ?fix_exn:(Exninfo.iexn -> Exninfo.iexn) + -> poly:bool + -> uctx:UState.t + -> ?hook_data:DeclareDef.Hook.t * UState.t * (Names.Id.t * Constr.t) list + -> udecl:UState.universe_decl + (* Only for the first constant, introduced by compat *) + -> ubind:UnivNames.universe_binders + -> name:Id.t + -> t + -> Names.GlobRef.t list + +end = struct + + (* Body with the fix *) + type et = + | NoBody of Entries.parameter_entry + | Single of Evd.side_effects Declare.proof_entry + | Mutual of Evd.side_effects Declare.proof_entry + + type t = + { entry : et + ; info : Info.t + } + + let variable ~info t = { entry = NoBody t; info } + + (* XXX: Refactor this with the code in + [ComFixpoint.declare_fixpoint_generic] *) + let guess_decreasing env possible_indexes ((body, ctx), eff) = + let open Constr in + match Constr.kind body with + | Fix ((nv,0),(_,_,fixdefs as fixdecls)) -> + let env = Safe_typing.push_private_constants env eff.Evd.seff_private in + let indexes = Pretyping.search_guard env possible_indexes fixdecls in + (mkFix ((indexes,0),fixdecls), ctx), eff + | _ -> (body, ctx), eff + + let adjust_guardness_conditions ~info const = + let entry = match info.Info.compute_guard with + | [] -> + (* Not a recursive statement *) + Single const + | possible_indexes -> + (* Try all combinations... not optimal *) + let env = Global.env() in + let pe = Declare.Internal.map_entry_body const + ~f:(guess_decreasing env possible_indexes) + in + Mutual pe + in { entry; info } + + let rec select_body i t = + let open Constr in + match Constr.kind t with + | Fix ((nv,0),decls) -> mkFix ((nv,i),decls) + | CoFix (0,decls) -> mkCoFix (i,decls) + | LetIn(na,t1,ty,t2) -> mkLetIn (na,t1,ty, select_body i t2) + | Lambda(na,ty,t) -> mkLambda(na,ty, select_body i t) + | App (t, args) -> mkApp (select_body i t, args) + | _ -> + CErrors.anomaly + Pp.(str "Not a proof by induction: " ++ + Termops.Internal.debug_print_constr (EConstr.of_constr t) ++ str ".") + + let declare_mutdef ?fix_exn ~poly ~uctx ?hook_data ~udecl ~ubind ~name ?typ ~impargs ~info mutpe i = + let { Info.hook; compute_guard; scope; kind; _ } = info in + match mutpe with + | NoBody pe -> + DeclareDef.declare_assumption ?fix_exn ~name ~scope ~hook ~impargs ~uctx pe + | Single pe -> + (* We'd like to do [assert (i = 0)] here, however this codepath + is used when declaring mutual cofixpoints *) + DeclareDef.declare_definition ~name ~scope ~kind ?hook_data ubind pe impargs + | Mutual pe -> + (* if typ = None , we don't touch the type; used in the base case *) + let pe = + match typ with + | None -> pe + | Some typ -> + Declare.Internal.map_entry_type pe ~f:(fun _ -> Some typ) + in + let pe = Declare.Internal.map_entry_body pe + ~f:(fun ((body, ctx), eff) -> (select_body i body, ctx), eff) in + DeclareDef.declare_definition ~name ~scope ~kind ?hook_data ubind pe impargs + + let declare_mutdef ?fix_exn ~poly ~uctx ?hook_data ~udecl ~ubind ~name { entry; info } = + (* At some point make this a single iteration *) + (* impargs here are special too, fixed in upcoming PRs *) + let impargs = info.Info.impargs in + let r = declare_mutdef ?fix_exn ~poly ~info ~udecl ~ubind ?hook_data ~uctx ~name ~impargs entry 0 in + (* Before we used to do this, check if that's right *) + let ubind = UnivNames.empty_binders in + let rs = + List.map_i ( + fun i { Recthm.name; typ; impargs } -> + declare_mutdef ?fix_exn ~poly ~udecl ~info ~ubind ?hook_data ~uctx ~name ~typ ~impargs entry i) 1 info.Info.other_thms + in r :: rs +end (************************************************************************) (* 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 ~key:["Keep"; "Admitted"; "Variables"] ~value:true -let finish_admitted env sigma ~name ~poly ~scope pe ctx hook ~udecl impargs other_thms = - let open DeclareDef in - let local = match scope with - | Global local -> local - | Discharge -> warn_let_as_axiom name; Declare.ImportNeedQualified - in - let kn = Declare.declare_constant ~name ~local ~kind:Decls.(IsAssumption Conjectural) (Declare.ParameterEntry pe) in - let () = Declare.assumption_message name in - DeclareUniv.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) (GlobRef.ConstRef kn) impargs other_thms +let compute_proof_using_for_admitted proof typ pproofs = + if not (get_keep_admitted_vars ()) then None + else match Proof_global.get_used_variables proof, pproofs with + | Some _ as x, _ -> x + | None, pproof :: _ -> + let env = Global.env () in + let ids_typ = Environ.global_vars_set env typ in + (* [pproof] is evar-normalized by [partial_proof]. We don't + count variables appearing only in the type of evars. *) + let ids_def = Environ.global_vars_set env (EConstr.Unsafe.to_constr pproof) in + Some (Environ.really_needed env (Id.Set.union ids_typ ids_def)) + | _ -> None + +let finish_admitted ~name ~poly ~info ~uctx ~udecl pe = + let mutpe = MutualEntry.variable ~info pe in + let ubind = UnivNames.empty_binders in + let _r : Names.GlobRef.t list = + MutualEntry.declare_mutdef ~uctx ~poly ~udecl ~ubind ~name mutpe in + () let save_lemma_admitted ~(lemma : t) : unit = - (* Used for printing in recthms *) - let env = Global.env () in - let { Info.hook; scope; impargs; other_thms } = lemma.info in let udecl = Proof_global.get_universe_decl lemma.proof in - let Proof.{ sigma; name; poly; entry } = Proof.data (Proof_global.get_proof lemma.proof) in + let Proof.{ name; poly; entry } = Proof.data (Proof_global.get_proof lemma.proof) in let typ = match Proofview.initial_goals entry with | [typ] -> snd typ - | _ -> CErrors.anomaly ~label:"Lemmas.save_proof" (Pp.str "more than one statement.") + | _ -> CErrors.anomaly ~label:"Lemmas.save_lemma_admitted" (Pp.str "more than one statement.") in let typ = EConstr.Unsafe.to_constr typ in let proof = Proof_global.get_proof lemma.proof in let pproofs = Proof.partial_proof proof in - let sec_vars = - if not (get_keep_admitted_vars ()) then None - else match Proof_global.get_used_variables lemma.proof, pproofs with - | Some _ as x, _ -> x - | None, pproof :: _ -> - let env = Global.env () in - let ids_typ = Environ.global_vars_set env typ in - (* [pproof] is evar-normalized by [partial_proof]. We don't - count variables appearing only in the type of evars. *) - let ids_def = Environ.global_vars_set env (EConstr.Unsafe.to_constr pproof) in - Some (Environ.really_needed env (Id.Set.union ids_typ ids_def)) - | _ -> None in + let sec_vars = compute_proof_using_for_admitted lemma.proof typ pproofs in let universes = Proof_global.get_initial_euctx lemma.proof in let ctx = UState.check_univ_decl ~poly universes udecl in - finish_admitted env sigma ~name ~poly ~scope (sec_vars, (typ, ctx), None) universes hook ~udecl impargs other_thms + finish_admitted ~name ~poly ~info:lemma.info ~uctx:universes ~udecl (sec_vars, (typ, ctx), None) (************************************************************************) (* Saving a lemma-like constant *) @@ -319,29 +347,12 @@ let save_lemma_admitted ~(lemma : t) : unit = let default_thm_id = Id.of_string "Unnamed_thm" 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.") - -(* Support for mutually proved theorems *) + if not (String.equal (Nameops.atompart_of_id id) (Id.to_string (default_thm_id))) then + CErrors.user_err Pp.(str "This command can only be used for unnamed theorem.") -(* Helper for finish_proved *) -let adjust_guardness_conditions const = function - | [] -> const (* Not a recursive statement *) - | possible_indexes -> - (* Try all combinations... not optimal *) - let env = Global.env() in - Declare.Internal.map_entry_body const - ~f:(fun ((body, ctx), eff) -> - match Constr.kind body with - | Fix ((nv,0),(_,_,fixdefs as fixdecls)) -> - let env = Safe_typing.push_private_constants env eff.Evd.seff_private in - let indexes = search_guard env possible_indexes fixdecls in - (mkFix ((indexes,0),fixdecls), ctx), eff - | _ -> (body, ctx), eff) - -let finish_proved env sigma idopt po info = +let finish_proved idopt po info = let open Proof_global in - let { Info.hook; compute_guard; impargs; other_thms; scope; kind } = info in + let { Info.hook } = info in match po with | { name; entries=[const]; universes; udecl; poly } -> let name = match idopt with @@ -349,37 +360,18 @@ let finish_proved env sigma idopt po info = | Some { CAst.v = save_id } -> check_anonymity name save_id; save_id in let fix_exn = Declare.Internal.get_fix_exn const in let () = try - let const = adjust_guardness_conditions const compute_guard in - let should_suggest = const.Declare.proof_entry_opaque && - Option.is_empty const.Declare.proof_entry_secctx in - let open DeclareDef in - let r = match scope with - | Discharge -> - 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 - GlobRef.VarRef name - | Global local -> - let kn = - 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 = GlobRef.ConstRef kn in - DeclareUniv.declare_univ_binders gr (UState.universe_binders universes); - gr - in - 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 + let mutpe = MutualEntry.adjust_guardness_conditions ~info const in + let hook_data = Option.map (fun hook -> hook, universes, []) hook in + let ubind = UState.universe_binders universes in + let _r : Names.GlobRef.t list = + MutualEntry.declare_mutdef ~fix_exn ~uctx:universes ~poly ~udecl ?hook_data ~ubind ~name mutpe + in () with e when CErrors.noncritical e -> - let e = CErrors.push e in - iraise (fix_exn e) + let e = Exninfo.capture e in + Exninfo.iraise (fix_exn e) in () | _ -> - CErrors.anomaly Pp.(str "[standard_proof_terminator] close_proof returned more than one proof term") + CErrors.anomaly ~label:"finish_proved" Pp.(str "close_proof returned more than one proof term") let finish_derived ~f ~name ~idopt ~entries = (* [f] and [name] correspond to the proof of [f] and of [suchthat], respectively. *) @@ -399,7 +391,7 @@ let finish_derived ~f ~name ~idopt ~entries = 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 + let f_kn_term = Constr.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 references to the constant [f] declared above. This substitution @@ -427,7 +419,7 @@ let finish_proved_equations lid kind proof_obj hook i types wits sigma0 = let id = match Evd.evar_ident ev sigma0 with | Some id -> id - | None -> let n = !obls in incr obls; add_suffix i ("_obligation_" ^ string_of_int n) + | None -> let n = !obls in incr obls; Nameops.add_suffix i ("_obligation_" ^ string_of_int n) in let entry, args = Declare.Internal.shrink_entry local_context entry in let cst = Declare.declare_constant ~name:id ~kind (Declare.DefinitionEntry entry) in @@ -438,12 +430,12 @@ let finish_proved_equations lid kind proof_obj hook i types wits sigma0 = in hook recobls sigma -let finalize_proof idopt env sigma proof_obj proof_info = +let finalize_proof idopt proof_obj proof_info = let open Proof_global in let open Proof_ending in match CEphemeron.default proof_info.Info.proof_ending Regular with | Regular -> - finish_proved env sigma idopt proof_obj proof_info + finish_proved idopt proof_obj proof_info | End_obligation oinfo -> DeclareObl.obligation_terminator proof_obj.entries proof_obj.universes oinfo | End_derive { f ; name } -> @@ -453,35 +445,26 @@ let finalize_proof idopt env sigma proof_obj proof_info = let save_lemma_proved ~lemma ~opaque ~idopt = (* Env and sigma are just used for error printing in save_remaining_recthms *) - let env = Global.env () in - let { Proof.sigma } = Proof.data (Proof_global.get_proof lemma.proof) in let proof_obj = Proof_global.close_proof ~opaque ~keep_body_ucst_separate:false (fun x -> x) lemma.proof in - finalize_proof idopt env sigma proof_obj lemma.info + finalize_proof idopt proof_obj lemma.info (***********************************************************************) (* Special case to close a lemma without forcing a proof *) (***********************************************************************) let save_lemma_admitted_delayed ~proof ~info = let open Proof_global in - let env = Global.env () in - let sigma = Evd.from_env env in let { name; entries; universes; udecl; poly } = proof in - let { Info.hook; scope; impargs; other_thms } = info in if List.length entries <> 1 then - user_err Pp.(str "Admitted does not support multiple statements"); + CErrors.user_err Pp.(str "Admitted does not support multiple statements"); let { Declare.proof_entry_secctx; proof_entry_type; proof_entry_universes } = List.hd entries in let poly = match proof_entry_universes with | Entries.Monomorphic_entry _ -> false | Entries.Polymorphic_entry (_, _) -> true in let typ = match proof_entry_type with - | None -> user_err Pp.(str "Admitted requires an explicit statement"); + | None -> CErrors.user_err Pp.(str "Admitted requires an explicit statement"); | Some typ -> typ in let ctx = UState.univ_entry ~poly universes in let sec_vars = if get_keep_admitted_vars () then proof_entry_secctx else None in - finish_admitted env sigma ~name ~poly ~scope (sec_vars, (typ, ctx), None) universes hook ~udecl impargs other_thms + finish_admitted ~name ~poly ~uctx:universes ~udecl ~info (sec_vars, (typ, ctx), None) -let save_lemma_proved_delayed ~proof ~info ~idopt = - (* Env and sigma are just used for error printing in save_remaining_recthms *) - let env = Global.env () in - let sigma = Evd.from_env env in - finalize_proof idopt env sigma proof info +let save_lemma_proved_delayed ~proof ~info ~idopt = finalize_proof idopt proof info diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli index e790c39022..d645de1ceb 100644 --- a/vernac/lemmas.mli +++ b/vernac/lemmas.mli @@ -48,7 +48,7 @@ module Recthm : sig type t = { name : Id.t (** Name of theorem *) - ; typ : EConstr.t + ; typ : Constr.t (** Type of theorem *) ; args : Name.t list (** Names to pre-introduce *) diff --git a/vernac/library.ml b/vernac/library.ml index 0f7e7d2aa0..5aff86c50c 100644 --- a/vernac/library.ml +++ b/vernac/library.ml @@ -440,11 +440,11 @@ let save_library_base f sum lib univs tasks proofs = System.marshal_out_segment f ch (proofs : seg_proofs); close_out ch with reraise -> - let reraise = CErrors.push reraise in + let reraise = Exninfo.capture reraise in close_out ch; Feedback.msg_warning (str "Removed file " ++ str f); Sys.remove f; - iraise reraise + Exninfo.iraise reraise type ('document,'counters) todo_proofs = | ProofsTodoNone (* for .vo *) diff --git a/vernac/loadpath.ml b/vernac/loadpath.ml index 506b3bc505..38aa42c349 100644 --- a/vernac/loadpath.ml +++ b/vernac/loadpath.ml @@ -218,24 +218,18 @@ let try_locate_absolute_library dir = (** { 5 Extending the load path } *) -(* Adds a path to the Coq and ML paths *) -type add_ml = AddNoML | AddTopML | AddRecML - -type vo_path_spec = { - unix_path : string; (* Filesystem path containing vo/ml files *) - coq_path : DP.t; (* Coq prefix for the path *) - implicit : bool; (* [implicit = true] avoids having to qualify with [coq_path] *) - has_ml : add_ml; (* If [has_ml] is true, the directory will also be search for plugins *) -} - -type coq_path_spec = - | VoPath of vo_path_spec - | MlPath of string - -type coq_path = { - path_spec: coq_path_spec; - recursive: bool; -} +type vo_path = + { unix_path : string + (** Filesystem path containing vo/ml files *) + ; coq_path : DP.t + (** Coq prefix for the path *) + ; implicit : bool + (** [implicit = true] avoids having to qualify with [coq_path] *) + ; has_ml : bool + (** If [has_ml] is true, the directory will also be added to the ml include path *) + ; recursive : bool + (** [recursive] will determine whether we explore sub-directories *) + } let warn_cannot_open_path = CWarnings.create ~name:"cannot-open-path" ~category:"filesystem" @@ -255,9 +249,10 @@ let convert_string d = warn_cannot_use_directory d; raise Exit -let add_vo_path ~recursive lp = +let add_vo_path lp = let unix_path = lp.unix_path in let implicit = lp.implicit in + let recursive = lp.recursive in if System.exists_dir unix_path then let dirs = if recursive then System.all_subdirs ~unix_path else [] in let prefix = DP.repr lp.coq_path in @@ -268,22 +263,17 @@ let add_vo_path ~recursive lp = with Exit -> None in let dirs = List.map_filter convert_dirs dirs in - let add_ml_dir = Mltop.add_ml_dir ~recursive:false in - let () = match lp.has_ml with - | AddNoML -> () - | AddTopML -> - Mltop.add_ml_dir ~recursive:false unix_path - | AddRecML -> - List.iter (fun (lp,_) -> add_ml_dir lp) dirs; - add_ml_dir unix_path in + let () = + if lp.has_ml && not lp.recursive then + Mltop.add_ml_dir unix_path + else if lp.has_ml && lp.recursive then + (List.iter (fun (lp,_) -> Mltop.add_ml_dir lp) dirs; + Mltop.add_ml_dir unix_path) + else + () + in let add (path, dir) = add_load_path path ~implicit dir in let () = List.iter add dirs in add_load_path unix_path ~implicit lp.coq_path else warn_cannot_open_path unix_path - -let add_coq_path { recursive; path_spec } = match path_spec with - | VoPath lp -> - add_vo_path ~recursive lp - | MlPath dir -> - Mltop.add_ml_dir ~recursive dir diff --git a/vernac/loadpath.mli b/vernac/loadpath.mli index 47d2d34125..68212b9a47 100644 --- a/vernac/loadpath.mli +++ b/vernac/loadpath.mli @@ -64,26 +64,17 @@ val try_locate_absolute_library : DirPath.t -> string (** {6 Extending the Load Path } *) (** Adds a path to the Coq and ML paths *) -type add_ml = AddNoML | AddTopML | AddRecML - -type vo_path_spec = { - unix_path : string; +type vo_path = + { unix_path : string (** Filesystem path containing vo/ml files *) - coq_path : Names.DirPath.t; + ; coq_path : DirPath.t (** Coq prefix for the path *) - implicit : bool; + ; implicit : bool (** [implicit = true] avoids having to qualify with [coq_path] *) - has_ml : add_ml; - (** If [has_ml] is true, the directory will also be search for plugins *) -} - -type coq_path_spec = - | VoPath of vo_path_spec - | MlPath of string - -type coq_path = { - path_spec: coq_path_spec; - recursive: bool; -} + ; has_ml : bool + (** If [has_ml] is true, the directory will also be added to the ml include path *) + ; recursive : bool + (** [recursive] will determine whether we explore sub-directories *) + } -val add_coq_path : coq_path -> unit +val add_vo_path : vo_path -> unit diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 3937f887ad..10946d78f0 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -1466,9 +1466,9 @@ let with_lib_stk_protection f x = let fs = Lib.freeze () in try let a = f x in Lib.unfreeze fs; a with reraise -> - let reraise = CErrors.push reraise in + let reraise = Exninfo.capture reraise in let () = Lib.unfreeze fs in - iraise reraise + Exninfo.iraise reraise let with_syntax_protection f x = with_lib_stk_protection @@ -1654,13 +1654,23 @@ let add_syntax_extension ~local ({CAst.loc;v=df},mods) = let open SynData in (* Notations with only interpretation *) -let add_notation_interpretation env ({CAst.loc;v=df},c,sc) = - let df' = add_notation_interpretation_core ~local:false df env c sc false false None in +let add_notation_interpretation env decl_ntn = + let + { decl_ntn_string = { CAst.loc ; v = df }; + decl_ntn_interp = c; + decl_ntn_only_parsing = onlyparse; + decl_ntn_scope = sc } = decl_ntn in + let df' = add_notation_interpretation_core ~local:false df env c sc onlyparse false None in Dumpglob.dump_notation (loc,df') sc true -let set_notation_for_interpretation env impls ({CAst.v=df},c,sc) = +let set_notation_for_interpretation env impls decl_ntn = + let + { decl_ntn_string = { CAst.v = df }; + decl_ntn_interp = c; + decl_ntn_only_parsing = onlyparse; + decl_ntn_scope = sc } = decl_ntn in (try ignore - (Flags.silently (fun () -> add_notation_interpretation_core ~local:false df env ~impls c sc false false None) ()); + (Flags.silently (fun () -> add_notation_interpretation_core ~local:false df env ~impls c sc onlyparse false None) ()); with NoSyntaxRule -> user_err Pp.(str "Parsing rule for this notation has to be previously declared.")); Option.iter (fun sc -> Notation.open_close_scope (false,true,sc)) sc @@ -1698,7 +1708,7 @@ let add_infix ~local deprecation env ({CAst.loc;v=inf},modifiers) pr sc = (* check the precedence *) let vars = names_of_constr_expr pr in let x = Namegen.next_ident_away (Id.of_string "x") vars in - let y = Namegen.next_ident_away (Id.of_string "y") vars in + let y = Namegen.next_ident_away (Id.of_string "y") (Id.Set.add x vars) in let metas = [inject_var x; inject_var y] in let c = mkAppC (pr,metas) in let df = CAst.make ?loc @@ Id.to_string x ^" "^(quote_notation_token inf)^" "^Id.to_string y in diff --git a/vernac/metasyntax.mli b/vernac/metasyntax.mli index e3e733a4b7..d76820b033 100644 --- a/vernac/metasyntax.mli +++ b/vernac/metasyntax.mli @@ -37,12 +37,12 @@ val add_class_scope : locality_flag -> scope_name -> scope_class list -> unit (** Add only the interpretation of a notation that already has pa/pp rules *) val add_notation_interpretation : - env -> (lstring * constr_expr * scope_name option) -> unit + env -> decl_notation -> unit (** Add a notation interpretation for supporting the "where" clause *) -val set_notation_for_interpretation : env -> Constrintern.internalization_env -> - (lstring * constr_expr * scope_name option) -> unit +val set_notation_for_interpretation : + env -> Constrintern.internalization_env -> decl_notation -> unit (** Add only the parsing/printing rule of a notation *) diff --git a/vernac/mltop.ml b/vernac/mltop.ml index 5046248e11..671dae7876 100644 --- a/vernac/mltop.ml +++ b/vernac/mltop.ml @@ -128,11 +128,6 @@ let add_ml_dir s = | WithoutTop when has_dynlink -> keep_copy_mlpath s | _ -> () -(* For Rec Add ML Path (-R) *) -let add_ml_dir ~recursive unix_path = - let dirs = if recursive then (all_subdirs ~unix_path) else [unix_path,[]] in - List.iter (fun (lp,_) -> add_ml_dir lp) dirs - (* convertit un nom quelconque en nom de fichier ou de module *) let mod_of_name name = if Filename.check_suffix name ".cmo" then diff --git a/vernac/mltop.mli b/vernac/mltop.mli index 271772d7ba..633a5c241d 100644 --- a/vernac/mltop.mli +++ b/vernac/mltop.mli @@ -32,7 +32,7 @@ val ocaml_toploop : unit -> unit (** {5 ML Dynlink} *) (** Adds a dir to the plugin search path *) -val add_ml_dir : recursive:bool -> string -> unit +val add_ml_dir : string -> unit (** Tests if we can load ML files *) val has_dynlink : bool diff --git a/vernac/obligations.ml b/vernac/obligations.ml index 76dbf1ad5a..27eb821a6a 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -428,7 +428,7 @@ let solve_by_tac ?loc name evi t poly ctx = Some (body, entry.Declare.proof_entry_type, ctx') with | Refiner.FailError (_, s) as exn -> - let _ = CErrors.push exn in + let _ = Exninfo.capture exn in user_err ?loc ~hdr:"solve_obligation" (Lazy.force s) (* If the proof is open we absorb the error and leave the obligation open *) | Proof.OpenProof _ -> diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index 314c423f65..84ae04e4cc 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -297,11 +297,6 @@ open Pputils | { v = CHole (k, Namegen.IntroAnonymous, _) } -> mt() | _ as c -> brk(0,2) ++ str" :" ++ pr_c c - let pr_decl_notation prc ({loc; v=ntn},c,scopt) = - fnl () ++ keyword "where " ++ qs ntn ++ str " := " - ++ Flags.without_option Flags.beautify prc c ++ - pr_opt (fun sc -> str ": " ++ str sc) scopt - let pr_binders_arg = let env = Global.env () in let sigma = Evd.from_env env in @@ -418,6 +413,21 @@ let string_of_theorem_kind = let open Decls in function | l -> spc() ++ hov 1 (str"(" ++ prlist_with_sep sep_v2 pr_syntax_modifier l ++ str")") + let pr_only_parsing_clause onlyparsing = + pr_syntax_modifiers (if onlyparsing then [SetOnlyParsing] else []) + + let pr_decl_notation prc decl_ntn = + let open Vernacexpr in + let + { decl_ntn_string = {CAst.loc;v=ntn}; + decl_ntn_interp = c; + decl_ntn_only_parsing = onlyparsing; + decl_ntn_scope = scopt } = decl_ntn in + fnl () ++ keyword "where " ++ qs ntn ++ str " := " + ++ Flags.without_option Flags.beautify prc c + ++ pr_only_parsing_clause onlyparsing + ++ pr_opt (fun sc -> str ": " ++ str sc) scopt + let pr_rec_definition { fname; univs; rec_order; binders; rtype; body_def; notations } = let env = Global.env () in let sigma = Evd.from_env env in @@ -1016,22 +1026,18 @@ let string_of_definition_object_kind = let open Decls in function return (keyword "Existential" ++ spc () ++ int i ++ pr_lconstrarg c) (* Auxiliary file and library management *) - | VernacAddLoadPath (fl,s,d) -> + | VernacAddLoadPath { implicit; physical_path; logical_path } -> return ( hov 2 (keyword "Add" ++ - (if fl then spc () ++ keyword "Rec" ++ spc () else spc()) ++ - keyword "LoadPath" ++ spc() ++ qs s ++ - (match d with - | None -> mt() - | Some dir -> spc() ++ keyword "as" ++ spc() ++ DirPath.print dir)) - ) + (if implicit then spc () ++ keyword "Rec" ++ spc () else spc()) ++ + keyword "LoadPath" ++ spc() ++ qs physical_path ++ + spc() ++ keyword "as" ++ spc() ++ DirPath.print logical_path)) | VernacRemoveLoadPath s -> return (keyword "Remove LoadPath" ++ qs s) - | VernacAddMLPath (fl,s) -> + | VernacAddMLPath (s) -> return ( keyword "Add" - ++ (if fl then spc () ++ keyword "Rec" ++ spc () else spc()) ++ keyword "ML Path" ++ qs s ) @@ -1061,7 +1067,7 @@ let string_of_definition_object_kind = let open Decls in function hov 2 (keyword "Notation" ++ spc () ++ pr_lident id ++ spc () ++ prlist_with_sep spc pr_id ids ++ str":=" ++ pr_constrarg c ++ - pr_syntax_modifiers (if onlyparsing then [SetOnlyParsing] else [])) + pr_only_parsing_clause onlyparsing) ) | VernacArguments (q, args, more_implicits, mods) -> return ( diff --git a/vernac/record.ml b/vernac/record.ml index 3e44cd85cc..065641989d 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -423,7 +423,13 @@ let declare_structure ~cumulative finite ubinders univs paramimpls params templa let args = Context.Rel.to_extended_list mkRel nfields params in let ind = applist (mkRel (ntypes - i + nparams + nfields), args) in let type_constructor = it_mkProd_or_LetIn ind fields in - let template = + { mind_entry_typename = id; + mind_entry_arity = arity; + mind_entry_consnames = [idbuild]; + mind_entry_lc = [type_constructor] } + in + let blocks = List.mapi mk_block record_data in + let check_template (id, _, min_univ, _, _, fields, _, _) = let template_candidate () = (* we use some dummy values for the arities in the rel_context as univs_of_constr doesn't care about localassums and @@ -454,14 +460,8 @@ let declare_structure ~cumulative finite ubinders univs paramimpls params templa | None, template -> (* auto detect template *) ComInductive.should_auto_template id (template && template_candidate ()) - in - { mind_entry_typename = id; - mind_entry_arity = arity; - mind_entry_template = template; - mind_entry_consnames = [idbuild]; - mind_entry_lc = [type_constructor] } in - let blocks = List.mapi mk_block record_data in + let template = List.for_all check_template record_data in let primitive = !primitive_flag && List.for_all (fun (_,_,_,_,_,fields,_,_) -> List.exists is_local_assum fields) record_data @@ -473,6 +473,7 @@ let declare_structure ~cumulative finite ubinders univs paramimpls params templa mind_entry_inds = blocks; mind_entry_private = None; mind_entry_universes = univs; + mind_entry_template = template; mind_entry_cumulative = poly && cumulative; } in diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml index de02f7ecfb..509c164af8 100644 --- a/vernac/topfmt.ml +++ b/vernac/topfmt.ml @@ -361,7 +361,7 @@ let in_phase ~phase f x = with exn -> let iexn = Exninfo.capture exn in default_phase := op; - Util.iraise iexn + Exninfo.iraise iexn let pr_loc loc = let fname = loc.Loc.fname in @@ -394,7 +394,7 @@ let pr_phase ?loc () = None let print_err_exn any = - let (e, info) = CErrors.push any in + let (e, info) = Exninfo.capture any in let loc = Loc.get_loc info in let pre_hdr = pr_phase ?loc () in let msg = CErrors.iprint (e, info) ++ fnl () in diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 2eb1aa39b0..c78b470e3b 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -15,17 +15,10 @@ open CErrors open CAst open Util open Names -open Tacmach -open Constrintern -open Prettyp open Printer open Goptions open Libnames -open Globnames open Vernacexpr -open Constrexpr -open Redexpr -open Lemmas open Locality open Attributes @@ -128,7 +121,7 @@ let show_intro ~proof all = let Proof.{goals;sigma} = Proof.data proof in if not (List.is_empty goals) then begin let gl = {Evd.it=List.hd goals ; sigma = sigma; } in - let l,_= decompose_prod_assum sigma (Termops.strip_outer_cast sigma (pf_concl gl)) in + let l,_= decompose_prod_assum sigma (Termops.strip_outer_cast sigma (Tacmach.pf_concl gl)) in if all then let lid = Tactics.find_intro_names l gl in hov 0 (prlist_with_sep spc Id.print lid) @@ -342,9 +335,9 @@ let dump_universes_gen prl g s = close (); str "Universes written to file \"" ++ str s ++ str "\"." with reraise -> - let reraise = CErrors.push reraise in + let reraise = Exninfo.capture reraise in close (); - iraise reraise + Exninfo.iraise reraise let universe_subgraph ?loc g univ = let open Univ in @@ -493,8 +486,8 @@ let start_lemma_com ~program_mode ~poly ~scope ~kind ?hook thms = let decl = fst (List.hd thms) in let evd, udecl = Constrexpr_ops.interp_univ_decl_opt env0 (snd decl) in let evd, thms = List.fold_left_map (fun evd ((id, _), (bl, t)) -> - let evd, (impls, ((env, ctx), imps)) = interp_context_evars ~program_mode env0 evd bl in - let evd, (t', imps') = interp_type_evars_impls ~program_mode ~impls env evd t in + let evd, (impls, ((env, ctx), imps)) = Constrintern.interp_context_evars ~program_mode env0 evd bl in + let evd, (t', imps') = Constrintern.interp_type_evars_impls ~program_mode ~impls env evd t in let flags = Pretyping.{ all_and_fail_flags with program_mode } in let inference_hook = if program_mode then Some program_inference_hook else None in let evd = Pretyping.solve_remaining_evars ?hook:inference_hook flags env evd in @@ -510,7 +503,7 @@ let start_lemma_com ~program_mode ~poly ~scope ~kind ?hook thms = (* XXX: This nf_evar is critical too!! We are normalizing twice if you look at the previous lines... *) let thms = List.map (fun (name, (typ, (args, impargs))) -> - { Recthm.name; typ = Evarutil.nf_evar evd typ; args; impargs} ) thms in + { Lemmas.Recthm.name; typ = EConstr.to_constr evd typ; args; impargs} ) thms in let () = let open UState in if not (udecl.univdecl_extensible_instance && udecl.univdecl_extensible_constraints) then @@ -521,7 +514,7 @@ let start_lemma_com ~program_mode ~poly ~scope ~kind ?hook thms = else (* We fix the variables to ensure they won't be lowered to Set *) Evd.fix_undefined_variables evd in - start_lemma_with_initialization ?hook ~poly ~scope ~kind evd ~udecl recguard thms snl + Lemmas.start_lemma_with_initialization ?hook ~poly ~scope ~kind evd ~udecl recguard thms snl let vernac_definition_hook ~canonical_instance ~local ~poly = let open Decls in function | Coercion -> @@ -587,15 +580,15 @@ let vernac_start_proof ~atts kind l = let vernac_end_proof ~lemma = let open Vernacexpr in function | Admitted -> - save_lemma_admitted ~lemma + Lemmas.save_lemma_admitted ~lemma | Proved (opaque,idopt) -> - save_lemma_proved ~lemma ~opaque ~idopt + Lemmas.save_lemma_proved ~lemma ~opaque ~idopt let vernac_exact_proof ~lemma c = (* spiwack: for simplicity I do not enforce that "Proof proof_term" is called only at the beginning of a proof. *) let lemma, status = Lemmas.by (Tactics.exact_proof c) lemma in - let () = save_lemma_proved ~lemma ~opaque:Proof_global.Opaque ~idopt:None in + let () = Lemmas.save_lemma_proved ~lemma ~opaque:Proof_global.Opaque ~idopt:None in if not status then Feedback.feedback Feedback.AddedAxiom let vernac_assumption ~atts discharge kind l nl = @@ -825,7 +818,7 @@ let vernac_scheme l = let vernac_combined_scheme lid l = if Dumpglob.dump () then (Dumpglob.dump_definition lid false "def"; - List.iter (fun {loc;v=id} -> dump_global (make ?loc @@ AN (qualid_of_ident ?loc id))) l); + List.iter (fun {loc;v=id} -> dump_global (make ?loc @@ Constrexpr.AN (qualid_of_ident ?loc id))) l); Indschemes.do_combined_scheme lid l let vernac_universe ~poly l = @@ -1120,20 +1113,17 @@ let vernac_set_used_variables ~pstate e : Proof_global.t = let expand filename = Envars.expand_path_macros ~warn:(fun x -> Feedback.msg_warning (str x)) filename -let vernac_add_loadpath implicit pdir ldiropt = +let vernac_add_loadpath ~implicit pdir coq_path = let open Loadpath in let pdir = expand pdir in - let alias = Option.default Libnames.default_root_prefix ldiropt in - add_coq_path { recursive = true; - path_spec = VoPath { unix_path = pdir; coq_path = alias; has_ml = AddTopML; implicit } } + add_vo_path { unix_path = pdir; coq_path; has_ml = true; implicit; recursive = true } let vernac_remove_loadpath path = Loadpath.remove_load_path (expand path) (* Coq syntax for ML or system commands *) -let vernac_add_ml_path isrec path = - let open Loadpath in - add_coq_path { recursive = isrec; path_spec = MlPath (expand path) } +let vernac_add_ml_path path = + Mltop.add_ml_dir (expand path) let vernac_declare_ml_module ~local l = let local = Option.default false local in @@ -1546,7 +1536,7 @@ let query_command_selector ?loc = function let vernac_check_may_eval ~pstate ~atts redexp glopt rc = let glopt = query_command_selector glopt in let sigma, env = get_current_context_of_args ~pstate glopt in - let sigma, c = interp_open_constr ~expected_type:Pretyping.UnknownIfTermOrType env sigma rc in + let sigma, c = Constrintern.interp_open_constr ~expected_type:Pretyping.UnknownIfTermOrType env sigma rc in let sigma = Evarconv.solve_unif_constraints_with_heuristics env sigma in Evarconv.check_problems_are_solved env sigma; let sigma = Evd.minimize_universes sigma in @@ -1565,16 +1555,16 @@ let vernac_check_may_eval ~pstate ~atts redexp glopt rc = let evars_of_term c = Evarutil.undefined_evars_of_term sigma c in let l = Evar.Set.union (evars_of_term j.Environ.uj_val) (evars_of_term j.Environ.uj_type) in let j = { j with Environ.uj_type = Reductionops.nf_betaiota env sigma j.Environ.uj_type } in - print_judgment env sigma j ++ + Prettyp.print_judgment env sigma j ++ pr_ne_evar_set (fnl () ++ str "where" ++ fnl ()) (mt ()) sigma l | Some r -> let (sigma,r_interp) = Hook.get f_interp_redexp env sigma r in let redfun env evm c = - let (redfun, _) = reduction_of_red_expr env r_interp in + let (redfun, _) = Redexpr.reduction_of_red_expr env r_interp in let (_, c) = redfun env evm c in c in - print_eval redfun env sigma rc j + Prettyp.print_eval redfun env sigma rc j in pp ++ Printer.pr_universe_ctx_set sigma uctx @@ -1582,20 +1572,20 @@ let vernac_declare_reduction ~local s r = let local = Option.default false local in let env = Global.env () in let sigma = Evd.from_env env in - declare_red_expr local s (snd (Hook.get f_interp_redexp env sigma r)) + Redexpr.declare_red_expr local s (snd (Hook.get f_interp_redexp env sigma r)) (* The same but avoiding the current goal context if any *) let vernac_global_check c = let env = Global.env() in let sigma = Evd.from_env env in - let c,uctx = interp_constr env sigma c in + let c,uctx = Constrintern.interp_constr env sigma c in let senv = Global.safe_env() in let uctx = UState.context_set uctx in let senv = Safe_typing.push_context_set ~strict:false uctx senv in let c = EConstr.to_constr sigma c in let j = Safe_typing.typing senv c in let env = Safe_typing.env_of_safe_env senv in - print_safe_judgment env sigma j ++ + Prettyp.print_safe_judgment env sigma j ++ pr_universe_ctx_set sigma uctx @@ -1621,6 +1611,7 @@ let print_about_hyp_globs ~pstate ?loc ref_or_by_not udecl glopt = (* FIXME error on non None udecl if we find the hyp. *) let glnumopt = query_command_selector ?loc glopt in let gl,id = + let open Constrexpr in match glnumopt, ref_or_by_not.v with | None,AN qid when qualid_is_ident qid -> (* goal number not given, catch any failure *) (try get_nth_goal ~pstate 1, qualid_basename qid with _ -> raise NoHyp) @@ -1630,7 +1621,7 @@ let print_about_hyp_globs ~pstate ?loc ref_or_by_not udecl glopt = Failure _ -> user_err ?loc ~hdr:"print_about_hyp_globs" (str "No such goal: " ++ int n ++ str ".")) | _ , _ -> raise NoHyp in - let hyps = pf_hyps gl in + let hyps = Tacmach.pf_hyps gl in let decl = Context.Named.lookup id hyps in let natureofid = match decl with | LocalAssum _ -> "Hypothesis" @@ -1641,16 +1632,16 @@ let print_about_hyp_globs ~pstate ?loc ref_or_by_not udecl glopt = with (* fallback to globals *) | NoHyp | Not_found -> let sigma, env = get_current_or_global_context ~pstate in - print_about env sigma ref_or_by_not udecl + Prettyp.print_about env sigma ref_or_by_not udecl let vernac_print ~pstate ~atts = let sigma, env = get_current_or_global_context ~pstate in function | PrintTypingFlags -> pr_typing_flags (Environ.typing_flags (Global.env ())) | PrintTables -> print_tables () - | PrintFullContext-> print_full_context_typ env sigma - | PrintSectionContext qid -> print_sec_context_typ env sigma qid - | PrintInspect n -> inspect env sigma n + | PrintFullContext-> Prettyp.print_full_context_typ env sigma + | PrintSectionContext qid -> Prettyp.print_sec_context_typ env sigma qid + | PrintInspect n -> Prettyp.inspect env sigma n | PrintGrammar ent -> Metasyntax.pr_grammar ent | PrintCustomGrammar ent -> Metasyntax.pr_custom_grammar ent | PrintLoadPath dir -> (* For compatibility ? *) print_loadpath dir @@ -1663,7 +1654,7 @@ let vernac_print ~pstate ~atts = | PrintDebugGC -> Mltop.print_gc () | PrintName (qid,udecl) -> dump_global qid; - print_name env sigma qid udecl + Prettyp.print_name env sigma qid udecl | PrintGraph -> Prettyp.print_graph () | PrintClasses -> Prettyp.print_classes() | PrintTypeClasses -> Prettyp.print_typeclasses() @@ -1695,11 +1686,11 @@ let vernac_print ~pstate ~atts = print_about_hyp_globs ~pstate ref_or_by_not udecl glnumopt | PrintImplicit qid -> dump_global qid; - print_impargs qid + Prettyp.print_impargs qid | PrintAssumptions (o,t,r) -> (* Prints all the axioms and section variables used by a term *) let gr = smart_global r in - let cstr = printable_constr_of_global gr in + let cstr = Globnames.printable_constr_of_global gr in let st = Conv_oracle.get_transp_state (Environ.oracle (Global.env())) in let nassums = Assumptions.assumptions st ~add_opaque:o ~add_transparent:t gr cstr in @@ -1722,7 +1713,7 @@ open Search let interp_search_about_item env sigma = function | SearchSubPattern pat -> - let _,pat = intern_constr_pattern env sigma pat in + let _,pat = Constrintern.intern_constr_pattern env sigma pat in GlobSearchSubPattern pat | SearchString (s,None) when Id.is_valid s -> GlobSearchString s @@ -1771,7 +1762,7 @@ let vernac_search ~pstate ~atts s gopt r = (* if goal selector is given and wrong, then let exceptions be raised. *) | Some g -> snd (get_goal_or_global_context ~pstate g) , Some g in - let get_pattern c = snd (intern_constr_pattern env Evd.(from_env env) c) in + let get_pattern c = snd (Constrintern.intern_constr_pattern env Evd.(from_env env) c) in let pr_search ref env c = let pr = pr_global ref in let pp = if !search_output_name_only @@ -1797,17 +1788,17 @@ let vernac_search ~pstate ~atts s gopt r = (Search.search_about ?pstate gopt (List.map (on_snd (interp_search_about_item env Evd.(from_env env))) sl) r |> Search.prioritize_search) pr_search -let vernac_locate ~pstate = function - | LocateAny {v=AN qid} -> print_located_qualid qid - | LocateTerm {v=AN qid} -> print_located_term qid +let vernac_locate ~pstate = let open Constrexpr in function + | LocateAny {v=AN qid} -> Prettyp.print_located_qualid qid + | LocateTerm {v=AN qid} -> Prettyp.print_located_term qid | LocateAny {v=ByNotation (ntn, sc)} (* TODO : handle Ltac notations *) | LocateTerm {v=ByNotation (ntn, sc)} -> let _, env = get_current_or_global_context ~pstate in Notation.locate_notation (Constrextern.without_symbols (pr_lglob_constr_env env)) ntn sc | LocateLibrary qid -> print_located_library qid - | LocateModule qid -> print_located_module qid - | LocateOther (s, qid) -> print_located_other s qid + | LocateModule qid -> Prettyp.print_located_module qid + | LocateOther (s, qid) -> Prettyp.print_located_other s qid | LocateFile f -> locate_file f let vernac_register qid r = @@ -2106,18 +2097,18 @@ let translate_vernac ~atts v = let open Vernacextend in match v with unsupported_attributes atts; vernac_solve_existential ~pstate n c) (* Auxiliary file and library management *) - | VernacAddLoadPath (isrec,s,alias) -> + | VernacAddLoadPath { implicit; physical_path; logical_path } -> VtDefault(fun () -> unsupported_attributes atts; - vernac_add_loadpath isrec s alias) + vernac_add_loadpath ~implicit physical_path logical_path) | VernacRemoveLoadPath s -> VtDefault(fun () -> unsupported_attributes atts; vernac_remove_loadpath s) - | VernacAddMLPath (isrec,s) -> + | VernacAddMLPath (s) -> VtDefault(fun () -> unsupported_attributes atts; - vernac_add_ml_path isrec s) + vernac_add_ml_path s) | VernacDeclareMLModule l -> VtDefault(fun () -> with_locality ~atts vernac_declare_ml_module l) | VernacChdir s -> diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index 45018a246c..7169ea834a 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -98,7 +98,6 @@ type search_restriction = | SearchInside of qualid list | SearchOutside of qualid list -type rec_flag = bool (* true = Rec; false = NoRec *) type verbose_flag = bool (* true = Verbose; false = Silent *) type coercion_flag = bool (* true = AddCoercion false = NoCoercion *) type instance_flag = bool option @@ -129,7 +128,12 @@ type definition_expr = | DefineBody of local_binder_expr list * Genredexpr.raw_red_expr option * constr_expr * constr_expr option -type decl_notation = lstring * constr_expr * scope_name option +type decl_notation = + { decl_ntn_string : lstring + ; decl_ntn_interp : constr_expr + ; decl_ntn_only_parsing : bool + ; decl_ntn_scope : scope_name option + } type 'a fix_expr_gen = { fname : lident @@ -363,9 +367,13 @@ type nonrec vernac_expr = | VernacSolveExistential of int * constr_expr (* Auxiliary file and library management *) - | VernacAddLoadPath of rec_flag * string * DirPath.t option + | VernacAddLoadPath of { implicit : bool + ; physical_path : CUnix.physical_path + ; logical_path : DirPath.t + } + | VernacRemoveLoadPath of string - | VernacAddMLPath of rec_flag * string + | VernacAddMLPath of string | VernacDeclareMLModule of string list | VernacChdir of string option diff --git a/vernac/vernacextend.ml b/vernac/vernacextend.ml index f41df06f85..5d38ea32be 100644 --- a/vernac/vernacextend.ml +++ b/vernac/vernacextend.ml @@ -92,28 +92,18 @@ let warn_deprecated_command = (* Interpretation of a vernac command *) let type_vernac opn converted_args ~atts = - let phase = ref "Looking up command" in - try - let depr, callback = vinterp_map opn in - let () = if depr then + let depr, callback = vinterp_map opn in + let () = if depr then let rules = Egramml.get_extend_vernac_rule opn in let pr_gram = function - | Egramml.GramTerminal s -> str s - | Egramml.GramNonTerminal _ -> str "_" + | Egramml.GramTerminal s -> str s + | Egramml.GramNonTerminal _ -> str "_" in let pr = pr_sequence pr_gram rules in warn_deprecated_command pr; - in - phase := "Checking arguments"; - let hunk = callback converted_args in - phase := "Executing command"; - hunk ~atts - with - | reraise -> - let reraise = CErrors.push reraise in - if !Flags.debug then - Feedback.msg_debug (str"Vernac Interpreter " ++ str !phase); - iraise reraise + in + let hunk = callback converted_args in + hunk ~atts (** VERNAC EXTEND registering *) diff --git a/vernac/vernacinterp.ml b/vernac/vernacinterp.ml index 1ec09b6beb..8083098022 100644 --- a/vernac/vernacinterp.ml +++ b/vernac/vernacinterp.ml @@ -96,7 +96,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 = CErrors.Timeout -> (* The error has to be printed in the failing state *) - Ok CErrors.(iprint (push e)) + Ok CErrors.(iprint (Exninfo.capture e)) (* We restore the state always *) let with_fail ~st f = @@ -262,10 +262,10 @@ let interp_gen ~verbosely ~st ~interp_fn cmd = Vernacstate.freeze_interp_state ~marshallable:false ) st with exn -> - let exn = CErrors.push exn in + let exn = Exninfo.capture exn in let exn = locate_if_not_already ?loc:cmd.CAst.loc exn in Vernacstate.invalidate_cache (); - Util.iraise exn + Exninfo.iraise exn (* Regular interp *) let interp ?(verbosely=true) ~st cmd = diff --git a/vernac/vernacstate.ml b/vernac/vernacstate.ml index 3c70961e06..280343f315 100644 --- a/vernac/vernacstate.ml +++ b/vernac/vernacstate.ml @@ -18,12 +18,9 @@ module Parser = struct let parse ps entry pa = Pcoq.unfreeze ps; - Flags.with_option Flags.we_are_parsing (fun () -> - try Pcoq.Entry.parse entry pa - with e when CErrors.noncritical e -> - let (e, info) = CErrors.push e in - Exninfo.iraise (e, info)) - () + Flags.with_option Flags.we_are_parsing + (fun () -> Pcoq.Entry.parse entry pa) + () end |