diff options
320 files changed, 4508 insertions, 3518 deletions
diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index a7c0846e35..63d6ccc240 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -1,14 +1,11 @@ -# This file describes the maintainers for the main components. See -# `dev/doc/MERGING.md`. +# This file associates maintainer teams to each component. +# See CONTRIBUTING.md ########## Contributing process ########## /.github/ @coq/contributing-process-maintainers /CONTRIBUTING.md @coq/contributing-process-maintainers -/dev/doc/shield-icon.png @coq/contributing-process-maintainers - -/dev/doc/release-process.md @coq/contributing-process-maintainers ########## Build system ########## @@ -53,6 +50,19 @@ # Trick to avoid getting review requests # each time someone modifies the changelog +/dev/doc/build-system*.txt @coq/legacy-build-maintainers +/dev/doc/build-system.dune.md @coq/build-maintainers +/dev/doc/critical-bugs @coq/kernel-maintainers +/dev/doc/econstr.md @coq/engine-maintainers +/dev/doc/proof-engine.md @coq/engine-maintainers +/dev/doc/release-process.md @coq/contributing-process-maintainers +/dev/doc/shield-icon.png @coq/contributing-process-maintainers +/dev/doc/SProp.md @coq/universes-maintainers +/dev/doc/style.txt @coq/contributing-process-maintainers +/dev/doc/unification.txt @coq/pretyper-maintainers +/dev/doc/universes.md @coq/universes-maintainers +/dev/doc/xml-protocol @coq/stm-maintainers + /man/ @coq/doc-maintainers /doc/plugin_tutorial/ @coq/plugin-tutorial-maintainers diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index c3e59a6d89..8fd5eb3972 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -632,19 +632,14 @@ library:ci-fiat-crypto: stage: stage-4 needs: - build:edge+flambda - - library:ci-bedrock2 - library:ci-coqprime - plugin:ci-bignums - plugin:ci-rewriter dependencies: - build:edge+flambda - - library:ci-bedrock2 - library:ci-coqprime - plugin:ci-rewriter -library:ci-fiat-crypto-legacy: - extends: .ci-template-flambda - library:ci-flocq: extends: .ci-template @@ -749,6 +744,9 @@ plugin:plugin-tutorial: plugin:ci-quickchick: extends: .ci-template-flambda +plugin:ci-reduction_effects: + extends: .ci-template + plugin:ci-relation_algebra: extends: .ci-template diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index a0139e422d..8cff8f66b7 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -43,6 +43,7 @@ well. - [Reviewing pull requests](#reviewing-pull-requests) - [Merging pull requests](#merging-pull-requests) - [Additional notes for pull request reviewers and assignees](#additional-notes-for-pull-request-reviewers-and-assignees) + - [Joining / leaving maintainer teams](#joining--leaving-maintainer-teams) - [Core development team](#core-development-team) - [Release management](#release-management) - [Packaging Coq](#packaging-coq) @@ -60,6 +61,7 @@ well. - [Merge script dependencies](#merge-script-dependencies) - [Coqbot](#coqbot) - [Online forum and chat to talk to developers](#online-forum-and-chat-to-talk-to-developers) + - [Coq calls](#coq-calls) - [Coq remote working groups](#coq-remote-working-groups) - [Coq Users and Developers Workshops](#coq-users-and-developers-workshops) @@ -746,12 +748,15 @@ member of a team that was requested a review should self-assign the PR, and will act as its shepherd from then on. The PR assignee is responsible for making sure that all the proposed -changes have been reviewed by relevant maintainers, that change -requests have been implemented, that CI is passing, and eventually -will be the one who merges the PR. +changes have been reviewed by relevant maintainers (at least one +reviewer for each component that is significantly affected), that +change requests have been implemented, that CI is passing, and +eventually will be the one who merges the PR. *If you have already frequently contributed to a component, we would -be happy to have you join one of the maintainer teams.* +be happy to have you join one of the maintainer teams.* See the +[section below](#joining--leaving-maintainer-teams) on joining / +leaving maintainer teams. The complete list of maintainer teams is available [here][coq-pushers] (link only accessible to people who are already members of the Coq @@ -768,9 +773,20 @@ organization, because of a limitation of GitHub). they contributed to. However, reviewers may push small fixes to the PR branch to facilitate the PR integration. +- PRs are merged when there is consensus. Consensus is defined by an + explicit approval from at least one maintainer for each component + that is significantly affected and an absence of dissent. As soon + as a developer opposes a PR, it should not be merged without being + discussed first (usually in a call or working group). + +- Sometimes (especially for large or potentially controversial PRs), + it is a good practice to announce the intent to merge, one or + several days in advance, when unsure that everyone had a chance to + voice their opinion, or to finish reviewing the PR. + - Only PRs targetting the `master` branch can be merged by a maintainer. For PRs targetting a release branch, the assignee - should always be the RM. + should always be the release manager. - Before merging, the assignee must also select a milestone for the PR (see also Section [Release management](#release-management)). @@ -782,10 +798,6 @@ organization, because of a limitation of GitHub).  -- Sometimes, it is a good practice to announce the intent to merge one - or several days in advance when unsure that everyone had a chance to - voice their opinion, or to finish reviewing the PR. - - When a PR has [overlays][user-overlays], then: - the overlays that are backward-compatible (normally the case for @@ -798,6 +810,16 @@ organization, because of a limitation of GitHub). maintainers of the affected projects to ask them to merge the overlays). +#### Joining / leaving maintainer teams #### + +We are always happy to have more people involved in the PR reviewing +and merging process, so do not hesitate to propose yourself if you +already have experience on a component. + +Maintainers can leave teams at any time (and core members can also +join any team where they feel able to help) but you should always +announce it to other maintainers when you do join or leave a team. + ### Core development team ### The core developers are the active developers with a lengthy and @@ -1110,6 +1132,14 @@ Obviously, the issue tracker is also a good place to ask questions, especially if the development processes are unclear, or the developer documentation should be improved. +### Coq calls ### + +We try to gather every week for one hour through video-conference to +discuss current and urgent matters. When longer discussions are +needed, topics are left out for the next working group. See the +[wiki][wiki-calls] for more information about Coq calls, as well as +notes of past ones. + ### Coq remote working groups ### We semi-regularly (up to every month) organize remote working groups, @@ -1219,6 +1249,7 @@ can be found [on the wiki][wiki-CUDW]. [user-changelog]: doc/changelog [user-overlays]: dev/ci/user-overlays [wiki]: https://github.com/coq/coq/wiki +[wiki-calls]: https://github.com/coq/coq/wiki/Coq-Calls [wiki-CUDW]: https://github.com/coq/coq/wiki/CoqImplementorsWorkshop [wiki-WG]: https://github.com/coq/coq/wiki/Coq-Working-Groups [YouTube]: https://www.youtube.com/channel/UCbJo6gYYr0OF18x01M4THdQ diff --git a/Makefile.build b/Makefile.build index a8ae040f8e..3c32e5bcc2 100644 --- a/Makefile.build +++ b/Makefile.build @@ -417,7 +417,7 @@ $(COQTOPBYTE): $(COQTOP_BYTE) $(LINKCMO) $(LIBCOQRUN) ########################################################################### .PHONY: tools -tools: $(TOOLS) $(OCAMLLIBDEP) $(COQDEPBOOT) +tools: $(TOOLS) $(OCAMLLIBDEP) $(COQDEPBOOT) $(DOC_GRAM) # coqdep_boot : a basic version of coqdep, with almost no dependencies. # We state these dependencies here explicitly, since some .ml.d files @@ -865,9 +865,11 @@ endif # Dependencies of .v files +PLUGININCLUDES=$(addprefix -I plugins/, $(PLUGINDIRS)) + $(VDFILE).d: $(D_DEPEND_BEFORE_SRC) $(VFILES) $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(SHOW)'COQDEP VFILES' - $(HIDE)$(COQDEPBOOT) -vos -boot $(DYNDEP) -Q user-contrib "" $(USERCONTRIBINCLUDES) $(VFILES) $(TOTARGET) + $(HIDE)$(COQDEPBOOT) -vos -boot $(DYNDEP) -R theories Coq -R plugins Coq -Q user-contrib "" $(PLUGININCLUDES) $(USERCONTRIBINCLUDES) $(VFILES) $(TOTARGET) ########################################################################### diff --git a/Makefile.ci b/Makefile.ci index 8315c16c64..c2a3cd7e14 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -25,7 +25,6 @@ CI_TARGETS= \ ci-equations \ ci-fcsl-pcm \ ci-fiat-crypto \ - ci-fiat-crypto-legacy \ ci-fiat_parsers \ ci-flocq \ ci-geocoq \ @@ -38,6 +37,7 @@ CI_TARGETS= \ ci-paramcoq \ ci-perennial \ ci-quickchick \ + ci-reduction_effects \ ci-relation_algebra \ ci-rewriter \ ci-sf \ @@ -45,6 +45,7 @@ CI_TARGETS= \ ci-stdlib2 \ ci-tlc \ ci-unimath \ + ci-unicoq \ ci-verdi-raft \ ci-vst @@ -64,7 +65,9 @@ ci-math-classes: ci-bignums ci-corn: ci-math-classes -ci-fiat-crypto: ci-bedrock2 ci-coqprime ci-rewriter +ci-mtac2: ci-unicoq + +ci-fiat-crypto: ci-coqprime ci-rewriter ci-simple-io: ci-ext-lib ci-quickchick: ci-ext-lib ci-simple-io diff --git a/Makefile.common b/Makefile.common index e392e51153..32bf19e99c 100644 --- a/Makefile.common +++ b/Makefile.common @@ -43,8 +43,9 @@ COQMAKE_BOTH_TIME_FILES:=tools/make-both-time-files.py COQMAKE_BOTH_SINGLE_TIMING_FILES:=tools/make-both-single-timing-files.py VOTOUR:=bin/votour +# these get installed! TOOLS:=$(COQDEP) $(COQMAKEFILE) $(COQTEX) $(COQWC) $(COQDOC) $(COQC)\ - $(COQWORKMGR) $(COQPP) $(DOC_GRAM) $(VOTOUR) + $(COQWORKMGR) $(COQPP) $(VOTOUR) TOOLS_HELPERS:=tools/CoqMakefile.in $(COQMAKE_ONE_TIME_FILE) $(COQTIME_FILE_MAKER)\ $(COQMAKE_BOTH_TIME_FILES) $(COQMAKE_BOTH_SINGLE_TIMING_FILES) @@ -55,7 +56,8 @@ OCAMLLIBDEPBYTE:=bin/ocamllibdep.byte$(EXE) FAKEIDE:=bin/fake_ide$(EXE) FAKEIDEBYTE:=bin/fake_ide.byte$(EXE) -PRIVATEBINARIES:=$(FAKEIDE) $(OCAMLLIBDEP) $(COQDEPBOOT) +# These don't get signed on OSX, and don't need to be separately listed for cleaning +PRIVATEBINARIES:=$(FAKEIDE) $(OCAMLLIBDEP) $(COQDEPBOOT) $(DOC_GRAM) CSDPCERT:=plugins/micromega/csdpcert$(EXE) CSDPCERTBYTE:=plugins/micromega/csdpcert.byte$(EXE) diff --git a/Makefile.make b/Makefile.make index e19053462d..e63a578e37 100644 --- a/Makefile.make +++ b/Makefile.make @@ -56,6 +56,7 @@ FIND_SKIP_DIRS:=-not -name . '(' \ -name "$${GIT_DIR}" -o \ -name '_build' -o \ -name '_build_ci' -o \ + -name '_build_boot' -o \ -name '_install_ci' -o \ -name 'gramlib' -o \ -name 'user-contrib' -o \ @@ -251,7 +252,7 @@ docclean: rm -rf doc/sphinx/_build archclean: clean-ide optclean voclean plugin-tutorialclean - rm -rf _build + rm -rf _build _build_boot rm -f $(ALLSTDLIB).* optclean: diff --git a/checker/checkInductive.ml b/checker/checkInductive.ml index e606d60d96..62e732ce69 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 (mb:mutual_inductive_body) : Entries.mutual_inductive_entry = +let to_entry mind (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 @@ -28,7 +28,27 @@ let to_entry (mb:mutual_inductive_body) : Entries.mutual_inductive_entry = | PrimRecord data -> Some (Some (Array.map (fun (x,_,_,_) -> x) data)) in let mind_entry_universes = match mb.mind_universes with - | Monomorphic univs -> Monomorphic_entry univs + | Monomorphic _ -> + (* We only need to rebuild the set of constraints for template polymorphic + 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 + | None -> ContextSet.empty + | Some ctx -> ctx + 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 -> @@ -69,8 +89,9 @@ 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} -> + | 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 && 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 @@ -136,7 +157,7 @@ let check_same_record r1 r2 = match r1, r2 with | (NotRecord | FakeRecord | PrimRecord _), _ -> false let check_inductive env mind mb = - let entry = to_entry mb in + let entry = to_entry mind 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; @@ -144,10 +165,15 @@ let check_inductive env mind mb = = (* Locally set typing flags for further typechecking *) let mb_flags = mb.mind_typing_flags in - let env = Environ.set_typing_flags {env.env_typing_flags with check_guarded = mb_flags.check_guarded; - check_positive = mb_flags.check_positive; - check_universes = mb_flags.check_universes; - conv_oracle = mb_flags.conv_oracle} env in + let env = Environ.set_typing_flags + {env.env_typing_flags with + check_guarded = mb_flags.check_guarded; + check_positive = mb_flags.check_positive; + check_universes = mb_flags.check_universes; + conv_oracle = mb_flags.conv_oracle; + } + env + in Indtypes.check_inductive env ~sec_univs:None mind entry in let check = check mind in diff --git a/checker/check_stat.ml b/checker/check_stat.ml index a67945ae94..8854a23dd5 100644 --- a/checker/check_stat.ml +++ b/checker/check_stat.ml @@ -56,7 +56,6 @@ let pr_nonpositive env = let inds = fold_inductives (fun c cb acc -> if not cb.mind_typing_flags.check_positive then MutInd.to_string c :: acc else acc) env [] in pr_assumptions "Inductives whose positivity is assumed" inds - let print_context env = if !output_context then begin Feedback.msg_notice @@ -67,7 +66,8 @@ let print_context env = str "* " ++ hov 0 (pr_axioms env ++ fnl()) ++ fnl() ++ str "* " ++ hov 0 (pr_type_in_type env ++ fnl()) ++ fnl() ++ str "* " ++ hov 0 (pr_unguarded env ++ fnl()) ++ fnl() ++ - str "* " ++ hov 0 (pr_nonpositive env))) + str "* " ++ hov 0 (pr_nonpositive env ++ fnl())) + ) end let stats env = diff --git a/checker/values.ml b/checker/values.ml index fff166f27b..ed730cff8e 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -228,7 +228,7 @@ let v_oracle = |] let v_pol_arity = - v_tuple "polymorphic_arity" [|List(Opt v_level);v_univ|] + v_tuple "polymorphic_arity" [|List(Opt v_level);v_univ;v_context_set|] let v_primitive = v_enum "primitive" 44 (* Number of "Primitive" in Int63.v and PrimFloat.v *) @@ -238,7 +238,7 @@ let v_cst_def = [|[|Opt Int|]; [|v_cstr_subst|]; [|v_opaque|]; [|v_primitive|]|] let v_typing_flags = - v_tuple "typing_flags" [|v_bool; v_bool; v_bool; v_oracle; v_bool; v_bool; v_bool; v_bool; v_bool|] + v_tuple "typing_flags" [|v_bool; v_bool; v_bool; v_oracle; v_bool; v_bool; v_bool; v_bool|] let v_univs = v_sum "universes" 0 [|[|v_context_set|]; [|v_abs_context|]|] diff --git a/clib/backtrace.ml b/clib/backtrace.ml deleted file mode 100644 index 81803a81a5..0000000000 --- a/clib/backtrace.ml +++ /dev/null @@ -1,119 +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) *) -(************************************************************************) -[@@@ocaml.warning "-37"] - -type raw_frame = -| Known_location of bool (* is_raise *) - * string (* filename *) - * int (* line number *) - * int (* start char *) - * int (* end char *) -| Unknown_location of bool (*is_raise*) - -type location = { - loc_filename : string; - loc_line : int; - loc_start : int; - loc_end : int; -} - -type frame = { frame_location : location option; frame_raised : bool; } - -external get_exception_backtrace: unit -> raw_frame array option - = "caml_get_exception_backtrace" - -type t = raw_frame array list -(** List of partial raw stack frames, in reverse order *) - -let empty = [] - -let of_raw = function -| Unknown_location r -> - { frame_location = None; frame_raised = r; } -| Known_location (r, file, line, st, en) -> - let loc = { - loc_filename = file; - loc_line = line; - loc_start = st; - loc_end = en; - } in - { frame_location = Some loc; frame_raised = r; } - -let rec repr_aux accu = function -| [] -> accu -| fragment :: stack -> - let len = Array.length fragment in - let rec append accu i = - if i = len then accu - else append (of_raw fragment.(i) :: accu) (succ i) - in - repr_aux (append accu 0) stack - -let repr bt = repr_aux [] (List.rev bt) - -let push stack = match get_exception_backtrace () with -| None -> [] -| Some frames -> frames :: stack - -(** Utilities *) - -let print_frame frame = - let raise = if frame.frame_raised then "raise" else "frame" in - match frame.frame_location with - | None -> Printf.sprintf "%s @ unknown" raise - | Some loc -> - Printf.sprintf "%s @ file \"%s\", line %d, characters %d-%d" - raise loc.loc_filename loc.loc_line loc.loc_start loc.loc_end - -(** Exception manipulation *) - -let backtrace : t Exninfo.t = Exninfo.make () - -let is_recording = ref false - -let record_backtrace b = - let () = Printexc.record_backtrace b in - is_recording := b - -let get_backtrace e = - Exninfo.get e backtrace - -let add_backtrace e = - if !is_recording then - (* This must be the first function call, otherwise the stack may be - destroyed *) - let current = get_exception_backtrace () in - let info = Exninfo.info e in - begin match current with - | None -> (e, info) - | Some fragment -> - let bt = match get_backtrace info with - | None -> [] - | Some bt -> bt - in - let bt = fragment :: bt in - (e, Exninfo.add info backtrace bt) - end - else - let info = Exninfo.info e in - (e, info) - -let app_backtrace ~src ~dst = - if !is_recording then - match get_backtrace src with - | None -> dst - | Some bt -> - match get_backtrace dst with - | None -> - Exninfo.add dst backtrace bt - | Some nbt -> - let bt = bt @ nbt in - Exninfo.add dst backtrace bt - else dst diff --git a/clib/backtrace.mli b/clib/backtrace.mli deleted file mode 100644 index 55c60e5483..0000000000 --- a/clib/backtrace.mli +++ /dev/null @@ -1,98 +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) *) -(************************************************************************) - -(** * Low-level management of OCaml backtraces. - - Currently, OCaml manages its backtraces in a very imperative way. That is to - say, it only keeps track of the stack destroyed by the last raised exception. - So we have to be very careful when using this module not to do silly things. - - Basically, you need to manually handle the reraising of exceptions. In order - to do so, each time the backtrace is lost, you must [push] the stack fragment. - This essentially occurs whenever a [with] handler is crossed. - -*) - -(** {5 Backtrace information} *) - -type location = { - loc_filename : string; - loc_line : int; - loc_start : int; - loc_end : int; -} -(** OCaml debugging information for function calls. *) - -type frame = { frame_location : location option; frame_raised : bool; } -(** A frame contains two informations: its optional physical location, and - whether it raised the exception or let it pass through. *) - -type t -(** Type of backtraces. They're essentially stack of frames. *) - -val empty : t -(** Empty frame stack. *) - -val push : t -> t -(** Add the current backtrace information to a given backtrace. *) - -val repr : t -> frame list -(** Represent a backtrace as a list of frames. Leftmost element is the outermost - call. *) - -(** {5 Utilities} *) - -val print_frame : frame -> string -(** Represent a frame. *) - -(** {5 Exception handling} *) - -val record_backtrace : bool -> unit -(** Whether to activate the backtrace recording mechanism. Note that it will - only work whenever the program was compiled with the [debug] flag. *) - -val get_backtrace : Exninfo.info -> t option -(** Retrieve the optional backtrace coming with the exception. *) - -val add_backtrace : exn -> Exninfo.iexn -(** Add the current backtrace information to the given exception. - - The intended use case is of the form: {[ - - try foo - with - | Bar -> bar - | err -> let err = add_backtrace err in baz - - ]} - - WARNING: any intermediate code between the [with] and the handler may - modify the backtrace. Yes, that includes [when] clauses. Ideally, what you - should do is something like: {[ - - try foo - with err -> - let err = add_backtrace err in - match err with - | Bar -> bar - | err -> baz - - ]} - - I admit that's a bit heavy, but there is not much to do... - -*) - -val app_backtrace : src:Exninfo.info -> dst:Exninfo.info -> Exninfo.info -(** Append the backtrace from [src] to [dst]. The returned exception is [dst] - except for its backtrace information. This is targeted at container - exceptions, that is, exceptions that contain exceptions. This way, one can - transfer the backtrace from the container to the underlying exception, as if - the latter was the one originally raised. *) diff --git a/clib/cArray.ml b/clib/cArray.ml index be59ae57d0..0f57204cc1 100644 --- a/clib/cArray.ml +++ b/clib/cArray.ml @@ -392,18 +392,30 @@ let iter2_i f v1 v2 = let () = if not (Int.equal len2 len1) then invalid_arg "Array.iter2" in for i = 0 to len1 - 1 do f i (uget v1 i) (uget v2 i) done -let pure_functional = false +let map_right f a = + let l = length a in + if l = 0 then [||] else begin + let r = Array.make l (f (unsafe_get a (l-1))) in + for i = l-2 downto 0 do + unsafe_set r i (f (unsafe_get a i)) + done; + r + end + +let map2_right f a b = + let l = length a in + if l <> length b then invalid_arg "CArray.map2_right: length mismatch"; + if l = 0 then [||] else begin + let r = Array.make l (f (unsafe_get a (l-1)) (unsafe_get b (l-1))) in + for i = l-2 downto 0 do + unsafe_set r i (f (unsafe_get a i) (unsafe_get b i)) + done; + r + end let fold_right_map f v e = -if pure_functional then - let (l,e) = - Array.fold_right - (fun x (l,e) -> let (y,e) = f x e in (y::l,e)) - v ([],e) in - (Array.of_list l,e) -else let e' = ref e in - let v' = Array.map (fun x -> let (y,e) = f x !e' in e' := e; y) v in + let v' = map_right (fun x -> let (y,e) = f x !e' in e' := e; y) v in (v',!e') let fold_left_map f e v = @@ -414,7 +426,7 @@ let fold_left_map f e v = let fold_right2_map f v1 v2 e = let e' = ref e in let v' = - map2 (fun x1 x2 -> let (y,e) = f x1 x2 !e' in e' := e; y) v1 v2 + map2_right (fun x1 x2 -> let (y,e) = f x1 x2 !e' in e' := e; y) v1 v2 in (v',!e') diff --git a/clib/cArray.mli b/clib/cArray.mli index f94af26515..94390a369f 100644 --- a/clib/cArray.mli +++ b/clib/cArray.mli @@ -107,7 +107,7 @@ sig (** Same than [fold_left2_map] but passing the index of the array *) val fold_right2_map : ('a -> 'b -> 'c -> 'd * 'c) -> 'a array -> 'b array -> 'c -> 'd array * 'c - (** Same with two arrays, folding on the left *) + (** Same with two arrays, folding on the right *) val distinct : 'a array -> bool (** Return [true] if every element of the array is unique (for default diff --git a/clib/cEphemeron.ml b/clib/cEphemeron.ml index a2a6933e36..78aa8266e4 100644 --- a/clib/cEphemeron.ml +++ b/clib/cEphemeron.ml @@ -103,8 +103,4 @@ let default (typ, boxkey) default = try (EHashtbl.find values boxkey).get typ with Not_found -> default -let iter_opt (typ, boxkey) f = - try f ((EHashtbl.find values boxkey).get typ) - with Not_found -> () - let clean () = EHashtbl.clean values diff --git a/clib/cEphemeron.mli b/clib/cEphemeron.mli index 4c10a3d66f..e567e9b2c5 100644 --- a/clib/cEphemeron.mli +++ b/clib/cEphemeron.mli @@ -43,12 +43,12 @@ type 'a key val create : 'a -> 'a key -(* May raise InvalidKey *) exception InvalidKey + val get : 'a key -> 'a +(** May raise InvalidKey *) -(* These never fail. *) val default : 'a key -> 'a -> 'a -val iter_opt : 'a key -> ('a -> unit) -> unit +(** Never fails. *) val clean : unit -> unit diff --git a/clib/exninfo.ml b/clib/exninfo.ml index 34f76a2edd..ee998c2f17 100644 --- a/clib/exninfo.ml +++ b/clib/exninfo.ml @@ -57,12 +57,29 @@ let rec find_and_remove_assoc (i : int) = function if rem == ans then (r, l) else (r, (j, v) :: ans) -let iraise e = +type backtrace = Printexc.raw_backtrace +let backtrace_to_string = Printexc.raw_backtrace_to_string + +let backtrace_info : backtrace t = make () + +let is_recording = ref false + +let record_backtrace b = + let () = Printexc.record_backtrace b in + is_recording := b + +let get_backtrace e = get e backtrace_info + +let iraise (e,i) = let () = Mutex.lock lock in let id = Thread.id (Thread.self ()) in - let () = current := (id, e) :: remove_assoc id !current in + let () = current := (id, (e,i)) :: remove_assoc id !current in let () = Mutex.unlock lock in - raise (fst e) + match get i backtrace_info with + | None -> + raise e + | Some bt -> + Printexc.raise_with_backtrace e bt let raise ?info e = match info with | None -> @@ -72,11 +89,7 @@ let raise ?info e = match info with let () = Mutex.unlock lock in raise e | Some i -> - let () = Mutex.lock lock in - let id = Thread.id (Thread.self ()) in - let () = current := (id, (e, i)) :: remove_assoc id !current in - let () = Mutex.unlock lock in - raise e + iraise (e,i) let find_and_remove () = let () = Mutex.lock lock in @@ -104,3 +117,13 @@ let info e = (* Mismatch: the raised exception is not the one stored, either because the previous raise was not instrumented, or because something went wrong. *) Store.empty + +let capture e = + if !is_recording then + (* This must be the first function call, otherwise the stack may be + destroyed *) + let bt = Printexc.get_raw_backtrace () in + let info = info e in + e, add info backtrace_info bt + else + e, info e diff --git a/clib/exninfo.mli b/clib/exninfo.mli index 30803e3e6a..36cc44cf82 100644 --- a/clib/exninfo.mli +++ b/clib/exninfo.mli @@ -34,6 +34,49 @@ val get : info -> 'a t -> 'a option val info : exn -> info (** Retrieve the information of the last exception raised. *) +type backtrace + +val get_backtrace : info -> backtrace option +(** [get_backtrace info] does get the backtrace associated to info *) + +val backtrace_to_string : backtrace -> string +(** [backtrace_to_string info] does get the backtrace associated to info *) + +val record_backtrace : bool -> unit + +val capture : exn -> iexn +(** Add the current backtrace information to the given exception. + + The intended use case is of the form: {[ + + try foo + with + | Bar -> bar + | exn -> + let exn = Exninfo.capture err in + baz + + ]} + + where [baz] should re-raise using [iraise] below. + + WARNING: any intermediate code between the [with] and the handler may + modify the backtrace. Yes, that includes [when] clauses. Ideally, what you + should do is something like: {[ + + try foo + with exn -> + let exn = Exninfo.capture exn in + match err with + | Bar -> bar + | err -> baz + + ]} + + I admit that's a bit heavy, but there is not much to do... + +*) + val iraise : iexn -> 'a (** Raise the given enriched exception. *) @@ -28,7 +28,7 @@ depends: [ ] build: [ - [ "./configure" "-prefix" prefix "-native-compiler" "no" ] + [ "./configure" "-prefix" prefix ] [ "make" "-f" "Makefile.dune" "voboot" ] [ "dune" "build" "-p" name "-j" jobs ] ] diff --git a/default.nix b/default.nix index 174e199014..ae6a8d06e5 100644 --- a/default.nix +++ b/default.nix @@ -77,7 +77,7 @@ stdenv.mkDerivation rec { !elem (baseNameOf path) [".git" "result" "bin" "_build" "_build_ci" "nix"]) ./.; preConfigure = '' - patchShebangs dev/tools/ + patchShebangs dev/tools/ doc/stdlib ''; prefixKey = "-prefix "; diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 9e9e3b4cfa..60c266699c 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -97,11 +97,8 @@ ######################################################################## # Coquelicot ######################################################################## -# Modified until https://gitlab.inria.fr/coquelicot/coquelicot/merge_requests/2 is merged -: "${coquelicot_CI_REF:=fix-rlist-import}" -: "${coquelicot_CI_GITURL:=https://gitlab.inria.fr/pedrot/coquelicot}" -# : "${coquelicot_CI_REF:=master}" -# : "${coquelicot_CI_GITURL:=https://gitlab.inria.fr/coquelicot/coquelicot}" +: "${coquelicot_CI_REF:=master}" +: "${coquelicot_CI_GITURL:=https://gitlab.inria.fr/coquelicot/coquelicot}" : "${coquelicot_CI_ARCHIVEURL:=${coquelicot_CI_GITURL}/-/archive}" ######################################################################## @@ -168,13 +165,6 @@ : "${fiat_crypto_CI_ARCHIVEURL:=${fiat_crypto_CI_GITURL}/archive}" ######################################################################## -# fiat_crypto_legacy -######################################################################## -: "${fiat_crypto_legacy_CI_REF:=sp2019latest}" -: "${fiat_crypto_legacy_CI_GITURL:=https://github.com/mit-plv/fiat-crypto}" -: "${fiat_crypto_legacy_CI_ARCHIVEURL:=${fiat_crypto_legacy_CI_GITURL}/archive}" - -######################################################################## # coq_dpdgraph ######################################################################## : "${coq_dpdgraph_CI_REF:=coq-master}" @@ -259,6 +249,13 @@ : "${quickchick_CI_ARCHIVEURL:=${quickchick_CI_GITURL}/archive}" ######################################################################## +# reduction-effects +######################################################################## +: "${reduction_effects_CI_REF:=master}" +: "${reduction_effects_CI_GITURL:=https://github.com/coq-community/reduction-effects}" +: "${reduction_effects_CI_ARCHIVEURL:=${reduction_effects_CI_GITURL}/archive}" + +######################################################################## # menhirlib ######################################################################## : "${menhirlib_CI_REF:=master}" diff --git a/dev/ci/ci-fiat-crypto-legacy.sh b/dev/ci/ci-fiat-crypto-legacy.sh deleted file mode 100755 index 2af4b58201..0000000000 --- a/dev/ci/ci-fiat-crypto-legacy.sh +++ /dev/null @@ -1,14 +0,0 @@ -#!/usr/bin/env bash - -ci_dir="$(dirname "$0")" -. "${ci_dir}/ci-common.sh" - -FORCE_GIT=1 -git_download fiat_crypto_legacy - -fiat_crypto_legacy_CI_TARGETS1="print-old-pipeline-lite old-pipeline-lite lite-display" -fiat_crypto_legacy_CI_TARGETS2="print-old-pipeline-nobigmem old-pipeline-nobigmem nonautogenerated-specific nonautogenerated-specific-display" - -( cd "${CI_BUILD_DIR}/fiat_crypto_legacy" && git submodule update --init --recursive && \ - ./etc/ci/remove_autogenerated.sh && \ - make ${fiat_crypto_legacy_CI_TARGETS1} && make -j 1 ${fiat_crypto_legacy_CI_TARGETS2} ) diff --git a/dev/ci/ci-fiat-crypto.sh b/dev/ci/ci-fiat-crypto.sh index 000c418137..811fefda35 100755 --- a/dev/ci/ci-fiat-crypto.sh +++ b/dev/ci/ci-fiat-crypto.sh @@ -9,11 +9,15 @@ git_download fiat_crypto # We need a larger stack size to not overflow ocamlopt+flambda when # building the executables. # c.f. https://github.com/coq/coq/pull/8313#issuecomment-416650241 +fiat_crypto_CI_STACKSIZE=32768 -fiat_crypto_CI_MAKE_ARGS="EXTERNAL_DEPENDENCIES=1" +# fiat-crypto is not guaranteed to build with the latest version of +# bedrock2, so we use the pinned version of bedrock2, but the external +# version of other developments +fiat_crypto_CI_MAKE_ARGS="EXTERNAL_REWRITER=1 EXTERNAL_COQPRIME=1" fiat_crypto_CI_TARGETS1="${fiat_crypto_CI_MAKE_ARGS} standalone-ocaml c-files rust-files printlite lite" fiat_crypto_CI_TARGETS2="${fiat_crypto_CI_MAKE_ARGS} all" ( cd "${CI_BUILD_DIR}/fiat_crypto" && git submodule update --init --recursive && \ - ulimit -s 32768 && \ + ulimit -s ${fiat_crypto_CI_STACKSIZE} && \ make ${fiat_crypto_CI_TARGETS1} && make -j 1 ${fiat_crypto_CI_TARGETS2} ) diff --git a/dev/ci/ci-mtac2.sh b/dev/ci/ci-mtac2.sh index 7075d4d7f6..e08dcf07ab 100755 --- a/dev/ci/ci-mtac2.sh +++ b/dev/ci/ci-mtac2.sh @@ -3,10 +3,6 @@ ci_dir="$(dirname "$0")" . "${ci_dir}/ci-common.sh" -git_download unicoq - -( cd "${CI_BUILD_DIR}/unicoq" && coq_makefile -f Make -o Makefile && make && make install ) - git_download mtac2 ( cd "${CI_BUILD_DIR}/mtac2" && coq_makefile -f _CoqProject -o Makefile && make ) diff --git a/dev/ci/ci-reduction_effects.sh b/dev/ci/ci-reduction_effects.sh new file mode 100755 index 0000000000..6b6de3fa2f --- /dev/null +++ b/dev/ci/ci-reduction_effects.sh @@ -0,0 +1,8 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +. "${ci_dir}/ci-common.sh" + +git_download reduction_effects + +( cd "${CI_BUILD_DIR}/reduction_effects" && make && make test && make install) diff --git a/dev/ci/ci-unicoq.sh b/dev/ci/ci-unicoq.sh new file mode 100755 index 0000000000..36acb115e9 --- /dev/null +++ b/dev/ci/ci-unicoq.sh @@ -0,0 +1,8 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +. "${ci_dir}/ci-common.sh" + +git_download unicoq + +( cd "${CI_BUILD_DIR}/unicoq" && coq_makefile -f Make -o Makefile && make && make install ) diff --git a/dev/ci/nix/default.nix b/dev/ci/nix/default.nix index f08a08531f..c8ea59f08a 100644 --- a/dev/ci/nix/default.nix +++ b/dev/ci/nix/default.nix @@ -91,7 +91,6 @@ let projects = { cross_crypto = callPackage ./cross_crypto.nix {}; Elpi = callPackage ./Elpi.nix {}; fiat_crypto = callPackage ./fiat_crypto.nix {}; - fiat_crypto_legacy = callPackage ./fiat_crypto_legacy.nix {}; flocq = callPackage ./flocq.nix {}; formal-topology = callPackage ./formal-topology.nix {}; GeoCoq = callPackage ./GeoCoq.nix {}; diff --git a/dev/ci/nix/fiat_crypto_legacy.nix b/dev/ci/nix/fiat_crypto_legacy.nix deleted file mode 100644 index 3248665579..0000000000 --- a/dev/ci/nix/fiat_crypto_legacy.nix +++ /dev/null @@ -1,6 +0,0 @@ -{}: - -{ - configure = "./etc/ci/remove_autogenerated.sh"; - make = "make print-old-pipeline-lite old-pipeline-lite lite-display"; -} diff --git a/dev/ci/user-overlays/11235-non-maximal-implicit.sh b/dev/ci/user-overlays/11235-non-maximal-implicit.sh new file mode 100644 index 0000000000..fd63980036 --- /dev/null +++ b/dev/ci/user-overlays/11235-non-maximal-implicit.sh @@ -0,0 +1,9 @@ +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/11417-ppedrot-rm-kind-of-type.sh b/dev/ci/user-overlays/11417-ppedrot-rm-kind-of-type.sh new file mode 100644 index 0000000000..5fb29e1826 --- /dev/null +++ b/dev/ci/user-overlays/11417-ppedrot-rm-kind-of-type.sh @@ -0,0 +1,6 @@ +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 new file mode 100644 index 0000000000..f2a431978d --- /dev/null +++ b/dev/ci/user-overlays/11521-SkySkimmer-no-optname.sh @@ -0,0 +1,15 @@ +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/doc/changes.md b/dev/doc/changes.md index 04b20c6889..cb6e695865 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -2,6 +2,13 @@ ### ML API +Exception handling: + +- Coq's custom `Backtrace` module has been removed in favor of OCaml's + native backtrace implementation. Please use the functions in + `Exninfo.capture` and `iraise` when re-raising inside an exception + handler. + Printers: - Functions such as Printer.pr_lconstr_goal_style_env have been @@ -10,6 +17,11 @@ Printers: Constrextern.extern_constr which were taking a boolean argument for the goal style now take instead a label. +Implicit arguments: + +- The type `Impargs.implicit_kind` was removed in favor of + `Glob_term.binding_kind`. + ## Changes between Coq 8.10 and Coq 8.11 ### ML API diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 835c20a4f7..f640a33773 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -254,7 +254,9 @@ let ppenvwithcst e = pp let pptac = (fun x -> pp(Ltac_plugin.Pptactic.pr_glob_tactic (Global.env()) x)) -let ppobj obj = Format.print_string (Libobject.object_tag obj) +let ppobj obj = + let Libobject.Dyn.Dyn (tag, _) = obj in + Format.print_string (Libobject.Dyn.repr tag) let cnt = ref 0 diff --git a/doc/changelog/02-specification-language/10202-master+fix8011-stronger-check-on-typability-ltac-env.rst b/doc/changelog/02-specification-language/10202-master+fix8011-stronger-check-on-typability-ltac-env.rst new file mode 100644 index 0000000000..57bce7e4f6 --- /dev/null +++ b/doc/changelog/02-specification-language/10202-master+fix8011-stronger-check-on-typability-ltac-env.rst @@ -0,0 +1,7 @@ +- **Changed:** + Warn when manual implicit arguments are used in unexpected positions + of a term (e.g. in `Check id (forall {x}, x)`) or when a implicit + argument name is shadowed (e.g. in `Check fun f : forall {x:nat} + {x}, nat => f`) + (`#10202 <https://github.com/coq/coq/pull/10202>`_, + by Hugo Herbelin). 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 new file mode 100644 index 0000000000..32526babdb --- /dev/null +++ b/doc/changelog/02-specification-language/11098-master+arguments-supports-anonymous-implicit.rst @@ -0,0 +1,8 @@ +- **Added:** + :cmd:`Arguments <Arguments (implicits)>` now supports setting + 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>`_.). diff --git a/doc/changelog/02-specification-language/11235-non_maximal_implicit.rst b/doc/changelog/02-specification-language/11235-non_maximal_implicit.rst new file mode 100644 index 0000000000..d8ff1fec31 --- /dev/null +++ b/doc/changelog/02-specification-language/11235-non_maximal_implicit.rst @@ -0,0 +1,6 @@ +- **Added:** + Syntax for non maximal implicit arguments in definitions and terms using + square brackets. The syntax is ``[x : A]``, ``[x]``, ```[A]`` + to be consistent with the command :cmd:`Arguments (implicits)`. + (`#11235 <https://github.com/coq/coq/pull/11235>`_, + by SimonBoulier). diff --git a/doc/changelog/03-notations/11113-remove-compat.rst b/doc/changelog/03-notations/11113-remove-compat.rst index 8c71d70cda..3bcdd3dd6f 100644 --- a/doc/changelog/03-notations/11113-remove-compat.rst +++ b/doc/changelog/03-notations/11113-remove-compat.rst @@ -1,4 +1,4 @@ -- Removed deprecated ``compat`` modifier of :cmd:`Notation` +- **Removed:** deprecated ``compat`` modifier of :cmd:`Notation` and :cmd:`Infix` commands (`#11113 <https://github.com/coq/coq/pull/11113>`_, by Théo Zimmermann, with help from Jason Gross). diff --git a/doc/changelog/03-notations/11172-master+coercion-notation-interleaved-printing.rst b/doc/changelog/03-notations/11172-master+coercion-notation-interleaved-printing.rst index 8551cf3aac..f377b53ae2 100644 --- a/doc/changelog/03-notations/11172-master+coercion-notation-interleaved-printing.rst +++ b/doc/changelog/03-notations/11172-master+coercion-notation-interleaved-printing.rst @@ -1,2 +1,3 @@ -- The printing algorithm now interleave search for notations and removal of coercions +- **Changed:** + The printing algorithm now interleaves search for notations and removal of coercions (`#11172 <https://github.com/coq/coq/pull/11172>`_, by Hugo Herbelin). diff --git a/doc/changelog/03-notations/11240-rew-dependent.rst b/doc/changelog/03-notations/11240-rew-dependent.rst new file mode 100644 index 0000000000..e9daab0c2c --- /dev/null +++ b/doc/changelog/03-notations/11240-rew-dependent.rst @@ -0,0 +1,5 @@ +- **Added** + Added :g:`rew dependent` notations for the dependent version of + :g:`rew` in :g:`Coq.Init.Logic.EqNotations` to improve the display + and parsing of :g:`match` statements on :g:`Logic.eq` (`#11240 + <https://github.com/coq/coq/pull/11240>`_, by Jason Gross). diff --git a/doc/changelog/04-tactics/10760-more-rapply.rst b/doc/changelog/04-tactics/10760-more-rapply.rst index 2815f8af8a..eeae2ec519 100644 --- a/doc/changelog/04-tactics/10760-more-rapply.rst +++ b/doc/changelog/04-tactics/10760-more-rapply.rst @@ -1,4 +1,5 @@ -- The tactic :tacn:`rapply` in :g:`Coq.Program.Tactics` now handles +- **Changed:** + The tactic :tacn:`rapply` in :g:`Coq.Program.Tactics` now handles arbitrary numbers of underscores and takes in a :g:`uconstr`. In rare cases where users were relying on :tacn:`rapply` inserting exactly 15 underscores and no more, due to the lemma having a diff --git a/doc/changelog/04-tactics/11023-nativecompute-timing.rst b/doc/changelog/04-tactics/11023-nativecompute-timing.rst new file mode 100644 index 0000000000..2afa3990ac --- /dev/null +++ b/doc/changelog/04-tactics/11023-nativecompute-timing.rst @@ -0,0 +1,7 @@ +- The :flag:`NativeCompute Timing` flag causes calls to + :tacn:`native_compute` (as well as kernel calls to the native + 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 + <https://github.com/coq/coq/pull/11023>`_, by Jason Gross). diff --git a/doc/changelog/04-tactics/11474-lia-bug-fix-11436.rst b/doc/changelog/04-tactics/11474-lia-bug-fix-11436.rst new file mode 100644 index 0000000000..2a341261e5 --- /dev/null +++ b/doc/changelog/04-tactics/11474-lia-bug-fix-11436.rst @@ -0,0 +1,9 @@ +- **Added:** + :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`` + (`#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/05-tactic-language/10343-issue-10342-ltac2-standard-library.rst b/doc/changelog/05-tactic-language/10343-issue-10342-ltac2-standard-library.rst new file mode 100644 index 0000000000..4acc423d10 --- /dev/null +++ b/doc/changelog/05-tactic-language/10343-issue-10342-ltac2-standard-library.rst @@ -0,0 +1,4 @@ +- **Added:** + An array library for ltac2 (OCaml standard library compatible where possible). + (`#10343 <https://github.com/coq/coq/pull/10343>`_, + by Michael Soegtrop). diff --git a/doc/changelog/07-commands-and-options/11162-local-cs.rst b/doc/changelog/07-commands-and-options/11162-local-cs.rst index 5a69a107cd..638222fbe1 100644 --- a/doc/changelog/07-commands-and-options/11162-local-cs.rst +++ b/doc/changelog/07-commands-and-options/11162-local-cs.rst @@ -1 +1,3 @@ -- Handle the ``#[local]`` attribute in :g:`Canonical Structure` declarations (`#11162 <https://github.com/coq/coq/pull/11162>`_, by Enrico Tassi). +- **Added:** Handle the ``#[local]`` attribute in :g:`Canonical + Structure` declarations (`#11162 + <https://github.com/coq/coq/pull/11162>`_, by Enrico Tassi). 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 b9ecd140e7..ec34c075ae 100644 --- a/doc/changelog/07-commands-and-options/11164-let-cs.rst +++ b/doc/changelog/07-commands-and-options/11164-let-cs.rst @@ -1 +1,3 @@ -- A section variable introduces with :g:`Let` can be declared as a :g:`Canonical Structure` (`#11164 <https://github.com/coq/coq/pull/11164>`_, by Enrico Tassi). +- **Added:** A section variable introduces with :g:`Let` can be + declared as a :g:`Canonical Structure` (`#11164 + <https://github.com/coq/coq/pull/11164>`_, by Enrico Tassi). diff --git a/doc/changelog/07-commands-and-options/11409-mltop+deprecate_use.rst b/doc/changelog/07-commands-and-options/11409-mltop+deprecate_use.rst new file mode 100644 index 0000000000..db433ad64c --- /dev/null +++ b/doc/changelog/07-commands-and-options/11409-mltop+deprecate_use.rst @@ -0,0 +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. + (`#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 new file mode 100644 index 0000000000..90c23d8b76 --- /dev/null +++ b/doc/changelog/08-tools/11523-coqdep+refactor2.rst @@ -0,0 +1,7 @@ +- **Changed:** + Internal options and behavior of ``coqdep`` have changed, in particular + options ``-w``, ``-D``, ``-mldep``, and ``-dumpbox`` have been removed, + and ``-boot`` will not load any path by default, ``-R/-Q`` should be + used instead + (`#11523 <https://github.com/coq/coq/pull/11523>`_, + by Emilio Jesus Gallego Arias). diff --git a/doc/changelog/09-coqide/11414-remove-ide-tactic-menu.rst b/doc/changelog/09-coqide/11414-remove-ide-tactic-menu.rst new file mode 100644 index 0000000000..6294cdb24a --- /dev/null +++ b/doc/changelog/09-coqide/11414-remove-ide-tactic-menu.rst @@ -0,0 +1,4 @@ +- **Removed:** + Removed the "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 new file mode 100644 index 0000000000..cb92945b8b --- /dev/null +++ b/doc/changelog/09-coqide/11415-remove-ide-revert-all-buffers.rst @@ -0,0 +1,4 @@ +- **Removed:** + Removed the "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/11404-removeRList.rst b/doc/changelog/10-standard-library/11404-removeRList.rst new file mode 100644 index 0000000000..88e22d128c --- /dev/null +++ b/doc/changelog/10-standard-library/11404-removeRList.rst @@ -0,0 +1,15 @@ +- **Removed:** + Type `RList` has been removed. All uses have been replaced by `list R`. + Functions from `RList` named `In`, `Rlength`, `cons_Rlist`, `app_Rlist` + have also been removed as they are essentially the same as `In`, `length`, + `app`, and `map` from `List`, modulo the following changes: + + - `RList.In x (RList.cons a l)` used to be convertible to + `(x = a) \\/ RList.In x l`, + but `List.In x (a :: l)` is convertible to + `(a = x) \\/ List.In l`. + The equality is reversed. + - `app_Rlist` and `List.map` take arguments in different order. + + (`#11404 <https://github.com/coq/coq/pull/11404>`_, + by Yves Bertot). diff --git a/doc/sphinx/addendum/micromega.rst b/doc/sphinx/addendum/micromega.rst index cc19c8b6a9..f706633da9 100644 --- a/doc/sphinx/addendum/micromega.rst +++ b/doc/sphinx/addendum/micromega.rst @@ -35,6 +35,17 @@ tactics for solving arithmetic goals over :math:`\mathbb{Q}`, use the Simplex method for solving linear goals. If it is not set, the decision procedures are using Fourier elimination. +.. opt:: Dump Arith + + This option (unset by default) may be set to a file path where + debug info will be written. + +.. cmd:: Show Lia Profile + + This command prints some statistics about the amount of pivoting + operations needed by :tacn:`lia` and may be useful to detect + inefficiencies (only meaningful if flag :flag:`Simplex` is set). + .. flag:: Lia Cache This flag (set by default) instructs :tacn:`lia` to cache its results in the file `.lia.cache` diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index 510e271951..f0bbaed8f3 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -1570,11 +1570,26 @@ inserted. In the second case, the function is considered to be implicitly applied to the implicit arguments it is waiting for: one says that the implicit argument is maximally inserted. -Each implicit argument can be declared to have to be inserted maximally or non -maximally. This can be governed argument per argument by the command -:cmd:`Arguments (implicits)` or globally by the :flag:`Maximal Implicit Insertion` flag. +Each implicit argument can be declared to be inserted maximally or non +maximally. In Coq, maximally-inserted implicit arguments are written between curly braces +"{ }" and non-maximally-inserted implicit arguments are written in square brackets "[ ]". -.. seealso:: :ref:`displaying-implicit-args`. +.. seealso:: :flag:`Maximal Implicit Insertion` + +Trailing Implicit Arguments ++++++++++++++++++++++++++++ + +An implicit argument is considered trailing when all following arguments are declared +implicit. Trailing implicit arguments cannot be declared non maximally inserted, +otherwise they would never be inserted. + +.. exn:: Argument @name is a trailing implicit, so it can't be declared non maximal. Please use %{ %} instead of [ ]. + + For instance: + + .. coqtop:: all fail + + Fail Definition double [n] := n + n. Casual use of implicit arguments @@ -1608,7 +1623,7 @@ Implicit Argument Binders In the first setting, one wants to explicitly give the implicit arguments of a declared object as part of its definition. To do this, one has to surround the bindings of implicit arguments by curly -braces: +braces or square braces: .. coqtop:: all @@ -1624,6 +1639,17 @@ absent in every situation but still be able to specify it if needed: Goal forall A, compose id id = id (A:=A). +For non maximally inserted implicit arguments, use square brackets: + +.. coqtop:: all + + Fixpoint map [A B : Type] (f : A -> B) (l : list A) : list B := + match l with + | nil => nil + | cons a t => cons (f a) (map f t) + end. + + Print Implicit map. The syntax is supported in all top-level definitions: :cmd:`Definition`, :cmd:`Fixpoint`, :cmd:`Lemma` and so on. For (co-)inductive datatype @@ -1643,17 +1669,55 @@ For example: One can always specify the parameter if it is not uniform using the usual implicit arguments disambiguation syntax. +The syntax is also supported in internal binders. For instance, in the +following kinds of expressions, the type of each declaration present +in :token:`binders` can be bracketed to mark the declaration as +implicit: +:n:`fun (@ident:forall @binders, @type) => @term`, +:n:`forall (@ident:forall @binders, @type), @type`, +:n:`let @ident @binders := @term in @term`, +:n:`fix @ident @binders := @term in @term` and +:n:`cofix @ident @binders := @term in @term`. +Here is an example: + +.. coqtop:: all + + Axiom Ax : + forall (f:forall {A} (a:A), A * A), + let g {A} (x y:A) := (x,y) in + f 0 = g 0 0. + +.. warn:: Ignoring implicit binder declaration in unexpected position + + This is triggered when setting an argument implicit in an + expression which does not correspond to the type of an assumption + or to the body of a definition. Here is an example: + + .. coqtop:: all warn + + Definition f := forall {y}, y = 0. + +.. warn:: Making shadowed name of implicit argument accessible by position + + This is triggered when two variables of same name are set implicit + in the same block of binders, in which case the first occurrence is + considered to be unnamed. Here is an example: + + .. coqtop:: all warn + + Check let g {x:nat} (H:x=x) {x} (H:x=x) := x in 0. + Declaring Implicit Arguments ++++++++++++++++++++++++++++ -.. cmd:: Arguments @qualid {* {| [ @ident ] | { @ident } | @ident } } +.. cmd:: Arguments @qualid {* {| [ @name ] | { @name } | @name } } :name: Arguments (implicits) This command is used to set implicit arguments *a posteriori*, - where the list of possibly bracketed :token:`ident` is a prefix of the list of + where the list of possibly bracketed :token:`name` is a prefix of the list of arguments of :token:`qualid` where the ones to be declared implicit are surrounded by square brackets and the ones to be declared as maximally inserted implicits are surrounded by curly braces. @@ -1667,20 +1731,20 @@ Declaring Implicit Arguments This command clears implicit arguments. -.. cmdv:: Global Arguments @qualid {* {| [ @ident ] | { @ident } | @ident } } +.. cmdv:: Global Arguments @qualid {* {| [ @name ] | { @name } | @name } } This command is used to recompute the implicit arguments of :token:`qualid` after ending of the current section if any, enforcing the implicit arguments known from inside the section to be the ones declared by the command. -.. cmdv:: Local Arguments @qualid {* {| [ @ident ] | { @ident } | @ident } } +.. cmdv:: Local Arguments @qualid {* {| [ @name ] | { @name } | @name } } When in a module, tell not to activate the implicit arguments of :token:`qualid` declared by this command to contexts that require the module. -.. cmdv:: {? {| Global | Local } } Arguments @qualid {*, {+ {| [ @ident ] | { @ident } | @ident } } } +.. cmdv:: {? {| Global | Local } } Arguments @qualid {*, {+ {| [ @name ] | { @name } | @name } } } For names of constants, inductive types, constructors, lemmas which can only be applied to a fixed number of @@ -1728,14 +1792,6 @@ Declaring Implicit Arguments To know which are the implicit arguments of an object, use the command :cmd:`Print Implicit` (see :ref:`displaying-implicit-args`). -.. exn:: Argument @ident is a trailing implicit, so it can't be declared non maximal. Please use %{ %} instead of [ ]. - - For instance in - - .. coqtop:: all fail - - Arguments prod _ [_]. - Automatic declaration of implicit arguments ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1811,7 +1867,7 @@ appear strictly in the body of the type, they are implicit. Mode for automatic declaration of implicit arguments -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +++++++++++++++++++++++++++++++++++++++++++++++++++++ .. flag:: Implicit Arguments @@ -1823,7 +1879,7 @@ Mode for automatic declaration of implicit arguments .. _controlling-strict-implicit-args: Controlling strict implicit arguments -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ++++++++++++++++++++++++++++++++++++++ .. flag:: Strict Implicit @@ -1842,7 +1898,7 @@ Controlling strict implicit arguments .. _controlling-contextual-implicit-args: Controlling contextual implicit arguments -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ++++++++++++++++++++++++++++++++++++++++++ .. flag:: Contextual Implicit @@ -1853,7 +1909,7 @@ Controlling contextual implicit arguments .. _controlling-rev-pattern-implicit-args: Controlling reversible-pattern implicit arguments -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ++++++++++++++++++++++++++++++++++++++++++++++++++ .. flag:: Reversible Pattern Implicit @@ -1864,7 +1920,7 @@ Controlling reversible-pattern implicit arguments .. _controlling-insertion-implicit-args: Controlling the insertion of implicit arguments not followed by explicit arguments -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ .. flag:: Maximal Implicit Insertion @@ -1873,6 +1929,28 @@ Controlling the insertion of implicit arguments not followed by explicit argumen function is partially applied and the next argument of the function is an implicit one. +Combining manual declaration and automatic declaration +++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +When some arguments are manually specified implicit with binders in a definition +and the automatic declaration mode in on, the manual implicit arguments are added to the +automatically declared ones. + +In that case, and when the flag :flag:`Maximal Implicit Insertion` is set to off, +some trailing implicit arguments can be inferred to be non maximally inserted. In +this case, they are converted to maximally inserted ones. + +.. example:: + + .. coqtop:: all + + Set Implicit Arguments. + Axiom eq0_le0 : forall (n : nat) (x : n = 0), n <= 0. + Print Implicit eq0_le0. + Axiom eq0_le0' : forall (n : nat) {x : n = 0}, n <= 0. + Print Implicit eq0_le0'. + + .. _explicit-applications: Explicit applications @@ -2136,8 +2214,10 @@ Implicit generalization ~~~~~~~~~~~~~~~~~~~~~~~ .. index:: `{ } +.. index:: `[ ] .. index:: `( ) .. index:: `{! } +.. index:: `[! ] .. index:: `(! ) Implicit generalization is an automatic elaboration of a statement @@ -2145,11 +2225,12 @@ with free variables into a closed statement where these variables are quantified explicitly. It is activated for a binder by prefixing a \`, and for terms by -surrounding it with \`{ } or \`( ). +surrounding it with \`{ }, or \`[ ] or \`( ). Terms surrounded by \`{ } introduce their free variables as maximally -inserted implicit arguments, and terms surrounded by \`( ) introduce -them as explicit arguments. +inserted implicit arguments, terms surrounded by \`[ ] introduce them as +non maximally inserted implicit arguments and terms surrounded by \`( ) +introduce them as explicit arguments. Generalizing binders always introduce their free variables as maximally inserted implicit arguments. The binder itself introduces diff --git a/doc/sphinx/language/gallina-specification-language.rst b/doc/sphinx/language/gallina-specification-language.rst index d591718b17..721c7a7a51 100644 --- a/doc/sphinx/language/gallina-specification-language.rst +++ b/doc/sphinx/language/gallina-specification-language.rst @@ -283,8 +283,10 @@ Binders | ( {+ @name } : @term ) | ( @name {? : @term } := @term ) | %{ {+ @name } {? : @term } %} + | [ {+ @name } {? : @term } ] | `( {+, @typeclass_constraint } ) | `%{ {+, @typeclass_constraint } %} + | `[ {+, @typeclass_constraint } ] | ' @pattern0 | ( @name : @term %| @term ) typeclass_constraint ::= {? ! } @term @@ -1061,6 +1063,9 @@ Parameterized inductive types | cons3 : A -> list3 -> list3. End list3. + Attributes ``uniform`` and ``nonuniform`` respectively enable and + disable uniform parameters for a single inductive declaration block. + .. seealso:: Section :ref:`inductive-definitions` and the :tacn:`induction` tactic. diff --git a/doc/sphinx/practical-tools/coq-commands.rst b/doc/sphinx/practical-tools/coq-commands.rst index ba43128bdc..98d222e317 100644 --- a/doc/sphinx/practical-tools/coq-commands.rst +++ b/doc/sphinx/practical-tools/coq-commands.rst @@ -157,8 +157,6 @@ and ``coqtop``, unless stated otherwise: loading the default resource file from the standard configuration directories. :-q: Do not to load the default resource file. -:-load-ml-source *file*: Load the OCaml source file *file*. -:-load-ml-object *file*: Load the OCaml object file *file*. :-l *file*, -load-vernac-source *file*: Load and execute the |Coq| script from *file.v*. :-lv *file*, -load-vernac-source-verbose *file*: Load and execute the diff --git a/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index 853ddfd6dc..46215f16a6 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -2222,14 +2222,14 @@ tactics to *permute* the subgoals generated by a tactic. If :token:`num`\'s value is :math:`k`, this tactic rotates the :math:`n` subgoals :math:`G_1` , …, :math:`G_n` - in focus. The first subgoal becomes :math:`G_{n + 1 − k}` and the + in focus. Subgoal :math:`G_{n + 1 − k}` becomes the first, and the circular order of subgoals remains unchanged. .. tacn:: first @num last If :token:`num`\'s value is :math:`k`, this tactic rotates the :math:`n` subgoals :math:`G_1` , …, :math:`G_n` - in focus. The first subgoal becomes :math:`G_k` and the circular order + in focus. Subgoal :math:`G_{k + 1 \bmod n}` becomes the first, and the circular order of subgoals remains unchanged. Finally, the tactics ``last`` and ``first`` combine with the branching syntax diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 53cfb973d4..36a5916868 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -3113,6 +3113,12 @@ the conversion in hypotheses :n:`{+ @ident}`. compilation cost is higher, so it is worth using only for intensive computations. + .. flag:: NativeCompute Timing + + This flag causes all calls to the native compiler to print + timing information for the compilation, execution, and + reification phases of native compilation. + .. flag:: NativeCompute Profiling On Linux, if you have the ``perf`` profiler installed, this flag makes diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index 5e13214a1a..b2ddf36b65 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -664,7 +664,6 @@ through the <tt>Require Import</tt> command.</p> </dt> <dd> theories/Compat/AdmitAxiom.v - theories/Compat/Coq89.v theories/Compat/Coq810.v theories/Compat/Coq811.v theories/Compat/Coq812.v diff --git a/doc/tools/coqrst/checkdeps.py b/doc/tools/coqrst/checkdeps.py index 91f0a7cb1b..feafcba026 100644 --- a/doc/tools/coqrst/checkdeps.py +++ b/doc/tools/coqrst/checkdeps.py @@ -10,13 +10,20 @@ from __future__ import print_function import sys +missing_deps = [] + def eprint(*args, **kwargs): print(*args, file=sys.stderr, **kwargs) def missing_dep(dep): - eprint('Cannot find %s (needed to build documentation)' % dep) - eprint('You can run `pip3 install %s` to install it.' % dep) - sys.exit(1) + missing_deps.append(dep) + +def report_missing_deps(): + if len(missing_deps) > 0: + deps = " ".join(missing_deps) + eprint('Cannot find package(s) `%s` (needed to build documentation)' % deps) + eprint('You can run `pip3 install %s` to install it/them.' % deps) + sys.exit(1) try: import sphinx_rtd_theme @@ -37,3 +44,10 @@ try: import bs4 except: missing_dep('beautifulsoup4') + +try: + import sphinxcontrib.bibtex +except: + missing_dep('sphinxcontrib-bibtex') + +report_missing_deps() @@ -25,7 +25,11 @@ (source_tree theories) (source_tree plugins) (source_tree user-contrib)) - (action (with-stdout-to .vfiles.d (bash "%{bin:coqdep} -dyndep both -noglob -boot `find theories plugins user-contrib -type f -name *.v`")))) + (action + (with-stdout-to .vfiles.d + (bash "%{bin:coqdep} -dyndep both -noglob -boot -R theories Coq -R plugins Coq -Q user-contrib/Ltac2 Ltac2 -I user-contrib/Ltac2 \ + `find plugins/ -maxdepth 1 -mindepth 1 -type d -printf '-I %p '` \ + `find theories plugins user-contrib -type f -name *.v`")))) (alias (name vodeps) diff --git a/engine/eConstr.ml b/engine/eConstr.ml index 150dad16c2..08e283f524 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -119,6 +119,20 @@ let isVarId sigma id c = let isRelN sigma n c = match kind sigma c with Rel n' -> Int.equal n n' | _ -> false +let isRef sigma c = match kind sigma c with + | Const _ | Ind _ | Construct _ | Var _ -> true + | _ -> false + +let isRefX sigma x c = + let open GlobRef in + match x, kind sigma c with + | ConstRef c, Const (c', _) -> Constant.equal c c' + | IndRef i, Ind (i', _) -> eq_ind i i' + | ConstructRef i, Construct (i', _) -> eq_constructor i i' + | VarRef id, Var id' -> Id.equal id id' + | _ -> false + + let destRel sigma c = match kind sigma c with | Rel p -> p | _ -> raise DestKO @@ -723,8 +737,27 @@ let fresh_global ?loc ?rigid ?names env sigma reference = let (evd,t) = Evd.fresh_global ?loc ?rigid ?names env sigma reference in evd, t -let is_global sigma gr c = - Globnames.is_global gr (to_constr sigma c) +let is_global = isRefX + +(** Kind of type *) + +type kind_of_type = + | SortType of ESorts.t + | CastType of types * t + | ProdType of Name.t Context.binder_annot * t * t + | LetInType of Name.t Context.binder_annot * t * t * t + | AtomicType of t * t array + +let kind_of_type sigma t = match kind sigma t with + | Sort s -> SortType s + | Cast (c,_,t) -> CastType (c, t) + | Prod (na,t,c) -> ProdType (na, t, c) + | LetIn (na,b,t,c) -> LetInType (na, b, t, c) + | App (c,l) -> AtomicType (c, l) + | (Rel _ | Meta _ | Var _ | Evar _ | Const _ + | Proj _ | Case _ | Fix _ | CoFix _ | Ind _) + -> AtomicType (t,[||]) + | (Lambda _ | Construct _ | Int _ | Float _) -> failwith "Not a type" module Unsafe = struct diff --git a/engine/eConstr.mli b/engine/eConstr.mli index 90f50b764c..ead7d88176 100644 --- a/engine/eConstr.mli +++ b/engine/eConstr.mli @@ -80,7 +80,14 @@ val to_constr : ?abort_on_undefined_evars:bool -> Evd.evar_map -> t -> Constr.t val to_constr_opt : Evd.evar_map -> t -> Constr.t option (** Same as [to_constr], but returns [None] if some unresolved evars remain *) -val kind_of_type : Evd.evar_map -> t -> (t, t) Term.kind_of_type +type kind_of_type = + | SortType of ESorts.t + | CastType of types * t + | ProdType of Name.t Context.binder_annot * t * t + | LetInType of Name.t Context.binder_annot * t * t * t + | AtomicType of t * t array + +val kind_of_type : Evd.evar_map -> t -> kind_of_type (** {5 Constructors} *) @@ -152,6 +159,7 @@ val mkNamedProd_or_LetIn : named_declaration -> types -> types val isRel : Evd.evar_map -> t -> bool val isVar : Evd.evar_map -> t -> bool val isInd : Evd.evar_map -> t -> bool +val isRef : Evd.evar_map -> t -> bool val isEvar : Evd.evar_map -> t -> bool val isMeta : Evd.evar_map -> t -> bool val isSort : Evd.evar_map -> t -> bool @@ -175,6 +183,7 @@ val isArity : Evd.evar_map -> t -> bool val isVarId : Evd.evar_map -> Id.t -> t -> bool val isRelN : Evd.evar_map -> int -> t -> bool +val isRefX : Evd.evar_map -> GlobRef.t -> t -> bool val destRel : Evd.evar_map -> t -> int val destMeta : Evd.evar_map -> t -> metavariable @@ -319,6 +328,7 @@ val fresh_global : Evd.evar_map -> GlobRef.t -> Evd.evar_map * t val is_global : Evd.evar_map -> GlobRef.t -> t -> bool +[@@ocaml.deprecated "Use [EConstr.isRefX] instead."] (** {5 Extra} *) diff --git a/engine/evarutil.ml b/engine/evarutil.ml index b09cc87f97..8533e05d3e 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -555,7 +555,7 @@ let rec check_and_clear_in_constr env evdref err ids global c = let () = if global then let check id' = if Id.Set.mem id' ids then - raise (ClearDependencyError (id',err,Some (Globnames.global_of_constr c))) + raise (ClearDependencyError (id',err,Some (fst @@ destRef c))) in Id.Set.iter check (Environ.vars_of_global env (fst @@ destRef c)) in diff --git a/engine/evd.ml b/engine/evd.ml index 8e7d942c37..4bfa7c45e3 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -902,14 +902,14 @@ let make_nonalgebraic_variable evd u = let fresh_sort_in_family ?loc ?(rigid=univ_flexible) evd s = with_context_set ?loc rigid evd (UnivGen.fresh_sort_in_family s) -let fresh_constant_instance ?loc env evd c = - with_context_set ?loc univ_flexible evd (UnivGen.fresh_constant_instance env c) +let fresh_constant_instance ?loc ?(rigid=univ_flexible) env evd c = + with_context_set ?loc rigid evd (UnivGen.fresh_constant_instance env c) -let fresh_inductive_instance ?loc env evd i = - with_context_set ?loc univ_flexible evd (UnivGen.fresh_inductive_instance env i) +let fresh_inductive_instance ?loc ?(rigid=univ_flexible) env evd i = + with_context_set ?loc rigid evd (UnivGen.fresh_inductive_instance env i) -let fresh_constructor_instance ?loc env evd c = - with_context_set ?loc univ_flexible evd (UnivGen.fresh_constructor_instance env c) +let fresh_constructor_instance ?loc ?(rigid=univ_flexible) env evd c = + with_context_set ?loc rigid evd (UnivGen.fresh_constructor_instance env c) let fresh_global ?loc ?(rigid=univ_flexible) ?names env evd gr = with_context_set ?loc rigid evd (UnivGen.fresh_global_instance ?loc ?names env gr) @@ -1364,7 +1364,6 @@ module MiniEConstr = struct let kind sigma c = Constr.kind (whd_evar sigma c) let kind_upto = kind - let kind_of_type sigma c = Term.kind_of_type (whd_evar sigma c) let of_kind = Constr.of_kind let of_constr c = c let of_constr_array v = v diff --git a/engine/evd.mli b/engine/evd.mli index 8843adc853..2c1194a5de 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -653,10 +653,14 @@ val update_sigma_env : evar_map -> env -> evar_map (** Polymorphic universes *) -val fresh_sort_in_family : ?loc:Loc.t -> ?rigid:rigid -> evar_map -> Sorts.family -> evar_map * Sorts.t -val fresh_constant_instance : ?loc:Loc.t -> env -> evar_map -> Constant.t -> evar_map * pconstant -val fresh_inductive_instance : ?loc:Loc.t -> env -> evar_map -> inductive -> evar_map * pinductive -val fresh_constructor_instance : ?loc:Loc.t -> env -> evar_map -> constructor -> evar_map * pconstructor +val fresh_sort_in_family : ?loc:Loc.t -> ?rigid:rigid + -> evar_map -> Sorts.family -> evar_map * Sorts.t +val fresh_constant_instance : ?loc:Loc.t -> ?rigid:rigid + -> env -> evar_map -> Constant.t -> evar_map * pconstant +val fresh_inductive_instance : ?loc:Loc.t -> ?rigid:rigid + -> env -> evar_map -> inductive -> evar_map * pinductive +val fresh_constructor_instance : ?loc:Loc.t -> ?rigid:rigid + -> env -> evar_map -> constructor -> evar_map * pconstructor val fresh_global : ?loc:Loc.t -> ?rigid:rigid -> ?names:Univ.Instance.t -> env -> evar_map -> GlobRef.t -> evar_map * econstr @@ -707,7 +711,6 @@ module MiniEConstr : sig val kind : evar_map -> t -> (t, t, ESorts.t, EInstance.t) Constr.kind_of_term val kind_upto : evar_map -> constr -> (constr, types, Sorts.t, Univ.Instance.t) Constr.kind_of_term - val kind_of_type : evar_map -> t -> (t, t) Term.kind_of_type val whd_evar : evar_map -> t -> t diff --git a/engine/namegen.ml b/engine/namegen.ml index 56277e8092..bcc8c34a4d 100644 --- a/engine/namegen.ml +++ b/engine/namegen.ml @@ -216,7 +216,6 @@ let it_mkLambda_or_LetIn_name env sigma b hyps = let get_mangle_names = Goptions.declare_bool_option_and_ref ~depr:false - ~name:"mangle auto-generated names" ~key:["Mangle";"Names"] ~value:false @@ -227,7 +226,6 @@ let set_prefix x = mangle_names_prefix := forget_subscript x let () = Goptions.( declare_string_option { optdepr = false; - optname = "mangled names prefix"; optkey = ["Mangle";"Names";"Prefix"]; optread = (fun () -> Id.to_string !mangle_names_prefix); optwrite = begin fun x -> diff --git a/engine/proofview.ml b/engine/proofview.ml index 16be96454e..b0ea75ac60 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -302,7 +302,8 @@ let tclONCE = Proof.once exception MoreThanOneSuccess let _ = CErrors.register_handler begin function - | MoreThanOneSuccess -> CErrors.user_err Pp.(str "This tactic has more than one success.") + | MoreThanOneSuccess -> + Pp.str "This tactic has more than one success." | _ -> raise CErrors.Unhandled end @@ -347,8 +348,7 @@ exception NoSuchGoals of int let _ = CErrors.register_handler begin function | NoSuchGoals n -> - CErrors.user_err - (str "No such " ++ str (String.plural n "goal") ++ str ".") + str "No such " ++ str (String.plural n "goal") ++ str "." | _ -> raise CErrors.Unhandled end @@ -420,12 +420,9 @@ let tclFOCUSID ?(nosuchgoal=tclZERO (NoSuchGoals 1)) id t = exception SizeMismatch of int*int let _ = CErrors.register_handler begin function | SizeMismatch (i,j) -> - let open Pp in - let errmsg = - str"Incorrect number of goals" ++ spc() ++ - str"(expected "++int i++str(String.plural i " tactic") ++ str", was given "++ int j++str")." - in - CErrors.user_err errmsg + let open Pp in + str"Incorrect number of goals" ++ spc() ++ + str"(expected "++int i++str(String.plural i " tactic") ++ str", was given "++ int j++str")." | _ -> raise CErrors.Unhandled end @@ -910,7 +907,8 @@ let tclPROGRESS t = tclZERO (CErrors.UserError (Some "Proofview.tclPROGRESS", Pp.str "Failed to progress.")) let _ = CErrors.register_handler begin function - | Logic_monad.Tac_Timeout -> CErrors.user_err ~hdr:"Proofview.tclTIMEOUT" (Pp.str"Tactic timeout!") + | Logic_monad.Tac_Timeout -> + Pp.str "[Proofview.tclTIMEOUT] Tactic timeout!" | _ -> raise CErrors.Unhandled end diff --git a/engine/termops.ml b/engine/termops.ml index a65b8275e6..a5c179bf78 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -1066,19 +1066,9 @@ let global_of_constr sigma c = | Var id -> VarRef id, EConstr.EInstance.empty | _ -> raise Not_found -let is_global sigma c t = - let open GlobRef in - match c, EConstr.kind sigma t with - | ConstRef c, Const (c', _) -> Constant.equal c c' - | IndRef i, Ind (i', _) -> eq_ind i i' - | ConstructRef i, Construct (i', _) -> eq_constructor i i' - | VarRef id, Var id' -> Id.equal id id' - | _ -> false +let is_global = EConstr.isRefX -let isGlobalRef sigma c = - match EConstr.kind sigma c with - | Const _ | Ind _ | Construct _ | Var _ -> true - | _ -> false +let isGlobalRef = EConstr.isRef let is_template_polymorphic_ind env sigma f = match EConstr.kind sigma f with diff --git a/engine/termops.mli b/engine/termops.mli index f970b9ece0..7bbf87239d 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -264,10 +264,13 @@ val dependency_closure : env -> Evd.evar_map -> named_context -> Id.Set.t -> Id. val is_section_variable : Id.t -> bool val global_of_constr : Evd.evar_map -> constr -> GlobRef.t * EInstance.t +[@@ocaml.deprecated "Use [EConstr.destRef] instead (throws DestKO instead of Not_found)."] val is_global : Evd.evar_map -> GlobRef.t -> constr -> bool +[@@ocaml.deprecated "Use [EConstr.isRefX] instead."] val isGlobalRef : Evd.evar_map -> constr -> bool +[@@ocaml.deprecated "Use [EConstr.isRef] instead."] val is_template_polymorphic_ind : env -> Evd.evar_map -> constr -> bool diff --git a/engine/uState.ml b/engine/uState.ml index 3546ece581..2eaa202246 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -53,7 +53,7 @@ let empty = uctx_weak_constraints = UPairSet.empty; } let elaboration_sprop_cumul = - Goptions.declare_bool_option_and_ref ~depr:false ~name:"SProp cumulativity during elaboration" + Goptions.declare_bool_option_and_ref ~depr:false ~key:["Elaboration";"StrictProp";"Cumulativity"] ~value:true let make ~lbound u = diff --git a/engine/univGen.ml b/engine/univGen.ml index 1fe09270ba..b270f9dc0b 100644 --- a/engine/univGen.ml +++ b/engine/univGen.ml @@ -48,8 +48,6 @@ let fresh_instance_from ?loc ctx = function (** Fresh universe polymorphic construction *) -open Globnames - let fresh_global_instance ?loc ?names env gr = let auctx = Environ.universes_of_global env gr in let u, ctx = fresh_instance_from ?loc auctx names in @@ -78,10 +76,6 @@ let constr_of_monomorphic_global gr = Pp.(str "globalization of polymorphic reference " ++ Nametab.pr_global_env Id.Set.empty gr ++ str " would forget universes.") -let fresh_global_or_constr_instance env = function - | IsConstr c -> c, ContextSet.empty - | IsGlobal gr -> fresh_global_instance env gr - let fresh_sort_in_family = function | InSProp -> Sorts.sprop, ContextSet.empty | InProp -> Sorts.prop, ContextSet.empty diff --git a/engine/univGen.mli b/engine/univGen.mli index 1b351c61c4..bbde9d4e30 100644 --- a/engine/univGen.mli +++ b/engine/univGen.mli @@ -46,9 +46,6 @@ val fresh_constructor_instance : env -> constructor -> val fresh_global_instance : ?loc:Loc.t -> ?names:Univ.Instance.t -> env -> GlobRef.t -> constr in_universe_context_set -val fresh_global_or_constr_instance : env -> Globnames.global_reference_or_constr -> - constr in_universe_context_set - (** Get fresh variables for the universe context. Useful to make tactics that manipulate constrs in universe contexts polymorphic. *) val fresh_universe_context_set_instance : ContextSet.t -> diff --git a/engine/univMinim.ml b/engine/univMinim.ml index fc0770cf75..53ff041fa5 100644 --- a/engine/univMinim.ml +++ b/engine/univMinim.ml @@ -15,7 +15,6 @@ open UnivSubst let get_set_minimization = Goptions.declare_bool_option_and_ref ~depr:false - ~name:"minimization to Set" ~key:["Universe";"Minimization";"ToSet"] ~value:true diff --git a/gramlib/grammar.ml b/gramlib/grammar.ml index ff0b90dcff..e1b9c6b7cb 100644 --- a/gramlib/grammar.ml +++ b/gramlib/grammar.ml @@ -831,8 +831,9 @@ let rec print_symbol : type s tr r. formatter -> (s, tr, r) ty_symbol -> unit = fprintf ppf "LIST1 %a SEP %a%s" print_symbol1 s print_symbol1 t (if osep then " OPT_SEP" else "") | Sopt s -> fprintf ppf "OPT %a" print_symbol1 s - | Stoken p when L.tok_pattern_strings p <> ("", None) -> + | Stoken p -> begin match L.tok_pattern_strings p with + | "", Some s -> print_str ppf s | con, Some prm -> fprintf ppf "%s@ %a" con print_str prm | con, None -> fprintf ppf "%s" con end | Snterml (e, l) -> diff --git a/ide/coq_commands.ml b/ide/coq_commands.ml index bfd99e7ce3..5b9ea17ba7 100644 --- a/ide/coq_commands.ml +++ b/ide/coq_commands.ml @@ -228,198 +228,3 @@ let state_preserving = [ "Test Printing Wildcard"; ] - - -let tactics = - [ - [ - "abstract"; - "absurd"; - "apply"; - "apply __ with"; - "assert"; - "assert (__:__)"; - "assert (__:=__)"; - "assumption"; - "auto"; - "auto with"; - "autorewrite"; - ]; - - [ - "case"; - "case __ with"; - "casetype"; - "cbv"; - "cbv in"; - "change"; - "change __ in"; - "clear"; - "clearbody"; - "cofix"; - "compare"; - "compute"; - "compute in"; - "congruence"; - "constructor"; - "constructor __ with"; - "contradiction"; - "cut"; - "cutrewrite"; - ]; - - [ - "decide equality"; - "decompose"; - "decompose record"; - "decompose sum"; - "dependent inversion"; - "dependent inversion __ with"; - "dependent inversion__clear"; - "dependent inversion__clear __ with"; - "dependent rewrite ->"; - "dependent rewrite <-"; - "destruct"; - "discriminate"; - "do"; - "double induction"; - ]; - - [ - "eapply"; - "eauto"; - "eauto with"; - "eexact"; - "elim"; - "elim __ using"; - "elim __ with"; - "elimtype"; - "exact"; - "exists"; - ]; - - [ - "fail"; - "field"; - "first"; - "firstorder"; - "firstorder using"; - "firstorder with"; - "fix"; - "fix __ with"; - "fold"; - "fold __ in"; - "functional induction"; - ]; - - [ - "generalize"; - "generalize dependent"; - ]; - - [ - "hnf"; - ]; - - [ - "idtac"; - "induction"; - "info"; - "injection"; - "instantiate (__:=__)"; - "intro"; - "intro after"; - "intro __ after"; - "intros"; - "intros until"; - "intuition"; - "inversion"; - "inversion __ in"; - "inversion __ using"; - "inversion __ using __ in"; - "inversion__clear"; - "inversion__clear __ in"; - ]; - - [ - "jp <n>"; - "jp"; - ]; - - [ - "lapply"; - "lazy"; - "lazy in"; - "left"; - ]; - - [ - "move __ after"; - ]; - - [ - "omega"; - ]; - - [ - "pattern"; - "pose"; - "pose __:=__)"; - "progress"; - ]; - - [ - "quote"; - ]; - - [ - "red"; - "red in"; - "refine"; - "reflexivity"; - "rename __ into"; - "repeat"; - "replace __ with"; - "rewrite"; - "rewrite __ in"; - "rewrite <-"; - "rewrite <- __ in"; - "right"; - "ring"; - ]; - - [ - "set"; - "set (__:=__)"; - "setoid__replace"; - "setoid__rewrite"; - "simpl"; - "simpl __ in"; - "simple destruct"; - "simple induction"; - "simple inversion"; - "simplify__eq"; - "solve"; - "split"; -(* "split__Rabs"; - "split__Rmult"; -*) - "subst"; - "symmetry"; - "symmetry in"; - ]; - - [ - "tauto"; - "transitivity"; - "trivial"; - "try"; - ]; - - [ - "unfold"; - "unfold __ in"; - ]; -] - - diff --git a/ide/coq_commands.mli b/ide/coq_commands.mli index 5f8ce30901..c8c11f77af 100644 --- a/ide/coq_commands.mli +++ b/ide/coq_commands.mli @@ -8,6 +8,5 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -val tactics : string list list val commands : string list list val state_preserving : string list diff --git a/ide/coqide.ml b/ide/coqide.ml index 918c196968..ccf6d40b2b 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -977,7 +977,6 @@ let build_ui () = let view_menu = GAction.action_group ~name:"View" () in let export_menu = GAction.action_group ~name:"Export" () in let navigation_menu = GAction.action_group ~name:"Navigation" () in - let tactics_menu = GAction.action_group ~name:"Tactics" () in let templates_menu = GAction.action_group ~name:"Templates" () in let tools_menu = GAction.action_group ~name:"Tools" () in let queries_menu = GAction.action_group ~name:"Queries" () in @@ -985,7 +984,7 @@ let build_ui () = let windows_menu = GAction.action_group ~name:"Windows" () in let help_menu = GAction.action_group ~name:"Help" () in let all_menus = [ - file_menu; edit_menu; view_menu; export_menu; navigation_menu; tactics_menu; + file_menu; edit_menu; view_menu; export_menu; navigation_menu; templates_menu; tools_menu; queries_menu; compile_menu; windows_menu; help_menu; ] in @@ -996,8 +995,6 @@ let build_ui () = item "Save" ~callback:(File.save ~parent:w) ~stock:`SAVE ~tooltip:"Save current buffer"; item "Save as" ~label:"S_ave as" ~stock:`SAVE_AS ~callback:(File.saveas ~parent:w); item "Save all" ~label:"Sa_ve all" ~callback:File.saveall; - item "Revert all buffers" ~label:"_Revert all buffers" - ~callback:(File.revert_all ~parent:w) ~stock:`REVERT_TO_SAVED; item "Close buffer" ~label:"_Close buffer" ~stock:`CLOSE ~callback:(File.close_buffer ~parent:w) ~tooltip:"Close current buffer"; item "Print..." ~label:"_Print..." @@ -1121,11 +1118,6 @@ let build_ui () = ("Force", "_Force", `EXECUTE, Nav.join_document, "Fully check the document", "f"); ] end; - menu tactics_menu [ - item "Tactics" ~label:"_Tactics"; - ]; - alpha_items tactics_menu "Tactic" Coq_commands.tactics; - menu templates_menu [ item "Templates" ~label:"Te_mplates"; template_item ("Lemma new_lemma : .\nProof.\n\nQed.\n", 6,9, "J"); @@ -1209,7 +1201,6 @@ let build_ui () = Coqide_ui.ui_m#insert_action_group edit_menu 0; Coqide_ui.ui_m#insert_action_group view_menu 0; Coqide_ui.ui_m#insert_action_group navigation_menu 0; - Coqide_ui.ui_m#insert_action_group tactics_menu 0; Coqide_ui.ui_m#insert_action_group templates_menu 0; Coqide_ui.ui_m#insert_action_group tools_menu 0; Coqide_ui.ui_m#insert_action_group queries_menu 0; @@ -1368,7 +1359,7 @@ let read_coqide_args argv = |"-debug"::args -> Minilib.debug := true; Flags.debug := true; - Backtrace.record_backtrace true; + Exninfo.record_backtrace true; filter_coqtop coqtop project_files bindings_files ("-debug"::out) args |"-coqtop-flags" :: flags :: args-> Coq.ideslave_coqtop_flags := Some flags; diff --git a/ide/coqide_ui.ml b/ide/coqide_ui.ml index f056af6703..f22821c6ea 100644 --- a/ide/coqide_ui.ml +++ b/ide/coqide_ui.ml @@ -36,7 +36,6 @@ let init () = \n <menuitem action='Save' />\ \n <menuitem action='Save as' />\ \n <menuitem action='Save all' />\ -\n <menuitem action='Revert all buffers' />\ \n <menuitem action='Close buffer' />\ \n <menuitem action='Print...' />\ \n <menu action='Export to'>\ @@ -100,9 +99,6 @@ let init () = \n <menuitem action='Previous' />\ \n <menuitem action='Next' />\ \n </menu>\ -\n <menu action='Tactics'>\ -\n %s\ -\n </menu>\ \n <menu action='Templates'>\ \n <menuitem action='Lemma' />\ \n <menuitem action='Theorem' />\ @@ -165,7 +161,6 @@ let init () = \n</toolbar>\ \n</ui>" (if Coq_config.gtk_platform <> `QUARTZ then "<menuitem action='Quit' />" else "") - (Buffer.contents (list_items "Tactic" Coq_commands.tactics)) (Buffer.contents (list_items "Template" Coq_commands.commands)) (Buffer.contents (list_queries "User-Query" Preferences.user_queries#get)) in diff --git a/ide/idetop.ml b/ide/idetop.ml index 7d92cff365..ae2301a0a7 100644 --- a/ide/idetop.ml +++ b/ide/idetop.ml @@ -360,7 +360,6 @@ let import_option_value = function let export_option_state s = { Interface.opt_sync = true; Interface.opt_depr = s.Goptions.opt_depr; - Interface.opt_name = s.Goptions.opt_name; Interface.opt_value = export_option_value s.Goptions.opt_value; } diff --git a/ide/preferences.ml b/ide/preferences.ml index d3cf08e90e..af1759b0bb 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -331,10 +331,6 @@ let modifier_for_navigation = let modifier_for_templates = new preference ~name:["modifier_for_templates"] ~init:"<Control><Shift>" ~repr:Repr.(string) -let modifier_for_tactics = - new preference ~name:["modifier_for_tactics"] - ~init:(select_arch "<Control><Alt>" "<Control><Primary>") ~repr:Repr.(string) - let modifier_for_display = new preference ~name:["modifier_for_display"] ~init:(select_arch "<Alt><Shift>" "<Primary><Shift>")~repr:Repr.(string) @@ -347,7 +343,6 @@ let attach_modifiers_callback () = (* To be done after the preferences are loaded *) let _ = attach_modifiers modifier_for_navigation "<Actions>/Navigation/" in let _ = attach_modifiers modifier_for_templates "<Actions>/Templates/" in - let _ = attach_modifiers modifier_for_tactics "<Actions>/Tactics/" in let _ = attach_modifiers modifier_for_display "<Actions>/View/" in let _ = attach_modifiers modifier_for_queries "<Actions>/Queries/" in () @@ -951,9 +946,6 @@ let configure ?(apply=(fun () -> ())) parent = (string_of_project_behavior read_project#get) in let project_file_name = pstring "Default name for project file" project_file_name in - let modifier_for_tactics = - pmodifiers "Global change of modifiers for Tactics Menu" modifier_for_tactics - in let modifier_for_templates = pmodifiers "Global change of modifiers for Templates Menu" modifier_for_templates in @@ -1056,7 +1048,7 @@ let configure ?(apply=(fun () -> ())) parent = [cmd_coqtop;cmd_coqc;cmd_make;cmd_coqmakefile; cmd_coqdoc; cmd_print;cmd_editor;cmd_browse]); Section("Shortcuts", Some `PREFERENCES, - [modifiers_valid; modifier_for_tactics; + [modifiers_valid; modifier_for_templates; modifier_for_display; modifier_for_navigation; modifier_for_queries (*; user_queries *)]); Section("Misc", Some `ADD, diff --git a/ide/preferences.mli b/ide/preferences.mli index 7b43079b4f..754f15c575 100644 --- a/ide/preferences.mli +++ b/ide/preferences.mli @@ -71,7 +71,6 @@ val automatic_tactics : string list preference val cmd_print : string preference val modifier_for_navigation : string preference val modifier_for_templates : string preference -val modifier_for_tactics : string preference val modifier_for_display : string preference val modifier_for_queries : string preference val modifiers_valid : string preference diff --git a/ide/protocol/interface.ml b/ide/protocol/interface.ml index 362833743e..be5e305ad3 100644 --- a/ide/protocol/interface.ml +++ b/ide/protocol/interface.ml @@ -71,8 +71,6 @@ type option_state = { (** Whether an option is synchronous *) opt_depr : bool; (** Whether an option is deprecated *) - opt_name : string; - (** A short string that is displayed when using [Test] *) opt_value : option_value; (** The current value of the option *) } diff --git a/ide/protocol/xmlprotocol.ml b/ide/protocol/xmlprotocol.ml index cad65cc5d6..a2c80ea118 100644 --- a/ide/protocol/xmlprotocol.ml +++ b/ide/protocol/xmlprotocol.ml @@ -79,13 +79,11 @@ let of_option_state s = Element ("option_state", [], [ of_bool s.opt_sync; of_bool s.opt_depr; - of_string s.opt_name; of_option_value s.opt_value]) let to_option_state = function - | Element ("option_state", [], [sync; depr; name; value]) -> { + | Element ("option_state", [], [sync; depr; value]) -> { opt_sync = to_bool sync; opt_depr = to_bool depr; - opt_name = to_string name; opt_value = to_option_value value } | x -> raise (Marshal_error("option_state",x)) @@ -429,8 +427,8 @@ end = struct | StringOptValue (Some s) -> s | BoolValue b -> if b then "true" else "false" let pr_option_state (s : option_state) = - Printf.sprintf "sync := %b; depr := %b; name := %s; value := %s\n" - s.opt_sync s.opt_depr s.opt_name (pr_option_value s.opt_value) + Printf.sprintf "sync := %b; depr := %b; value := %s\n" + s.opt_sync s.opt_depr (pr_option_value s.opt_value) let pr_list pr l = "["^String.concat ";" (List.map pr l)^"]" let pr_option pr = function None -> "None" | Some x -> "Some("^pr x^")" let pr_coq_object (o : 'a coq_object) = "FIXME" @@ -513,7 +511,7 @@ end = struct "type which contains a flattened n-tuple. We provide one example.\n"); Printf.printf "%s:\n\n%s\n\n" (print_val_t Option_state) (pr_xml (of_option_state { opt_sync = true; opt_depr = false; - opt_name = "name1"; opt_value = IntValue (Some 37) })); + opt_value = IntValue (Some 37) })); end open ReifType diff --git a/interp/constrextern.ml b/interp/constrextern.ml index cc0c1e4602..c198c4eb9b 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -194,7 +194,6 @@ let without_specific_symbols l = let get_record_print = Goptions.declare_bool_option_and_ref ~depr:false - ~name:"record printing" ~key:["Printing";"Records"] ~value:true @@ -281,6 +280,17 @@ let get_extern_reference () = !my_extern_reference let extern_reference ?loc vars l = !my_extern_reference vars l (**********************************************************************) +(* utilities *) + +let rec fill_arg_scopes args subscopes (entry,(_,scopes) as all) = + match args, subscopes with + | [], _ -> [] + | a :: args, scopt :: subscopes -> + (a, (entry, (scopt, scopes))) :: fill_arg_scopes args subscopes all + | a :: args, [] -> + (a, (entry, (None, scopes))) :: fill_arg_scopes args [] all + +(**********************************************************************) (* mapping patterns to cases_pattern_expr *) let add_patt_for_params ind l = @@ -550,14 +560,14 @@ let is_gvar id c = match DAst.get c with | GVar id' -> Id.equal id id' | _ -> false -let is_projection nargs = function - | Some r when not !Flags.in_debugger && not !Flags.raw_print && !print_projections -> - (try - let n = Recordops.find_projection_nparams r + 1 in - if n <= nargs then Some n - else None - with Not_found -> None) - | _ -> None +let is_projection nargs r = + if not !Flags.in_debugger && not !Flags.raw_print && !print_projections then + try + let n = Recordops.find_projection_nparams r + 1 in + if n <= nargs then Some n + else None + with Not_found -> None + else None let is_hole = function CHole _ | CEvar _ -> true | _ -> false @@ -569,11 +579,12 @@ let is_needed_for_correct_partial_application tail imp = exception Expl -(* Implicit args indexes are in ascending order *) -(* inctx is useful only if there is a last argument to be deduced from ctxt *) -let explicitize inctx impl (cf,f) args = - let impl = if !Constrintern.parsing_explicit then [] else impl in - let n = List.length args in +(* Take a list of arguments starting at position [q] and their implicit status *) +(* Decide for each implicit argument if it skipped or made explicit *) +(* If the removal of implicit arguments is not possible, raise [Expl] *) +(* [inctx] tells if the term is in a context which will enforce the external type *) +(* [n] is the total number of arguments block to which the [args] belong *) +let adjust_implicit_arguments inctx n q args impl = let rec exprec q = function | a::args, imp::impl when is_status_implicit imp -> let tail = exprec (q+1) (args,impl) in @@ -595,10 +606,11 @@ let explicitize inctx impl (cf,f) args = (* The non-explicit application cannot be parsed back with the same type *) raise Expl | [], _ -> [] - in + in exprec q (args,impl) + +let extern_projection (cf,f) args impl = let ip = is_projection (List.length args) cf in - let expl () = - match ip with + match ip with | Some i -> (* Careful: It is possible to have declared implicits ending before the principal argument *) @@ -607,33 +619,61 @@ let explicitize inctx impl (cf,f) args = with Failure _ -> false in if is_impl - then raise Expl + then None else let (args1,args2) = List.chop i args in let (impl1,impl2) = try List.chop i impl with Failure _ -> impl, [] in - let args1 = exprec 1 (args1,impl1) in - let args2 = exprec (i+1) (args2,impl2) in - let ip = Some (List.length args1) in - CApp ((ip,f),args1@args2) - | None -> - let args = exprec 1 (args,impl) in - if List.is_empty args then f.CAst.v else - match f.CAst.v with - | CApp (g,args') -> - (* may happen with notations for a prefix of an n-ary - application *) - CApp (g,args'@args) - | _ -> CApp ((None, f), args) in - try expl () - with Expl -> - let f',us = match f with { CAst.v = CRef (f,us) } -> f,us | _ -> assert false in - let ip = if !print_projections then ip else None in - CAppExpl ((ip, f', us), List.map Lazy.force args) + Some (i,(args1,impl1),(args2,impl2)) + | None -> None let is_start_implicit = function | imp :: _ -> is_status_implicit imp && maximal_insertion_of imp | [] -> false +let extern_record ref args = + try + if !Flags.raw_print then raise Exit; + let cstrsp = match ref with GlobRef.ConstructRef c -> c | _ -> raise Not_found in + let struc = Recordops.lookup_structure (fst cstrsp) in + if PrintingRecord.active (fst cstrsp) then + () + else if PrintingConstructor.active (fst cstrsp) then + raise Exit + else if not (get_record_print ()) then + raise Exit; + let projs = struc.Recordops.s_PROJ in + let locals = struc.Recordops.s_PROJKIND in + let rec cut args n = + if Int.equal n 0 then args + else + match args with + | [] -> raise No_match + | _ :: t -> cut t (n - 1) in + let args = cut args struc.Recordops.s_EXPECTEDPARAM in + let rec ip projs locs args acc = + match projs with + | [] -> acc + | None :: q -> raise No_match + | Some c :: q -> + match locs with + | [] -> anomaly (Pp.str "projections corruption [Constrextern.extern].") + | { Recordops.pk_true_proj = false } :: locs' -> + (* we don't want to print locals *) + ip q locs' args acc + | { Recordops.pk_true_proj = true } :: locs' -> + match args with + | [] -> raise No_match + (* we give up since the constructor is not complete *) + | arg :: tail -> + let arg = Lazy.force arg in + let loc = arg.CAst.loc in + let ref = extern_reference ?loc Id.Set.empty (GlobRef.ConstRef c) in + ip q locs' tail ((ref, arg) :: acc) + in + Some (List.rev (ip projs locals args [])) + with + | Not_found | No_match | Exit -> None + let extern_global impl f us = if not !Constrintern.parsing_explicit && is_start_implicit impl then @@ -641,26 +681,63 @@ let extern_global impl f us = else CRef (f,us) -let extern_app inctx impl (cf,f) us args = - if List.is_empty args then - (* If coming from a notation "Notation a := @b" *) - CAppExpl ((None, f, us), []) - else if not !Constrintern.parsing_explicit && - ((!Flags.raw_print || - (!print_implicits && not !print_implicits_explicit_args)) && - List.exists is_status_implicit impl) - then +(* Implicit args indexes are in ascending order *) +(* inctx is useful only if there is a last argument to be deduced from ctxt *) +let extern_applied_ref inctx impl (cf,f) us args = + let isproj = is_projection (List.length args) cf in + try + if not !Constrintern.parsing_explicit && + ((!Flags.raw_print || + (!print_implicits && not !print_implicits_explicit_args)) && + List.exists is_status_implicit impl) + then raise Expl; + let impl = if !Constrintern.parsing_explicit then [] else impl in + let n = List.length args in + let ref = CRef (f,us) in + let f = CAst.make ref in + match extern_projection (cf,f) args impl with + (* Try a [t.(f args1) args2] projection-style notation *) + | Some (i,(args1,impl1),(args2,impl2)) -> + let args1 = adjust_implicit_arguments inctx n 1 args1 impl1 in + let args2 = adjust_implicit_arguments inctx n (i+1) args2 impl2 in + let ip = Some (List.length args1) in + CApp ((ip,f),args1@args2) + (* A normal application node with each individual implicit + arguments either dropped or made explicit *) + | None -> + let args = adjust_implicit_arguments inctx n 1 args impl in + if args = [] then ref else CApp ((None, f), args) + with Expl -> + (* A [@f args] node *) let args = List.map Lazy.force args in - CAppExpl ((is_projection (List.length args) cf,f,us), args) - else - explicitize inctx impl (cf, CAst.make @@ CRef (f,us)) args + let isproj = if !print_projections then isproj else None in + CAppExpl ((isproj,f,us), args) -let rec fill_arg_scopes args subscopes (entry,(_,scopes) as all) = match args, subscopes with -| [], _ -> [] -| a :: args, scopt :: subscopes -> - (a, (entry, (scopt, scopes))) :: fill_arg_scopes args subscopes all -| a :: args, [] -> - (a, (entry, (None, scopes))) :: fill_arg_scopes args [] all +let extern_applied_syntactic_definition n extraimpl (cf,f) syndefargs extraargs = + try + let syndefargs = List.map (fun a -> (a,None)) syndefargs in + let extraargs = adjust_implicit_arguments false (List.length extraargs) 1 extraargs extraimpl in + let args = syndefargs @ extraargs in + if args = [] then cf else CApp ((None, CAst.make cf), args) + with Expl -> + let args = syndefargs @ List.map Lazy.force extraargs in + CAppExpl ((None,f,None), args) + +let mkFlattenedCApp (head,args) = + match head.CAst.v with + | CApp (g,args') -> + (* may happen with notations for a prefix of an n-ary application *) + (* or after removal of a coercion to funclass *) + CApp (g,args'@args) + | _ -> + CApp ((None, head), args) + +let extern_applied_notation n impl f args = + if List.is_empty args then + f.CAst.v + else + let args = adjust_implicit_arguments false (List.length args) 1 args impl in + mkFlattenedCApp (f,args) let extern_args extern env args = let map (arg, argscopes) = lazy (extern argscopes env arg) in @@ -838,56 +915,19 @@ let rec extern inctx scopes vars r = | GRef (ref,us) -> let subscopes = find_arguments_scope ref in let args = fill_arg_scopes args subscopes scopes in - begin - try - if !Flags.raw_print then raise Exit; - let cstrsp = match ref with GlobRef.ConstructRef c -> c | _ -> raise Not_found in - let struc = Recordops.lookup_structure (fst cstrsp) in - if PrintingRecord.active (fst cstrsp) then - () - else if PrintingConstructor.active (fst cstrsp) then - raise Exit - else if not (get_record_print ()) then - raise Exit; - let projs = struc.Recordops.s_PROJ in - let locals = struc.Recordops.s_PROJKIND in - let rec cut args n = - if Int.equal n 0 then args - else - match args with - | [] -> raise No_match - | _ :: t -> cut t (n - 1) in - let args = cut args struc.Recordops.s_EXPECTEDPARAM in - let rec ip projs locs args acc = - match projs with - | [] -> acc - | None :: q -> raise No_match - | Some c :: q -> - match locs with - | [] -> anomaly (Pp.str "projections corruption [Constrextern.extern].") - | { Recordops.pk_true_proj = false } :: locs' -> - (* we don't want to print locals *) - ip q locs' args acc - | { Recordops.pk_true_proj = true } :: locs' -> - match args with - | [] -> raise No_match - (* we give up since the constructor is not complete *) - | (arg, scopes) :: tail -> - let head = extern true scopes vars arg in - ip q locs' tail ((extern_reference ?loc Id.Set.empty (GlobRef.ConstRef c), head) :: acc) - in - CRecord (List.rev (ip projs locals args [])) - with - | Not_found | No_match | Exit -> - let args = extern_args (extern true) vars args in - extern_app inctx - (select_stronger_impargs (implicits_of_global ref)) - (Some ref,extern_reference ?loc vars ref) (extern_universes us) args - end - - | _ -> - explicitize inctx [] (None,sub_extern false scopes vars f) - (List.map (fun c -> lazy (sub_extern true scopes vars c)) args)) + let args = extern_args (extern true) vars args in + (* Try a "{|...|}" record notation *) + (match extern_record ref args with + | Some l -> CRecord l + | None -> + (* Otherwise... *) + extern_applied_ref inctx + (select_stronger_impargs (implicits_of_global ref)) + (ref,extern_reference ?loc vars ref) (extern_universes us) args) + | _ -> + let args = List.map (fun c -> (sub_extern true scopes vars c,None)) args in + let head = sub_extern false scopes vars f in + mkFlattenedCApp (head,args)) | GLetIn (na,b,t,c) -> CLetIn (make ?loc na,sub_extern false scopes vars b, @@ -1104,46 +1144,45 @@ and extern_notation (custom,scopes as allscopes) vars t rules = let loc = Glob_ops.loc_of_glob_constr t in try if is_inactive_rule keyrule then raise No_match; - (* Adjusts to the number of arguments expected by the notation *) - let (t,args,argsscopes,argsimpls) = match DAst.get t ,n with - | GApp (f,args), Some n - when List.length args >= n -> + let f,args = + match DAst.get t with + | GApp (f,args) -> f,args + | _ -> t,[] in + let nallargs = List.length args in + let argsscopes,argsimpls = + match DAst.get f with + | GRef (ref,_) -> + let subscopes = find_arguments_scope ref in + let impls = select_impargs_size nallargs (implicits_of_global ref) in + subscopes, impls + | _ -> + [], [] in + (* Adjust to the number of arguments expected by the notation *) + let (t,args,argsscopes,argsimpls) = match n with + | Some n when nallargs >= n && nallargs > 0 -> let args1, args2 = List.chop n args in - let subscopes, impls = - match DAst.get f with - | GRef (ref,us) -> - let subscopes = - try List.skipn n (find_arguments_scope ref) - with Failure _ -> [] in - let impls = - let impls = - select_impargs_size - (List.length args) (implicits_of_global ref) in - try List.skipn n impls with Failure _ -> [] in - subscopes,impls - | _ -> - [], [] in + let args2scopes = try List.skipn n argsscopes with Failure _ -> [] in + let args2impls = try List.skipn n argsimpls with Failure _ -> [] in + (* Note: NApp(NRef f,[]), hence n=0, encodes @f *) (if Int.equal n 0 then f else DAst.make @@ GApp (f,args1)), - args2, subscopes, impls - | GApp (f, args), None -> + args2, args2scopes, args2impls + | None when nallargs > 0 -> begin match DAst.get f with - | GRef (ref,us) -> - let subscopes = find_arguments_scope ref in - let impls = - select_impargs_size - (List.length args) (implicits_of_global ref) in - f, args, subscopes, impls + | GRef (ref,us) -> f, args, argsscopes, argsimpls | _ -> t, [], [], [] end - | GRef (ref,us), Some 0 -> DAst.make @@ GApp (t,[]), [], [], [] - | _, None -> t, [], [], [] + | Some 0 when nallargs = 0 -> + begin match DAst.get f with + | GRef (ref,us) -> DAst.make @@ GApp (t,[]), [], [], [] + | _ -> t, [], [], [] + end + | None -> t, [], [], [] | _ -> raise No_match in (* Try matching ... *) let terms,termlists,binders,binderlists = match_notation_constr !print_universes t pat in (* Try availability of interpretation ... *) - let e = - match keyrule with + match keyrule with | NotationRule (sc,ntn) -> (match availability_of_entry_coercion custom (fst ntn) with | None -> raise No_match @@ -1171,22 +1210,25 @@ and extern_notation (custom,scopes as allscopes) vars t rules = List.map (fun (bl,(subentry,(scopt,scl))) -> pi3 (extern_local_binder (subentry,(scopt,scl@scopes')) vars bl)) binderlists in - insert_coercion coercion (insert_delimiters (make_notation loc ntn (l,ll,bl,bll)) key)) + let c = make_notation loc ntn (l,ll,bl,bll) in + let c = insert_coercion coercion (insert_delimiters c key) in + let args = fill_arg_scopes args argsscopes allscopes in + let args = extern_args (extern true) vars args in + CAst.make ?loc @@ extern_applied_notation nallargs argsimpls c args) | SynDefRule kn -> match availability_of_entry_coercion custom InConstrEntrySomeLevel with | None -> raise No_match | Some coercion -> let l = List.map (fun (c,(subentry,(scopt,scl))) -> - extern true (subentry,(scopt,scl@snd scopes)) vars c, None) + extern true (subentry,(scopt,scl@snd scopes)) vars c) terms in - let a = CRef (Nametab.shortest_qualid_of_syndef ?loc vars kn,None) in - insert_coercion coercion (CAst.make ?loc @@ if List.is_empty l then a else CApp ((None, CAst.make a),l)) in - if List.is_empty args then e - else - let args = fill_arg_scopes args argsscopes allscopes in - let args = extern_args (extern true) vars args in - CAst.make ?loc @@ explicitize false argsimpls (None,e) args + let cf = Nametab.shortest_qualid_of_syndef ?loc vars kn in + let a = CRef (cf,None) in + let args = fill_arg_scopes args argsscopes allscopes in + let args = extern_args (extern true) vars args in + let c = CAst.make ?loc @@ extern_applied_syntactic_definition nallargs argsimpls (a,cf) l args in + insert_coercion coercion c with No_match -> extern_notation allscopes vars t rules diff --git a/interp/constrintern.ml b/interp/constrintern.ml index c699f79351..b2c572d290 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -257,7 +257,7 @@ type intern_env = { tmp_scope: Notation_term.tmp_scope_name option; scopes: Notation_term.scope_name list; impls: internalization_env; - impl_binder_index: int option; + binder_block_names: (abstraction_kind option (* None = unknown *) * Id.Set.t) option; } (**********************************************************************) @@ -330,15 +330,18 @@ let exists_name na l = | _ -> false let build_impls ?loc n bk na acc = - match bk with - | Implicit -> + let impl_status max = let na = - if exists_name na acc then begin warn_shadowed_implicit_name ?loc na; Anonymous end - else na in + if exists_name na acc then begin warn_shadowed_implicit_name ?loc na; Anonymous end + else na in let impl = match na with - | Name id -> Some (ExplByName id,Manual,(true,true)) - | Anonymous -> Some (ExplByPos (n,None),Manual,(true,true)) in - impl :: acc + | Name id -> Some (ExplByName id,Manual,(max,true)) + | Anonymous -> Some (ExplByPos (n,None),Manual,(max,true)) in + impl + in + match bk with + | NonMaxImplicit -> impl_status false :: acc + | MaxImplicit -> impl_status true :: acc | Explicit -> None :: acc let impls_binder_list = @@ -373,6 +376,49 @@ let rec check_capture ty = let open CAst in function | [] -> () +(** Status of the internalizer wrt "Arguments" of names *) + +let restart_no_binders env = + { env with binder_block_names = None} + (* Not in relation with the "Arguments" of a name *) + +let restart_prod_binders env = + { env with binder_block_names = Some (Some AbsPi, Id.Set.empty) } + (* In a position binding a type to a name *) + +let restart_lambda_binders env = + { env with binder_block_names = Some (Some AbsLambda, Id.Set.empty) } + (* In a position binding a body to a name *) + +let switch_prod_binders env = + match env.binder_block_names with + | Some (o,ids) when o <> Some AbsLambda -> restart_prod_binders env + | _ -> restart_no_binders env + (* In a position switching to a type *) + +let switch_lambda_binders env = + match env.binder_block_names with + | Some (o,ids) when o <> Some AbsPi -> restart_lambda_binders env + | _ -> restart_no_binders env + (* In a position switching to a term *) + +let slide_binders env = + match env.binder_block_names with + | Some (o,ids) when o <> Some AbsPi -> restart_prod_binders env + | _ -> restart_no_binders env + (* In a position of cast *) + +let binder_status_fun = { + no = (fun x -> x); + restart_prod = on_snd restart_prod_binders; + restart_lambda = on_snd restart_lambda_binders; + switch_prod = on_snd switch_prod_binders; + switch_lambda = on_snd switch_lambda_binders; + slide = on_snd slide_binders; +} + +(**) + let locate_if_hole ?loc na c = match DAst.get c with | GHole (_,naming,arg) -> (try match na with @@ -397,7 +443,11 @@ let check_hidden_implicit_parameters ?loc id impls = strbrk "the type of a constructor shall use a different name.") let pure_push_name_env (id,implargs) env = - {env with ids = Id.Set.add id env.ids; impls = Id.Map.add id implargs env.impls} + {env with + ids = Id.Set.add id env.ids; + impls = Id.Map.add id implargs env.impls; + binder_block_names = Option.map (fun (b,ids) -> (b,Id.Set.add id ids)) env.binder_block_names; + } let push_name_env ntnvars implargs env = let open CAst in @@ -421,13 +471,15 @@ let remember_binders_impargs env bl = let restore_binders_impargs env l = List.fold_right pure_push_name_env l env -let warn_unexpected_implicit_binder_declaration = +let warn_ignoring_unexpected_implicit_binder_declaration = CWarnings.create ~name:"unexpected-implicit-declaration" ~category:"syntax" - Pp.(fun () -> str "Unexpected implicit binder declaration.") + Pp.(fun () -> str "Ignoring implicit binder declaration in unexpected position.") let check_implicit_meaningful ?loc k env = - if k = Implicit && env.impl_binder_index = None then - warn_unexpected_implicit_binder_declaration ?loc () + if k <> Explicit && env.binder_block_names = None then + (warn_ignoring_unexpected_implicit_binder_declaration ?loc (); Explicit) + else + k let intern_generalized_binder intern_type ntnvars env {loc;v=na} b' t ty = @@ -441,10 +493,10 @@ let intern_generalized_binder intern_type ntnvars let env' = List.fold_left (fun env {loc;v=x} -> push_name_env ntnvars (Variable,[],[],[])(*?*) env (make ?loc @@ Name x)) env fvs in - check_implicit_meaningful ?loc b' env; + let b' = check_implicit_meaningful ?loc b' env in let bl = List.map CAst.(map (fun id -> - (Name id, Implicit, DAst.make ?loc @@ GHole (Evar_kinds.BinderType (Name id), IntroAnonymous, None)))) + (Name id, MaxImplicit, DAst.make ?loc @@ GHole (Evar_kinds.BinderType (Name id), IntroAnonymous, None)))) fvs in let na = match na with @@ -463,7 +515,7 @@ let intern_generalized_binder intern_type ntnvars (make ?loc (na,b',ty')) :: List.rev bl) let intern_assumption intern ntnvars env nal bk ty = - let intern_type env = intern (set_type_scope env) in + let intern_type env = intern (restart_prod_binders (set_type_scope env)) in match bk with | Default k -> let ty = intern_type env ty in @@ -471,7 +523,7 @@ let intern_assumption intern ntnvars env nal bk ty = let impls = impls_type_list 1 ty in List.fold_left (fun (env, bl) ({loc;v=na} as locna) -> - check_implicit_meaningful ?loc k env; + let k = check_implicit_meaningful ?loc k env in (push_name_env ntnvars impls env locna, (make ?loc (na,k,locate_if_hole ?loc na ty))::bl)) (env, []) nal @@ -492,8 +544,8 @@ let glob_local_binder_of_extended = DAst.with_loc_val (fun ?loc -> function let intern_cases_pattern_fwd = ref (fun _ -> failwith "intern_cases_pattern_fwd") let intern_letin_binder intern ntnvars env (({loc;v=na} as locna),def,ty) = - let term = intern env def in - let ty = Option.map (intern env) ty in + let term = intern (reset_tmp_scope (restart_lambda_binders env)) def in + let ty = Option.map (intern (set_type_scope (restart_prod_binders env))) ty in let impls = impls_term_list 1 term in (push_name_env ntnvars impls env locna, (na,Explicit,term,ty)) @@ -713,6 +765,19 @@ let flatten_binders bl = | a -> [a] in List.flatten (List.map dispatch bl) +let rec adjust_env env = function + (* We need to adjust scopes, binder blocks ... to the env expected + at the recursive occurrence; We do an underapproximation... *) + | NProd (_,_,c) -> adjust_env (switch_prod_binders env) c + | NLambda (_,_,c) -> adjust_env (switch_lambda_binders env) c + | NLetIn (_,_,_,c) -> adjust_env env c + | NVar id when Id.equal id ldots_var -> env + | NCast (c,_) -> adjust_env env c + | NApp _ -> restart_no_binders env + | NVar _ | NRef _ | NHole _ | NCases _ | NLetTuple _ | NIf _ + | NRec _ | NSort _ | NInt _ | NFloat _ + | NList _ | NBinderList _ -> env (* to be safe, but restart should be ok *) + let instantiate_notation_constr loc intern intern_pat ntnvars subst infos c = let (terms,termlists,binders,binderlists) = subst in (* when called while defining a notation, avoid capturing the private binders @@ -725,7 +790,7 @@ let instantiate_notation_constr loc intern intern_pat ntnvars subst infos c = let rec aux_letin env = function | [],terminator,_ -> aux (terms,None,None) (renaming,env) terminator | AddPreBinderIter (y,binder)::rest,terminator,iter -> - let env,binders = intern_local_binder_aux intern ntnvars (env,[]) binder in + let env,binders = intern_local_binder_aux intern ntnvars (adjust_env env iter,[]) binder in let binder,extra = flatten_generalized_binders_if_any y binders in aux (terms,Some (y,binder),Some (extra@rest,terminator,iter)) (renaming,env) iter | AddBinderIter (y,binder)::rest,terminator,iter -> @@ -733,7 +798,7 @@ let instantiate_notation_constr loc intern intern_pat ntnvars subst infos c = | AddTermIter nterms::rest,terminator,iter -> aux (nterms,None,Some (rest,terminator,iter)) (renaming,env) iter | AddLetIn (na,c,t)::rest,terminator,iter -> - let env,(na,_,c,t) = intern_letin_binder intern ntnvars env (na,c,t) in + let env,(na,_,c,t) = intern_letin_binder intern ntnvars (adjust_env env iter) (na,c,t) in DAst.make ?loc (GLetIn (na,c,t,aux_letin env (rest,terminator,iter))) in aux_letin env (Option.get iteropt) | NVar id -> subst_var subst' (renaming, env) id @@ -823,7 +888,7 @@ let instantiate_notation_constr loc intern intern_pat ntnvars subst infos c = DAst.make ?loc @@ GLambda (na,Explicit,ty,Option.fold_right apply_cases_pattern disjpat (aux subst' subinfos c')) | t -> glob_constr_of_notation_constr_with_binders ?loc - (traverse_binder intern_pat ntnvars subst avoid) (aux subst') subinfos t + (traverse_binder intern_pat ntnvars subst avoid) (aux subst') ~h:binder_status_fun subinfos t and subst_var (terms, binderopt, _terminopt) (renaming, env) id = (* subst remembers the delimiters stack in the interpretation *) (* of the notations *) @@ -1144,7 +1209,7 @@ let interp_reference vars r = intern_applied_reference ~isproj:None (fun _ -> error_not_enough_arguments ?loc:None) {ids = Id.Set.empty; unb = false ; tmp_scope = None; scopes = []; impls = empty_internalization_env; - impl_binder_index = None} + binder_block_names = None} Environ.empty_named_context_val (vars, Id.Map.empty) None [] r in r @@ -1550,7 +1615,6 @@ let is_non_zero_pat c = match c with let get_asymmetric_patterns = Goptions.declare_bool_option_and_ref ~depr:false - ~name:"no parameters in constructors" ~key:["Asymmetric";"Patterns"] ~value:false @@ -1643,7 +1707,7 @@ let drop_notations_pattern looked_for genv = | Some (a,b,c) -> DAst.make ?loc @@ RCPatCstr(a, b, c) | None -> raise (InternalizationError (loc,NotAConstructor head)) end - | CPatCstr (qid, Some expl_pl, pl) -> + | CPatCstr (qid, Some expl_pl, pl) -> let g = try Nametab.locate qid with Not_found -> raise (InternalizationError (loc,NotAConstructor qid)) in @@ -1892,6 +1956,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = with Not_found -> raise (InternalizationError (locid,UnboundFixName (false,iddef))) in + let env = restart_lambda_binders env in let idl_temp = Array.map (fun (id,recarg,bl,ty,_) -> let recarg = Option.map (function { CAst.v = v } -> match v with @@ -1934,6 +1999,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = with Not_found -> raise (InternalizationError (locid,UnboundFixName (true,iddef))) in + let env = restart_lambda_binders env in let idl_tmp = Array.map (fun ({ CAst.loc; v = id },bl,ty,_) -> let (env',rbl) = List.fold_left intern_local_binder (env,[]) bl in @@ -1957,18 +2023,18 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = Array.map (fun (_,_,bd) -> bd) idl) | CProdN ([],c2) -> anomaly (Pp.str "The AST is malformed, found prod without binders.") | CProdN (bl,c2) -> - let (env',bl) = List.fold_left intern_local_binder (env,[]) bl in + let (env',bl) = List.fold_left intern_local_binder (switch_prod_binders env,[]) bl in expand_binders ?loc mkGProd bl (intern_type env' c2) | CLambdaN ([],c2) -> anomaly (Pp.str "The AST is malformed, found lambda without binders.") | CLambdaN (bl,c2) -> - let (env',bl) = List.fold_left intern_local_binder (reset_tmp_scope env,[]) bl in + let (env',bl) = List.fold_left intern_local_binder (reset_tmp_scope (switch_lambda_binders env),[]) bl in expand_binders ?loc mkGLambda bl (intern env' c2) | CLetIn (na,c1,t,c2) -> - let inc1 = intern_restart_implicit (reset_tmp_scope env) c1 in - let int = Option.map (intern_type_restart_implicit env) t in + let inc1 = intern_restart_binders (reset_tmp_scope env) c1 in + let int = Option.map (intern_type_restart_binders env) t in DAst.make ?loc @@ GLetIn (na.CAst.v, inc1, int, - intern_restart_implicit (push_name_env ntnvars (impls_term_list 1 inc1) env na) c2) + intern_restart_binders (push_name_env ntnvars (impls_term_list 1 inc1) env na) c2) | CNotation ((InConstrEntrySomeLevel,"- _"), ([a],[],[],[])) when is_non_zero a -> let p = match a.CAst.v with CPrim (Numeral (_, p)) -> p | _ -> assert false in intern env (CAst.make ?loc @@ CPrim (Numeral (SMinus,p))) @@ -2009,7 +2075,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let c = intern_notation intern env ntnvars loc ntn ([],[],[],[]) in let x, impl, scopes, l = find_appl_head_data c in (x,impl,scopes,l), args - | _ -> assert (Option.is_empty isproj); (intern env f,[],[],[]), args in + | _ -> assert (Option.is_empty isproj); (intern_no_implicit env f,[],[],[]), args in apply_impargs c env impargs args_scopes (merge_impargs l args) loc @@ -2053,7 +2119,8 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = tms ([],Id.Set.empty,Id.Map.empty,[]) in let env' = Id.Set.fold (fun var bli -> push_name_env ntnvars (Variable,[],[],[]) bli (CAst.make @@ Name var)) - (Id.Set.union ex_ids as_in_vars) (reset_hidden_inductive_implicit_test env) in + (Id.Set.union ex_ids as_in_vars) + (reset_hidden_inductive_implicit_test (restart_lambda_binders env)) in (* PatVars before a real pattern do not need to be matched *) let stripped_match_from_in = let rec aux = function @@ -2063,7 +2130,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = in aux match_from_in in let rtnpo = Option.map (replace_vars_constr_expr aliases) rtnpo in let rtnpo = match stripped_match_from_in with - | [] -> Option.map (intern_type env') rtnpo (* Only PatVar in "in" clauses *) + | [] -> Option.map (intern_type (slide_binders env')) rtnpo (* Only PatVar in "in" clauses *) | l -> (* Build a return predicate by expansion of the patterns of the "in" clause *) let thevars, thepats = List.split l in @@ -2071,7 +2138,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let sub_tms = List.map (fun id -> (DAst.make @@ GVar id),(Name id,None)) thevars (* "match v1,..,vn" *) in let main_sub_eqn = CAst.make @@ ([],thepats, (* "|p1,..,pn" *) - Option.cata (intern_type env') + Option.cata (intern_type_no_implicit env') (DAst.make ?loc @@ GHole(Evar_kinds.CasesType false,IntroAnonymous,None)) rtnpo) (* "=> P" if there were a return predicate P, and "=> _" otherwise *) in let catch_all_sub_eqn = @@ -2090,7 +2157,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let p' = Option.map (fun u -> let env'' = push_name_env ntnvars (Variable,[],[],[]) (reset_hidden_inductive_implicit_test env') (CAst.make na') in - intern_type env'' u) po in + intern_type (slide_binders env'') u) po in DAst.make ?loc @@ GLetTuple (List.map (fun { CAst.v } -> v) nal, (na', p'), b', intern (List.fold_left (push_name_env ntnvars (Variable,[],[],[])) (reset_hidden_inductive_implicit_test env) nal) c) @@ -2100,7 +2167,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let p' = Option.map (fun p -> let env'' = push_name_env ntnvars (Variable,[],[],[]) (reset_hidden_inductive_implicit_test env) (CAst.make na') in - intern_type env'' p) po in + intern_type (slide_binders env'') p) po in DAst.make ?loc @@ GIf (c', (na', p'), intern env b1, intern env b2) | CHole (k, naming, solve) -> @@ -2160,18 +2227,20 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = GSort s | CCast (c1, c2) -> DAst.make ?loc @@ - GCast (intern env c1, map_cast_type (intern_type env) c2) + GCast (intern env c1, map_cast_type (intern_type (slide_binders env)) c2) ) and intern_type env = intern (set_type_scope env) - and intern_no_implicit env = intern {env with impl_binder_index = None} + and intern_type_no_implicit env = intern (restart_no_binders (set_type_scope env)) - and intern_restart_implicit env = intern {env with impl_binder_index = Some 0} + and intern_no_implicit env = intern (restart_no_binders env) - and intern_type_restart_implicit env = intern {(set_type_scope env) with impl_binder_index = Some 0} + and intern_restart_binders env = intern (restart_lambda_binders env) + + and intern_type_restart_binders env = intern (restart_prod_binders (set_type_scope env)) and intern_local_binder env bind : intern_env * Glob_term.extended_glob_local_binder list = - intern_local_binder_aux intern_restart_implicit ntnvars env bind + intern_local_binder_aux intern ntnvars env bind (* Expands a multiple pattern into a disjunction of multiple patterns *) and intern_multiple_pattern env n pl = @@ -2198,7 +2267,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let env_ids = List.fold_right Id.Set.add eqn_ids env.ids in List.map (fun (asubst,pl) -> let rhs = replace_vars_constr_expr asubst rhs in - let rhs' = intern {env with ids = env_ids} rhs in + let rhs' = intern_no_implicit {env with ids = env_ids} rhs in CAst.make ?loc (eqn_ids,pl,rhs')) pll and intern_case_item env forbidden_names_for_gen (tm,na,t) = @@ -2336,7 +2405,12 @@ let extract_ids env = let scope_of_type_kind sigma = function | IsType -> Notation.current_type_scope_name () | OfType typ -> compute_type_scope sigma typ - | WithoutTypeConstraint -> None + | WithoutTypeConstraint | UnknownIfTermOrType -> None + +let allowed_binder_kind_of_type_kind = function + | IsType -> Some AbsPi + | OfType _ | WithoutTypeConstraint -> Some AbsLambda + | UnknownIfTermOrType -> None let empty_ltac_sign = { ltac_vars = Id.Set.empty; @@ -2348,9 +2422,10 @@ let intern_gen kind env sigma ?(impls=empty_internalization_env) ?(pattern_mode=false) ?(ltacvars=empty_ltac_sign) c = let tmp_scope = scope_of_type_kind sigma kind in + let k = allowed_binder_kind_of_type_kind kind in internalize env {ids = extract_ids env; unb = false; tmp_scope = tmp_scope; scopes = []; - impls; impl_binder_index = Some 0} + impls; binder_block_names = Some (k,Id.Map.domain impls)} pattern_mode (ltacvars, Id.Map.empty) c let intern_constr env sigma c = intern_gen WithoutTypeConstraint env sigma c @@ -2372,8 +2447,8 @@ let interp_gen kind env sigma ?(impls=empty_internalization_env) c = let c = intern_gen kind ~impls env sigma c in understand ~expected_type:kind env sigma c -let interp_constr env sigma ?(impls=empty_internalization_env) c = - interp_gen WithoutTypeConstraint env sigma c +let interp_constr ?(expected_type=WithoutTypeConstraint) env sigma ?(impls=empty_internalization_env) c = + interp_gen expected_type env sigma c let interp_type env sigma ?(impls=empty_internalization_env) c = interp_gen IsType env sigma ~impls c @@ -2383,8 +2458,8 @@ let interp_casted_constr env sigma ?(impls=empty_internalization_env) c typ = (* Not all evars expected to be resolved *) -let interp_open_constr env sigma c = - understand_tcc env sigma (intern_constr env sigma c) +let interp_open_constr ?(expected_type=WithoutTypeConstraint) env sigma c = + understand_tcc env sigma (intern_gen expected_type env sigma c) (* Not all evars expected to be resolved and computation of implicit args *) @@ -2432,8 +2507,10 @@ let intern_core kind env sigma ?(pattern_mode=false) ?(ltacvars=empty_ltac_sign) { Genintern.intern_ids = ids; Genintern.notation_variable_status = vl } c = let tmp_scope = scope_of_type_kind sigma kind in let impls = empty_internalization_env in + let k = allowed_binder_kind_of_type_kind kind in internalize env - {ids; unb = false; tmp_scope; scopes = []; impls; impl_binder_index = Some 0} + {ids; unb = false; tmp_scope; scopes = []; impls; + binder_block_names = Some (k,Id.Set.empty)} pattern_mode (ltacvars, vl) c let interp_notation_constr env ?(impls=empty_internalization_env) nenv a = @@ -2442,7 +2519,7 @@ let interp_notation_constr env ?(impls=empty_internalization_env) nenv a = let vl = Id.Map.map (fun typ -> (ref false, ref None, typ)) nenv.ninterp_var_type in let impls = Id.Map.fold (fun id _ impls -> Id.Map.remove id impls) nenv.ninterp_var_type impls in let c = internalize env - {ids; unb = false; tmp_scope = None; scopes = []; impls; impl_binder_index = None} + {ids; unb = false; tmp_scope = None; scopes = []; impls; binder_block_names = None} false (empty_ltac_sign, vl) a in (* Splits variables into those that are binding, bound, or both *) (* Translate and check that [c] has all its free variables bound in [vars] *) @@ -2473,13 +2550,17 @@ let my_intern_constr env lvar acc c = let intern_context env impl_env binders = try let lvar = (empty_ltac_sign, Id.Map.empty) in + let ids = + (* We assume all ids around are parts of the prefix of the current + context being interpreted *) + extract_ids env in let lenv, bl = List.fold_left (fun (lenv, bl) b -> let (env, bl) = intern_local_binder_aux (my_intern_constr env lvar) Id.Map.empty (lenv, bl) b in (env, bl)) - ({ids = extract_ids env; unb = false; + ({ids; unb = false; tmp_scope = None; scopes = []; impls = impl_env; - impl_binder_index = Some 0}, []) binders in + binder_block_names = Some (Some AbsPi,ids)}, []) binders in (lenv.impls, List.map glob_local_binder_of_extended bl) with InternalizationError (loc,e) -> user_err ?loc ~hdr:"internalize" (explain_internalization_error e) @@ -2500,8 +2581,10 @@ let interp_glob_context_evars ?(program_mode=false) env sigma k bl = let r = Retyping.relevance_of_type env sigma t in let d = LocalAssum (make_annot na r,t) in let impls = - if k == Implicit then CAst.make (Some (na,true)) :: impls - else CAst.make None :: impls + match k with + | NonMaxImplicit -> CAst.make (Some (na,false)) :: impls + | MaxImplicit -> CAst.make (Some (na,true)) :: impls + | Explicit -> CAst.make None :: impls in (push_rel d env, sigma, d::params, succ n, impls) | Some b -> diff --git a/interp/constrintern.mli b/interp/constrintern.mli index 8cce7cd9af..670563f02f 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -97,7 +97,7 @@ val intern_context : env -> internalization_env -> local_binder_expr list -> int (** Main interpretation functions, using type class inference, expecting evars and pending problems to be all resolved *) -val interp_constr : env -> evar_map -> ?impls:internalization_env -> +val interp_constr : ?expected_type:typing_constraint -> env -> evar_map -> ?impls:internalization_env -> constr_expr -> constr Evd.in_evar_universe_context val interp_casted_constr : env -> evar_map -> ?impls:internalization_env -> @@ -109,7 +109,7 @@ val interp_type : env -> evar_map -> ?impls:internalization_env -> (** Main interpretation function expecting all postponed problems to be resolved, but possibly leaving evars. *) -val interp_open_constr : env -> evar_map -> constr_expr -> evar_map * constr +val interp_open_constr : ?expected_type:typing_constraint -> env -> evar_map -> constr_expr -> evar_map * constr (** Accepting unresolved evars *) diff --git a/interp/impargs.ml b/interp/impargs.ml index e2c732809a..78c4b21920 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -14,6 +14,7 @@ open Util open Names open Constr open Globnames +open Glob_term open Declarations open Lib open Libobject @@ -80,10 +81,28 @@ let with_implicit_protection f x = let () = implicit_args := oflags in iraise reraise -let set_maximality imps b = +type on_trailing_implicit = Error | Info | Silent + + +let msg_trailing_implicit (fail : on_trailing_implicit) na i = + let pos = match na with + | Anonymous -> "number " ^ string_of_int i + | Name id -> Names.Id.to_string id in + let str1 = "Argument " ^ pos ^ " is a trailing implicit, " in + match fail with + | Error -> + user_err (strbrk (str1 ^ "so it can't be declared non maximal. Please use { } instead of [ ].")) + | Info -> + Flags.if_verbose Feedback.msg_info (strbrk (str1 ^ "so it has been declared maximally inserted.")) + | Silent -> () + +let set_maximality fail na i imps b = (* Force maximal insertion on ending implicits (compatibility) *) - let is_set x = match x with None -> false | _ -> true in - b || List.for_all is_set imps + b || ( + let is_set x = match x with None -> false | _ -> true in + let b' = List.for_all is_set imps in + if b' then msg_trailing_implicit fail na i; + b') (*s Computation of implicit arguments *) @@ -302,6 +321,11 @@ let is_status_implicit = function let name_of_pos k = Id.of_string ("arg_" ^ string_of_int k) +let binding_kind_of_status = function + | Some (_, _, (false, _)) -> NonMaxImplicit + | Some (_, _, (true, _)) -> MaxImplicit + | None -> Explicit + let name_of_implicit = function | None -> anomaly (Pp.str "Not an implicit argument.") | Some (ExplByName id,_,_) -> id @@ -335,24 +359,24 @@ let positions_of_implicits (_,impls) = (* Manage user-given implicit arguments *) -let rec prepare_implicits f = function +let rec prepare_implicits i f = function | [] -> [] | (Anonymous, Some _)::_ -> anomaly (Pp.str "Unnamed implicit.") | (Name id, Some imp)::imps -> - let imps' = prepare_implicits f imps in - Some (ExplByName id,imp,(set_maximality imps' f.maximal,true)) :: imps' - | _::imps -> None :: prepare_implicits f imps + let imps' = prepare_implicits (i+1) f imps in + Some (ExplByName id,imp,(set_maximality Silent (Name id) i imps' f.maximal,true)) :: imps' + | _::imps -> None :: prepare_implicits (i+1) f imps -let set_manual_implicits flags enriching autoimps l = +let set_manual_implicits silent flags enriching autoimps l = (* Compare with automatic implicits to recover printing data and names *) let rec merge k autoimps explimps = match autoimps, explimps with | autoimp::autoimps, explimp::explimps -> let imps' = merge (k+1) autoimps explimps in begin match autoimp, explimp.CAst.v with | (Name id,_), Some (_,max) -> - Some (ExplByName id, Manual, (set_maximality imps' max, true)) + Some (ExplByName id, Manual, (set_maximality (if silent then Silent else Error) (Name id) k imps' max, true)) | (Name id,Some exp), None when enriching -> - Some (ExplByName id, exp, (set_maximality imps' flags.maximal, true)) + Some (ExplByName id, exp, (set_maximality (if silent then Silent else Info) (Name id) k imps' flags.maximal, true)) | (Name _,_), None -> None | (Anonymous,_), Some (Name id,max) -> Some (ExplByName id,Manual,(max,true)) @@ -370,7 +394,7 @@ let set_manual_implicits flags enriching autoimps l = let compute_semi_auto_implicits env sigma f t = if not f.auto then [DefaultImpArgs, []] else let l = compute_implicits_flags env sigma f false t in - [DefaultImpArgs, prepare_implicits f l] + [DefaultImpArgs, prepare_implicits 1 f l] (*s Constants. *) @@ -497,8 +521,9 @@ let impls_of_context ctx = let map decl = let id = NamedDecl.get_id decl in match Id.Map.get id !sec_implicits with - | Glob_term.Implicit -> Some (ExplByName id, Manual, (true, true)) - | Glob_term.Explicit -> None + | NonMaxImplicit -> Some (ExplByName id, Manual, (false, true)) + | MaxImplicit -> Some (ExplByName id, Manual, (true, true)) + | Explicit -> None in List.rev_map map (List.filter (NamedDecl.is_local_assum) ctx) @@ -608,7 +633,7 @@ type manual_implicits = (Name.t * bool) option CAst.t list let compute_implicits_with_manual env sigma typ enriching l = let autoimpls = compute_auto_implicits env sigma !implicit_args enriching typ in - set_manual_implicits !implicit_args enriching autoimpls l + set_manual_implicits true !implicit_args enriching autoimpls l let check_inclusion l = (* Check strict inclusion *) @@ -636,7 +661,7 @@ let declare_manual_implicits local ref ?enriching l = let t = of_constr t in let enriching = Option.default flags.auto enriching in let autoimpls = compute_auto_implicits env sigma flags enriching t in - let l = [DefaultImpArgs, set_manual_implicits flags enriching autoimpls l] in + let l = [DefaultImpArgs, set_manual_implicits false flags enriching autoimpls l] in let req = if is_local local ref then ImplLocal else ImplInteractive(flags,ImplManual (List.length autoimpls)) @@ -646,28 +671,22 @@ let maybe_declare_manual_implicits local ref ?enriching l = if List.exists (fun x -> x.CAst.v <> None) l then declare_manual_implicits local ref ?enriching l - -let msg_trailing_implicit id = - user_err (strbrk ("Argument " ^ Names.Id.to_string id ^ " is a trailing implicit, so it can't be declared non maximal. Please use { } instead of [ ].")) - -type implicit_kind = Implicit | MaximallyImplicit | NotImplicit +let explicit_kind i = function + | Name id -> ExplByName id + | Anonymous -> ExplByPos (i,None) let compute_implicit_statuses autoimps l = let rec aux i = function - | _ :: autoimps, NotImplicit :: manualimps -> None :: aux (i+1) (autoimps, manualimps) - | Name id :: autoimps, MaximallyImplicit :: manualimps -> - Some (ExplByName id, Manual, (true, true)) :: aux (i+1) (autoimps, manualimps) - | Name id :: autoimps, Implicit :: manualimps -> + | _ :: autoimps, Explicit :: manualimps -> None :: aux (i+1) (autoimps, manualimps) + | na :: autoimps, MaxImplicit :: manualimps -> + Some (explicit_kind i na, Manual, (true, true)) :: aux (i+1) (autoimps, manualimps) + | na :: autoimps, NonMaxImplicit :: manualimps -> let imps' = aux (i+1) (autoimps, manualimps) in - let max = set_maximality imps' false in - if max then msg_trailing_implicit id; - Some (ExplByName id, Manual, (max, true)) :: imps' - | Anonymous :: _, (Implicit | MaximallyImplicit) :: _ -> - user_err ~hdr:"set_implicits" - (strbrk ("Argument number " ^ string_of_int i ^ " (anonymous in original definition) cannot be declared implicit.")) + let max = set_maximality Error na i imps' false in + Some (explicit_kind i na, Manual, (max, true)) :: imps' | autoimps, [] -> List.map (fun _ -> None) autoimps | [], _::_ -> assert false - in aux 0 (autoimps, l) + in aux 1 (autoimps, l) let set_implicits local ref l = let flags = !implicit_args in @@ -684,7 +703,7 @@ let set_implicits local ref l = check_rigidity (is_rigid env sigma t); (* Sort by number of implicits, decreasing *) let is_implicit = function - | NotImplicit -> false + | Explicit -> false | _ -> true in let l = List.map (fun imps -> (imps,List.count is_implicit imps)) l in let l = List.sort (fun (_,n1) (_,n2) -> n2 - n1) l in diff --git a/interp/impargs.mli b/interp/impargs.mli index ef3c2496f4..65e7fd8aaf 100644 --- a/interp/impargs.mli +++ b/interp/impargs.mli @@ -77,6 +77,7 @@ type implicit_side_condition type implicits_list = implicit_side_condition * implicit_status list val is_status_implicit : implicit_status -> bool +val binding_kind_of_status : implicit_status -> Glob_term.binding_kind val is_inferable_implicit : bool -> int -> implicit_status -> bool val name_of_implicit : implicit_status -> Id.t val maximal_insertion_of : implicit_status -> bool @@ -113,12 +114,10 @@ val declare_manual_implicits : bool -> GlobRef.t -> ?enriching:bool -> val maybe_declare_manual_implicits : bool -> GlobRef.t -> ?enriching:bool -> manual_implicits -> unit -type implicit_kind = Implicit | MaximallyImplicit | NotImplicit - (** [set_implicits local ref l] Manual declaration of implicit arguments. `l` is a list of possible sequences of implicit statuses. *) -val set_implicits : bool -> GlobRef.t -> implicit_kind list list -> unit +val set_implicits : bool -> GlobRef.t -> Glob_term.binding_kind list list -> unit val implicits_of_global : GlobRef.t -> implicits_list list diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index 8b457ab37b..ffbb982ab7 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -203,8 +203,9 @@ let warn_ignoring_implicit_status = let implicits_of_glob_constr ?(with_products=true) l = let add_impl ?loc na bk l = match bk with - | Implicit -> CAst.make ?loc (Some (na,true)) :: l - | _ -> CAst.make ?loc None :: l + | NonMaxImplicit -> CAst.make ?loc (Some (na,false)) :: l + | MaxImplicit -> CAst.make ?loc (Some (na,true)) :: l + | Explicit -> CAst.make ?loc None :: l in let rec aux c = match DAst.get c with @@ -212,8 +213,9 @@ let implicits_of_glob_constr ?(with_products=true) l = if with_products then add_impl na bk (aux b) else let () = match bk with - | Implicit -> warn_ignoring_implicit_status na ?loc:c.CAst.loc - | _ -> () + | NonMaxImplicit + | MaxImplicit -> warn_ignoring_implicit_status na ?loc:c.CAst.loc + | Explicit -> () in [] | GLambda (na, bk, t, b) -> add_impl ?loc:t.CAst.loc na bk (aux b) | GLetIn (na, b, t, c) -> aux c diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index 265ca58ed9..d1eb50d370 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -151,6 +151,24 @@ let rec subst_glob_vars l gc = DAst.map (function let ldots_var = Id.of_string ".." +type 'a binder_status_fun = { + no : 'a -> 'a; + restart_prod : 'a -> 'a; + restart_lambda : 'a -> 'a; + switch_prod : 'a -> 'a; + switch_lambda : 'a -> 'a; + slide : 'a -> 'a; +} + +let default_binder_status_fun = { + no = (fun x -> x); + restart_prod = (fun x -> x); + restart_lambda = (fun x -> x); + switch_prod = (fun x -> x); + switch_lambda = (fun x -> x); + slide = (fun x -> x); +} + let protect g e na = let e',disjpat,na = g e na in if disjpat <> None then user_err (Pp.str "Unsupported substitution of an arbitrary pattern."); @@ -163,10 +181,10 @@ let apply_cases_pattern_term ?loc (ids,disjpat) tm c = let apply_cases_pattern ?loc (ids_disjpat,id) c = apply_cases_pattern_term ?loc ids_disjpat (DAst.make ?loc (GVar id)) c -let glob_constr_of_notation_constr_with_binders ?loc g f e nc = +let glob_constr_of_notation_constr_with_binders ?loc g f ?(h=default_binder_status_fun) e nc = let lt x = DAst.make ?loc x in lt @@ match nc with | NVar id -> GVar id - | NApp (a,args) -> GApp (f e a, List.map (f e) args) + | NApp (a,args) -> let e = h.no e in GApp (f e a, List.map (f e) args) | NList (x,y,iter,tail,swap) -> let t = f e tail in let it = f e iter in let innerl = (ldots_var,t)::(if swap then [y, lt @@ GVar x] else []) in @@ -180,15 +198,18 @@ let glob_constr_of_notation_constr_with_binders ?loc g f e nc = let outerl = (ldots_var,inner)::(if swap then [] else [y, lt @@ GVar x]) in DAst.get (subst_glob_vars outerl it) | NLambda (na,ty,c) -> - let e',disjpat,na = g e na in GLambda (na,Explicit,f e ty,Option.fold_right (apply_cases_pattern ?loc) disjpat (f e' c)) + let e = h.switch_lambda e in + let e',disjpat,na = g e na in GLambda (na,Explicit,f (h.restart_prod e) ty,Option.fold_right (apply_cases_pattern ?loc) disjpat (f e' c)) | NProd (na,ty,c) -> - let e',disjpat,na = g e na in GProd (na,Explicit,f e ty,Option.fold_right (apply_cases_pattern ?loc) disjpat (f e' c)) + let e = h.switch_prod e in + let e',disjpat,na = g e na in GProd (na,Explicit,f (h.restart_prod e) ty,Option.fold_right (apply_cases_pattern ?loc) disjpat (f e' c)) | NLetIn (na,b,t,c) -> let e',disjpat,na = g e na in (match disjpat with - | None -> GLetIn (na,f e b,Option.map (f e) t,f e' c) + | None -> GLetIn (na,f (h.restart_lambda e) b,Option.map (f (h.restart_prod e)) t,f e' c) | Some (disjpat,_id) -> DAst.get (apply_cases_pattern_term ?loc disjpat (f e b) (f e' c))) | NCases (sty,rtntypopt,tml,eqnl) -> + let e = h.no e in let e',tml' = List.fold_right (fun (tm,(na,t)) (e',tml') -> let e',t' = match t with | None -> e',None @@ -207,19 +228,22 @@ let glob_constr_of_notation_constr_with_binders ?loc g f e nc = List.map (fun patl -> CAst.make (idl,patl,f e rhs)) disjpatl) eqnl in GCases (sty,Option.map (f e') rtntypopt,tml',List.flatten eqnl') | NLetTuple (nal,(na,po),b,c) -> + let e = h.no e in let e',nal = List.fold_left_map (protect g) e nal in let e'',na = protect g e na in GLetTuple (nal,(na,Option.map (f e'') po),f e b,f e' c) | NIf (c,(na,po),b1,b2) -> + let e = h.no e in let e',na = protect g e na in GIf (f e c,(na,Option.map (f e') po),f e b1,f e b2) | NRec (fk,idl,dll,tl,bl) -> + let e = h.no e in let e,dll = Array.fold_left_map (List.fold_left_map (fun e (na,oc,b) -> let e,na = protect g e na in (e,(na,Explicit,Option.map (f e) oc,f e b)))) e dll in let e',idl = Array.fold_left_map (to_id (protect g)) e idl in GRec (fk,idl,dll,Array.map (f e) tl,Array.map (f e') bl) - | NCast (c,k) -> GCast (f e c,map_cast_type (f e) k) + | NCast (c,k) -> GCast (f e c,map_cast_type (f (h.slide e)) k) | NSort x -> GSort x | NHole (x, naming, arg) -> GHole (x, naming, arg) | NRef x -> GRef (x,None) diff --git a/interp/notation_ops.mli b/interp/notation_ops.mli index f9de6b7d6b..c62dac013b 100644 --- a/interp/notation_ops.mli +++ b/interp/notation_ops.mli @@ -35,12 +35,21 @@ val notation_constr_of_glob_constr : notation_interp_env -> (** Re-interpret a notation as a [glob_constr], taking care of binders *) +type 'a binder_status_fun = { + no : 'a -> 'a; + restart_prod : 'a -> 'a; + restart_lambda : 'a -> 'a; + switch_prod : 'a -> 'a; + switch_lambda : 'a -> 'a; + slide : 'a -> 'a; +} + val apply_cases_pattern : ?loc:Loc.t -> (Id.t list * cases_pattern_disjunction) * Id.t -> glob_constr -> glob_constr val glob_constr_of_notation_constr_with_binders : ?loc:Loc.t -> ('a -> Name.t -> 'a * ((Id.t list * cases_pattern_disjunction) * Id.t) option * Name.t) -> - ('a -> notation_constr -> glob_constr) -> + ('a -> notation_constr -> glob_constr) -> ?h:'a binder_status_fun -> 'a -> notation_constr -> glob_constr val glob_constr_of_notation_constr : ?loc:Loc.t -> notation_constr -> glob_constr diff --git a/interp/reserve.ml b/interp/reserve.ml index e81439c3d5..4a731e57a3 100644 --- a/interp/reserve.ml +++ b/interp/reserve.ml @@ -104,8 +104,8 @@ let declare_reserved_type idl t = let find_reserved_type id = Id.Map.find (root_of_id id) !reserve_table let constr_key c = - try RefKey (canonical_gr (global_of_constr (fst (Constr.decompose_app c)))) - with Not_found -> Oth + try RefKey (canonical_gr (fst @@ Constr.destRef (fst (Constr.decompose_app c)))) + with Constr.DestKO -> Oth let revert_reserved_type t = try diff --git a/kernel/constr.ml b/kernel/constr.ml index 15e5c512ed..84eacb196c 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -253,7 +253,7 @@ let mkFloat f = Float f least one argument and the function is not itself an applicative term *) -let kind c = c +let kind (c:t) = c let rec kind_nocast_gen kind c = match kind c with @@ -338,6 +338,19 @@ let isProj c = match kind c with Proj _ -> true | _ -> false let isFix c = match kind c with Fix _ -> true | _ -> false let isCoFix c = match kind c with CoFix _ -> true | _ -> false +let isRef c = match kind c with + | Const _ | Ind _ | Construct _ | Var _ -> true + | _ -> false + +let isRefX x c = + let open GlobRef in + match x, kind c with + | ConstRef c, Const (c', _) -> Constant.equal c c' + | IndRef i, Ind (i', _) -> eq_ind i i' + | ConstructRef i, Construct (i', _) -> eq_constructor i i' + | VarRef id, Var id' -> Id.equal id id' + | _ -> false + (* Destructs a de Bruijn index *) let destRel c = match kind c with | Rel n -> n diff --git a/kernel/constr.mli b/kernel/constr.mli index d4af1149c2..159570b5ea 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -256,6 +256,8 @@ val isRel : constr -> bool val isRelN : int -> constr -> bool val isVar : constr -> bool val isVarId : Id.t -> constr -> bool +val isRef : constr -> bool +val isRefX : GlobRef.t -> constr -> bool val isInd : constr -> bool val isEvar : constr -> bool val isMeta : constr -> bool diff --git a/kernel/context.ml b/kernel/context.ml index 7e394da2ed..500ed20343 100644 --- a/kernel/context.ml +++ b/kernel/context.ml @@ -196,12 +196,10 @@ struct (** Return a new rel-context enriched by with a given inner-most declaration. *) let add d ctx = d :: ctx - (** Return the number of {e local declarations} in a given context. *) + (** Return the number of {e local declarations} in a given rel-context. *) let length = List.length - (** [extended_rel_list n Γ] builds an instance [args] such that [Γ,Δ ⊢ args:Γ] - with n = |Δ| and with the local definitions of [Γ] skipped in - [args]. Example: for [x:T,y:=c,z:U] and [n]=2, it gives [Rel 5, Rel 3]. *) + (** Return the number of {e local assumptions} in a given rel-context. *) let nhyps ctx = let open Declaration in let rec nhyps acc = function @@ -413,7 +411,7 @@ struct (** empty named-context *) let empty = [] - (** empty named-context *) + (** Return a new named-context enriched by with a given inner-most declaration. *) let add d ctx = d :: ctx (** Return the number of {e local declarations} in a given named-context. *) diff --git a/kernel/context.mli b/kernel/context.mli index 8f233613da..04aa039a01 100644 --- a/kernel/context.mli +++ b/kernel/context.mli @@ -129,7 +129,7 @@ sig (** Return a new rel-context enriched by with a given inner-most declaration. *) val add : ('c, 't) Declaration.pt -> ('c, 't) pt -> ('c, 't) pt - (** Return the number of {e local declarations} in a given context. *) + (** Return the number of {e local declarations} in a given rel-context. *) val length : ('c, 't) pt -> int (** Check whether given two rel-contexts are equal. *) diff --git a/kernel/cooking.ml b/kernel/cooking.ml index cebbfe4986..31dd26d2ba 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -258,17 +258,6 @@ let cook_constant { from = cb; info } = (********************************) (* Discharging mutual inductive *) -let template_level_of_var ~template_check d = - (* When [template_check], a universe from a section variable may not - be in the universes from the inductive (it must be pre-declared) - so always [None]. *) - if template_check then None - else - let c = Term.strip_prod_assum (RelDecl.get_type d) in - match kind c with - | Sort (Type u) -> Univ.Universe.level u - | _ -> None - let it_mkProd_wo_LetIn = List.fold_left (fun c d -> mkProd_wo_LetIn d c) let abstract_rel_ctx (section_decls,subst) ctx = @@ -305,21 +294,21 @@ let abstract_projection ~params expmod hyps t = let _, t = decompose_prod_n_assum (List.length params + 1 + Context.Rel.nhyps (fst hyps)) t in t -let cook_one_ind ~template_check ~ntypes +let cook_one_ind ~ntypes (section_decls,_ as 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} -> + | 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 (template_level_of_var ~template_check 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} + TemplateArity {template_param_levels=levels;template_level;template_context} in let mind_arity_ctxt = let ctx = Context.Rel.map expmod mip.mind_arity_ctxt in @@ -362,14 +351,13 @@ let cook_inductive { Opaqueproof.modlist; abstract } mib = let removed_vars = Context.Named.to_vars section_decls in let section_decls, _ as hyps = abstract_context section_decls in let nnewparams = Context.Rel.nhyps section_decls in - let template_check = mib.mind_typing_flags.check_template in let mind_params_ctxt = let ctx = Context.Rel.map expmod mib.mind_params_ctxt in abstract_rel_ctx hyps ctx in let ntypes = mib.mind_ntypes in let mind_packets = - Array.map (cook_one_ind ~template_check ~ntypes hyps expmod) + Array.map (cook_one_ind ~ntypes hyps expmod) mib.mind_packets in let mind_record = match mib.mind_record with diff --git a/kernel/declarations.ml b/kernel/declarations.ml index 0b6e59bd5e..ac130d018d 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -32,6 +32,7 @@ type engagement = set_predicativity type template_arity = { template_param_levels : Univ.Level.t option list; template_level : Univ.Universe.t; + template_context : Univ.ContextSet.t; } type ('a, 'b) declaration_arity = @@ -88,10 +89,6 @@ type typing_flags = { indices_matter: bool; (** The universe of an inductive type must be above that of its indices. *) - check_template : bool; - (* If [false] then we don't check that the universes template-polymorphic - inductive parameterize on are necessarily local and unbounded from below. - This potentially introduces inconsistencies. *) } (* some contraints are in constant_constraints, some other may be in diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 27e3f84464..a3adac7a11 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -26,7 +26,6 @@ let safe_flags oracle = { enable_VM = true; enable_native_compiler = true; indices_matter = true; - check_template = true; } (** {6 Arities } *) @@ -49,7 +48,8 @@ let map_decl_arity f g = function let hcons_template_arity 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_level = Univ.hcons_univ ar.template_level; + template_context = Univ.hcons_universe_context_set ar.template_context } let universes_context = function | Monomorphic _ -> Univ.AUContext.empty diff --git a/kernel/environ.ml b/kernel/environ.ml index f04863386f..501ac99ff3 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -275,7 +275,6 @@ let type_in_type env = not (typing_flags env).check_universes let deactivated_guard env = not (typing_flags env).check_guarded let indices_matter env = env.env_typing_flags.indices_matter -let check_template env = env.env_typing_flags.check_template let universes env = env.env_stratification.env_universes let universes_lbound env = env.env_stratification.env_universes_lbound @@ -399,9 +398,6 @@ let add_constraints c env = let check_constraints c env = UGraph.check_constraints c env.env_stratification.env_universes -let push_constraints_to_env (_,univs) env = - add_constraints univs env - let add_universes ~lbound ~strict ctx g = let g = Array.fold_left (fun g v -> UGraph.add_universe ~lbound ~strict v g) @@ -449,7 +445,6 @@ let same_flags { share_reduction; enable_VM; enable_native_compiler; - check_template; } alt = check_guarded == alt.check_guarded && check_positive == alt.check_positive && @@ -458,8 +453,7 @@ let same_flags { indices_matter == alt.indices_matter && share_reduction == alt.share_reduction && enable_VM == alt.enable_VM && - enable_native_compiler == alt.enable_native_compiler && - check_template == alt.check_template + enable_native_compiler == alt.enable_native_compiler [@warning "+9"] let set_typing_flags c env = (* Unsafe *) @@ -591,9 +585,6 @@ let polymorphic_pind (ind,u) env = let type_in_type_ind (mind,_i) env = not (lookup_mind mind env).mind_typing_flags.check_universes -let template_checked_ind (mind,_i) env = - (lookup_mind mind env).mind_typing_flags.check_template - let template_polymorphic_ind (mind,i) env = match (lookup_mind mind env).mind_packets.(i).mind_arity with | TemplateArity _ -> true @@ -802,14 +793,6 @@ let get_template_polymorphic_variables env r = | IndRef ind -> template_polymorphic_variables ind env | ConstructRef cstr -> template_polymorphic_variables (inductive_of_constructor cstr) env -let is_template_checked env r = - let open Names.GlobRef in - match r with - | VarRef _id -> false - | ConstRef _c -> false - | IndRef ind -> template_checked_ind ind env - | ConstructRef cstr -> template_checked_ind (inductive_of_constructor cstr) env - let is_type_in_type env r = let open Names.GlobRef in match r with diff --git a/kernel/environ.mli b/kernel/environ.mli index bd5a000c2b..a596584cbe 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -112,7 +112,6 @@ val is_impredicative_set : env -> bool val type_in_type : env -> bool val deactivated_guard : env -> bool val indices_matter : env -> bool -val check_template : env -> bool val is_impredicative_sort : env -> Sorts.t -> bool val is_impredicative_univ : env -> Univ.Universe.t -> bool @@ -274,7 +273,6 @@ val type_in_type_ind : inductive -> env -> bool val template_polymorphic_ind : inductive -> env -> bool val template_polymorphic_variables : inductive -> env -> Univ.Level.t list val template_polymorphic_pind : pinductive -> env -> bool -val template_checked_ind : inductive -> env -> bool (** {5 Modules } *) @@ -288,22 +286,21 @@ val lookup_modtype : ModPath.t -> env -> module_type_body (** {5 Universe constraints } *) -(** Add universe constraints to the environment. - @raise UniverseInconsistency . -*) val add_constraints : Univ.Constraint.t -> env -> env +(** Add universe constraints to the environment. + @raise UniverseInconsistency. *) -(** Check constraints are satifiable in the environment. *) val check_constraints : Univ.Constraint.t -> env -> bool +(** Check constraints are satifiable in the environment. *) + val push_context : ?strict:bool -> Univ.UContext.t -> env -> env -(* [push_context ?(strict=false) ctx env] pushes the universe context to the environment. - @raise UGraph.AlreadyDeclared if one of the universes is already declared. -*) -val push_context_set : ?strict:bool -> Univ.ContextSet.t -> env -> env -(* [push_context_set ?(strict=false) ctx env] pushes the universe context set - to the environment. It does not fail if one of the universes is already declared. *) +(** [push_context ?(strict=false) ctx env] pushes the universe context to the environment. + @raise UGraph.AlreadyDeclared if one of the universes is already declared. *) -val push_constraints_to_env : 'a Univ.constrained -> env -> env +val push_context_set : ?strict:bool -> Univ.ContextSet.t -> env -> env +(** [push_context_set ?(strict=false) ctx env] pushes the universe + context set to the environment. It does not fail even if one of the + universes is already declared. *) val push_subgraph : Univ.ContextSet.t -> env -> env (** [push_subgraph univs env] adds the universes and constraints in @@ -373,7 +370,6 @@ val remove_hyps : Id.Set.t -> (Constr.named_declaration -> Constr.named_declarat val is_polymorphic : env -> Names.GlobRef.t -> bool val is_template_polymorphic : env -> GlobRef.t -> bool val get_template_polymorphic_variables : env -> GlobRef.t -> Univ.Level.t list -val is_template_checked : env -> GlobRef.t -> bool val is_type_in_type : env -> GlobRef.t -> bool (** Native compiler *) diff --git a/kernel/float64.ml b/kernel/float64.ml index 3e36373b77..cc661aeba3 100644 --- a/kernel/float64.ml +++ b/kernel/float64.ml @@ -12,7 +12,10 @@ format *) type t = float -let is_nan f = f <> f +(* The [f : float] type annotation enable the compiler to compile f <> f + as comparison on floats rather than the polymorphic OCaml comparison + which is much slower. *) +let is_nan (f : float) = f <> f let is_infinity f = f = infinity let is_neg_infinity f = f = neg_infinity @@ -42,19 +45,20 @@ let abs = abs_float type float_comparison = FEq | FLt | FGt | FNotComparable -let eq x y = x = y +(* See above comment on [is_nan] for the [float] type annotations. *) +let eq (x : float) (y : float) = x = y [@@ocaml.inline always] -let lt x y = x < y +let lt (x : float) (y : float) = x < y [@@ocaml.inline always] -let le x y = x <= y +let le (x : float) (y : float) = x <= y [@@ocaml.inline always] (* inspired by lib/util.ml; see also #10471 *) -let pervasives_compare = compare +let pervasives_compare (x : float) (y : float) = compare x y -let compare x y = +let compare (x : float) (y : float) = if x < y then FLt else ( diff --git a/kernel/indTyping.ml b/kernel/indTyping.ml index 591cd050a5..cc15109f06 100644 --- a/kernel/indTyping.ml +++ b/kernel/indTyping.ml @@ -66,7 +66,9 @@ let mind_check_names mie = type univ_info = { ind_squashed : bool; ind_has_relevant_arg : bool; ind_min_univ : Universe.t option; (* Some for template *) - ind_univ : Universe.t } + ind_univ : Universe.t; + missing : Universe.Set.t; (* missing u <= ind_univ constraints *) + } let check_univ_leq ?(is_real_arg=false) env u info = let ind_univ = info.ind_univ in @@ -78,9 +80,8 @@ let check_univ_leq ?(is_real_arg=false) env u info = if type_in_type env || Univ.Universe.is_sprop u || UGraph.check_leq (universes env) u ind_univ then { info with ind_min_univ = Option.map (Universe.sup u) info.ind_min_univ } else if is_impredicative_univ env ind_univ - then if Option.is_empty info.ind_min_univ then { info with ind_squashed = true } - else raise (InductiveError BadUnivs) - else raise (InductiveError BadUnivs) + && Option.is_empty info.ind_min_univ then { info with ind_squashed = true } + else {info with missing = Universe.Set.add u info.missing} let check_context_univs ~ctor env info ctx = let check_one d (info,env) = @@ -109,6 +110,7 @@ let check_arity env_params env_ar ind = ind_has_relevant_arg=false; ind_min_univ; ind_univ=Sorts.univ_of_sort ind_sort; + missing=Universe.Set.empty; } in let univ_info = check_indices_matter env_params univ_info indices in @@ -174,7 +176,7 @@ let check_record data = (* - all_sorts in case of small, unitary Prop (not smashed) *) (* - logical_sorts in case of large, unitary Prop (smashed) *) -let allowed_sorts {ind_squashed;ind_univ;ind_min_univ=_;ind_has_relevant_arg=_} = +let allowed_sorts {ind_squashed;ind_univ;ind_min_univ=_;ind_has_relevant_arg=_;missing=_} = if not ind_squashed then InType else Sorts.family (Sorts.sort_of_univ ind_univ) @@ -195,7 +197,7 @@ let unbounded_from_below u cstrs = (starting from the most recent and ignoring let-definitions) is not contributing to the inductive type's sort or is Some u_k if its level is u_k and is contributing. *) -let template_polymorphic_univs ~template_check ~ctor_levels uctx paramsctxt concl = +let template_polymorphic_univs ~ctor_levels uctx paramsctxt concl = let check_level l = Univ.LSet.mem l (Univ.ContextSet.levels uctx) && unbounded_from_below l (Univ.ContextSet.constraints uctx) && @@ -203,27 +205,25 @@ let template_polymorphic_univs ~template_check ~ctor_levels uctx paramsctxt conc in let univs = Univ.Universe.levels concl in let univs = - if template_check then - Univ.LSet.filter (fun l -> check_level l || Univ.Level.is_prop l) univs - else univs (* Doesn't check the universes can be generalized *) + Univ.LSet.filter (fun l -> check_level l || Univ.Level.is_prop l) univs in let fold acc = function | (LocalAssum (_, p)) -> (let c = Term.strip_prod_assum p in match kind c with | Sort (Type u) -> - if template_check then (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 | None -> None) - else Univ.Universe.level u | _ -> None) :: acc | LocalDef _ -> acc in let params = List.fold_left fold [] paramsctxt in params, univs -let abstract_packets ~template_check univs usubst params ((arity,lc),(indices,splayed_lc),univ_info) = +let abstract_packets univs usubst params ((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 let lc = Array.map (Vars.subst_univs_level_constr usubst) lc in let indices = Vars.subst_univs_level_context usubst indices in @@ -263,14 +263,14 @@ let abstract_packets ~template_check univs usubst params ((arity,lc),(indices,sp splayed_lc in let param_levels, concl_levels = - template_polymorphic_univs ~template_check ~ctor_levels ctx params min_univ + template_polymorphic_univs ~ctor_levels ctx params min_univ in - if template_check && List.for_all (fun x -> Option.is_empty x) param_levels + 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} + TemplateArity {template_param_levels = param_levels; template_level = min_univ; template_context = ctx } in let kelim = allowed_sorts univ_info in @@ -352,8 +352,7 @@ 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 template_check = Environ.check_template env in - let data = List.map (abstract_packets ~template_check univs usubst params) data in + let data = List.map (abstract_packets univs usubst params) data in let env_ar_par = let ctx = Environ.rel_context env_ar_par in diff --git a/kernel/indTyping.mli b/kernel/indTyping.mli index 8dea8f046d..723ba5459e 100644 --- a/kernel/indTyping.mli +++ b/kernel/indTyping.mli @@ -40,7 +40,6 @@ val typecheck_inductive : env -> sec_univs:Univ.Level.t array option (* Utility function to compute the actual universe parameters of a template polymorphic inductive *) val template_polymorphic_univs : - template_check:bool -> ctor_levels:Univ.LSet.t -> Univ.ContextSet.t -> Constr.rel_context -> diff --git a/kernel/inductive.ml b/kernel/inductive.ml index ca4fea45c5..5d8e1f0fdb 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -198,7 +198,14 @@ let relevance_of_inductive env ind = let _, mip = lookup_mind_specif env ind in mip.mind_relevance -let type_of_inductive_gen ?(polyprop=true) env ((_,mip),u) paramtyps = +let check_instance mib u = + if not (match mib.mind_universes with + | Monomorphic _ -> Instance.is_empty u + | Polymorphic uctx -> Instance.length u = AUContext.size uctx) + then CErrors.anomaly Pp.(str "bad instance length on mutind.") + +let type_of_inductive_gen ?(polyprop=true) env ((mib,mip),u) paramtyps = + check_instance mib u; match mip.mind_arity with | RegularArity a -> subst_instance_constr u a.mind_user_arity | TemplateArity ar -> @@ -244,6 +251,7 @@ let max_inductive_sort = (* Type of a constructor *) let type_of_constructor (cstr, u) (mib,mip) = + check_instance mib u; let ind = inductive_of_constructor cstr in let specif = mip.mind_user_lc in let i = index_of_constructor cstr in diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index f6f2058c13..8db8a044a8 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -321,6 +321,8 @@ let universes_of_private eff = let env_of_safe_env senv = senv.env let env_of_senv = env_of_safe_env +let structure_body_of_safe_env env = env.revstruct + let sections_of_safe_env senv = senv.sections let get_section = function @@ -757,7 +759,7 @@ 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 (b_ctx, eff) = +let export_side_effects mb env eff = 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 @@ -774,7 +776,7 @@ let export_side_effects mb env (b_ctx, eff) = in let rec translate_seff sl seff acc env = match seff with - | [] -> List.rev acc, b_ctx + | [] -> List.rev acc | eff :: rest -> if Int.equal sl 0 then let env, cb = @@ -803,8 +805,8 @@ let push_opaque_proof pf senv = let senv = { senv with env = Environ.set_opaque_tables senv.env otab } in senv, o -let export_private_constants ce senv = - let exported, ce = export_side_effects senv.revstruct senv.env ce in +let export_private_constants eff senv = + let exported = export_side_effects senv.revstruct senv.env eff in let map senv (kn, c) = match c.const_body with | OpaqueDef p -> let local = empty_private c.const_universes in @@ -817,7 +819,7 @@ let export_private_constants ce senv = let exported = List.map (fun (kn, _) -> kn) exported in (* No delayed constants to declare *) let senv = List.fold_left add_constant_aux senv bodies in - (ce, exported), senv + exported, senv let add_constant l decl senv = let kn = Constant.make2 senv.modpath l in diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 92bbd264fa..e472dfd5e5 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -37,6 +37,8 @@ val env_of_safe_env : safe_environment -> Environ.env val sections_of_safe_env : safe_environment -> section_data Section.t option +val structure_body_of_safe_env : safe_environment -> Declarations.structure_body + (** The safe_environment state monad *) type safe_transformer0 = safe_environment -> safe_environment @@ -84,8 +86,8 @@ type side_effect_declaration = type exported_private_constant = Constant.t val export_private_constants : - private_constants Entries.proof_output -> - (Constr.constr Univ.in_universe_context_set * exported_private_constant list) safe_transformer + private_constants -> + exported_private_constant list safe_transformer (** returns the main constant *) val add_constant : diff --git a/kernel/term.ml b/kernel/term.ml index 87678b911e..a2586e74f7 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -363,24 +363,3 @@ let rec isArity c = | Cast (c,_,_) -> isArity c | Sort _ -> true | _ -> false - -(** Kind of type *) - -(* Experimental, used in Presburger contrib *) -type ('constr, 'types) kind_of_type = - | SortType of Sorts.t - | CastType of 'types * 'types - | ProdType of Name.t Context.binder_annot * 'types * 'types - | LetInType of Name.t Context.binder_annot * 'constr * 'types * 'types - | AtomicType of 'constr * 'constr array - -let kind_of_type t = match kind t with - | Sort s -> SortType s - | Cast (c,_,t) -> CastType (c, t) - | Prod (na,t,c) -> ProdType (na, t, c) - | LetIn (na,b,t,c) -> LetInType (na, b, t, c) - | App (c,l) -> AtomicType (c, l) - | (Rel _ | Meta _ | Var _ | Evar _ | Const _ - | Proj _ | Case _ | Fix _ | CoFix _ | Ind _) - -> AtomicType (t,[||]) - | (Lambda _ | Construct _ | Int _ | Float _) -> failwith "Not a type" diff --git a/kernel/term.mli b/kernel/term.mli index d2de4177ce..1fef54257a 100644 --- a/kernel/term.mli +++ b/kernel/term.mli @@ -181,17 +181,6 @@ val destArity : types -> arity (** Tell if a term has the form of an arity *) val isArity : types -> bool -(** {5 Kind of type} *) - -type ('constr, 'types) kind_of_type = - | SortType of Sorts.t - | CastType of 'types * 'types - | ProdType of Name.t Context.binder_annot * 'types * 'types - | LetInType of Name.t Context.binder_annot * 'constr * 'types * 'types - | AtomicType of 'constr * 'constr array - -val kind_of_type : types -> (constr, types) kind_of_type - (* Deprecated *) type sorts_family = Sorts.family = InSProp | InProp | InSet | InType [@@ocaml.deprecated "Alias for Sorts.family"] diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml index f221ac7a4f..6c06c1e0f1 100644 --- a/kernel/type_errors.ml +++ b/kernel/type_errors.ml @@ -12,6 +12,7 @@ open Names open Constr open Environ open Reduction +open Univ (* Type errors. *) @@ -47,7 +48,7 @@ type ('constr, 'types) ptype_error = | UnboundVar of variable | NotAType of ('constr, 'types) punsafe_judgment | BadAssumption of ('constr, 'types) punsafe_judgment - | ReferenceVariables of Id.t * 'constr + | ReferenceVariables of Id.t * GlobRef.t | ElimArity of pinductive * 'constr * ('constr, 'types) punsafe_judgment * (Sorts.family * Sorts.family * Sorts.family * arity_error) option | CaseNotInductive of ('constr, 'types) punsafe_judgment @@ -63,8 +64,8 @@ type ('constr, 'types) ptype_error = | IllFormedRecBody of 'constr pguard_error * Name.t Context.binder_annot array * int * env * ('constr, 'types) punsafe_judgment array | IllTypedRecBody of int * Name.t Context.binder_annot array * ('constr, 'types) punsafe_judgment array * 'types array - | UnsatisfiedConstraints of Univ.Constraint.t - | UndeclaredUniverse of Univ.Level.t + | UnsatisfiedConstraints of Constraint.t + | UndeclaredUniverse of Level.t | DisallowedSProp | BadRelevance @@ -83,7 +84,7 @@ type inductive_error = | NotAnArity of env * constr | BadEntry | LargeNonPropInductiveNotInType - | BadUnivs + | MissingConstraints of (Universe.Set.t * Universe.t) exception InductiveError of inductive_error @@ -181,7 +182,7 @@ let map_ptype_error f = function | UnboundVar id -> UnboundVar id | NotAType j -> NotAType (on_judgment f j) | BadAssumption j -> BadAssumption (on_judgment f j) -| ReferenceVariables (id, c) -> ReferenceVariables (id, f c) +| ReferenceVariables (id, c) -> ReferenceVariables (id, c) | ElimArity (pi, c, j, ar) -> ElimArity (pi, f c, on_judgment f j, ar) | CaseNotInductive j -> CaseNotInductive (on_judgment f j) | WrongCaseInfo (pi, ci) -> WrongCaseInfo (pi, ci) diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli index ae6fd31762..d9842ecefa 100644 --- a/kernel/type_errors.mli +++ b/kernel/type_errors.mli @@ -11,6 +11,7 @@ open Names open Constr open Environ +open Univ (** Type errors. {% \label{typeerrors} %} *) @@ -48,7 +49,7 @@ type ('constr, 'types) ptype_error = | UnboundVar of variable | NotAType of ('constr, 'types) punsafe_judgment | BadAssumption of ('constr, 'types) punsafe_judgment - | ReferenceVariables of Id.t * 'constr + | ReferenceVariables of Id.t * GlobRef.t | ElimArity of pinductive * 'constr * ('constr, 'types) punsafe_judgment * (Sorts.family * Sorts.family * Sorts.family * arity_error) option | CaseNotInductive of ('constr, 'types) punsafe_judgment @@ -64,8 +65,8 @@ type ('constr, 'types) ptype_error = | IllFormedRecBody of 'constr pguard_error * Name.t Context.binder_annot array * int * env * ('constr, 'types) punsafe_judgment array | IllTypedRecBody of int * Name.t Context.binder_annot array * ('constr, 'types) punsafe_judgment array * 'types array - | UnsatisfiedConstraints of Univ.Constraint.t - | UndeclaredUniverse of Univ.Level.t + | UnsatisfiedConstraints of Constraint.t + | UndeclaredUniverse of Level.t | DisallowedSProp | BadRelevance @@ -86,7 +87,8 @@ type inductive_error = | NotAnArity of env * constr | BadEntry | LargeNonPropInductiveNotInType - | BadUnivs + | MissingConstraints of (Universe.Set.t * Universe.t) + (* each universe in the set should have been <= the other one *) exception InductiveError of inductive_error @@ -100,7 +102,7 @@ val error_not_type : env -> unsafe_judgment -> 'a val error_assumption : env -> unsafe_judgment -> 'a -val error_reference_variables : env -> Id.t -> constr -> 'a +val error_reference_variables : env -> Id.t -> GlobRef.t -> 'a val error_elim_arity : env -> pinductive -> constr -> unsafe_judgment -> @@ -133,9 +135,9 @@ val error_ill_typed_rec_body : val error_elim_explain : Sorts.family -> Sorts.family -> arity_error -val error_unsatisfied_constraints : env -> Univ.Constraint.t -> 'a +val error_unsatisfied_constraints : env -> Constraint.t -> 'a -val error_undeclared_universe : env -> Univ.Level.t -> 'a +val error_undeclared_universe : env -> Level.t -> 'a val error_disallowed_sprop : env -> 'a diff --git a/kernel/typeops.ml b/kernel/typeops.ml index c74bfd0688..2a35f87db8 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -116,7 +116,7 @@ let type_of_variable env id = (* Checks if a context of variables can be instantiated by the variables of the current env. Order does not have to be checked assuming that all names are distinct *) -let check_hyps_inclusion env ?evars f c sign = +let check_hyps_inclusion env ?evars c sign = let conv env a b = conv env ?evars a b in Context.Named.fold_outside (fun d1 () -> @@ -133,7 +133,7 @@ let check_hyps_inclusion env ?evars f c sign = | LocalDef _, LocalAssum _ -> raise NotConvertible | LocalDef (_,b2,_), LocalDef (_,b1,_) -> conv env b2 b1); with Not_found | NotConvertible | Option.Heterogeneous -> - error_reference_variables env id (f c)) + error_reference_variables env id c) sign ~init:() @@ -146,14 +146,14 @@ let check_hyps_inclusion env ?evars f c sign = let type_of_constant env (kn,_u as cst) = let cb = lookup_constant kn env in - let () = check_hyps_inclusion env mkConstU cst cb.const_hyps in + let () = check_hyps_inclusion env (GlobRef.ConstRef kn) cb.const_hyps in let ty, cu = constant_type env cst in let () = check_constraints cu env in ty let type_of_constant_in env (kn,_u as cst) = let cb = lookup_constant kn env in - let () = check_hyps_inclusion env mkConstU cst cb.const_hyps in + let () = check_hyps_inclusion env (GlobRef.ConstRef kn) cb.const_hyps in constant_type_in env cst (* Type of a lambda-abstraction. *) @@ -368,18 +368,18 @@ let check_cast env c ct k expected_type = the App case of execute; from this constraints, the expected dynamic constraints of the form u<=v are enforced *) -let type_of_inductive_knowing_parameters env (ind,u as indu) args = +let type_of_inductive_knowing_parameters env (ind,u) args = let (mib,_mip) as spec = lookup_mind_specif env ind in - check_hyps_inclusion env mkIndU indu mib.mind_hyps; + check_hyps_inclusion env (GlobRef.IndRef ind) mib.mind_hyps; let t,cst = Inductive.constrained_type_of_inductive_knowing_parameters env (spec,u) args in check_constraints cst env; t -let type_of_inductive env (ind,u as indu) = +let type_of_inductive env (ind,u) = let (mib,mip) = lookup_mind_specif env ind in - check_hyps_inclusion env mkIndU indu mib.mind_hyps; + check_hyps_inclusion env (GlobRef.IndRef ind) mib.mind_hyps; let t,cst = Inductive.constrained_type_of_inductive env ((mib,mip),u) in check_constraints cst env; t @@ -390,7 +390,7 @@ let type_of_constructor env (c,_u as cu) = let () = let ((kn,_),_) = c in let mib = lookup_mind kn env in - check_hyps_inclusion env mkConstructU cu mib.mind_hyps + check_hyps_inclusion env (GlobRef.ConstructRef c) mib.mind_hyps in let specif = lookup_mind_specif env (inductive_of_constructor c) in let t,cst = constrained_type_of_constructor cu specif in diff --git a/kernel/typeops.mli b/kernel/typeops.mli index ae816fe26e..f88bc653de 100644 --- a/kernel/typeops.mli +++ b/kernel/typeops.mli @@ -111,7 +111,7 @@ val type_of_global_in_context : env -> GlobRef.t -> types * Univ.AUContext.t (** Check that hyps are included in env and fails with error otherwise *) val check_hyps_inclusion : env -> ?evars:((existential->constr option) * UGraph.t) -> - ('a -> constr) -> 'a -> Constr.named_context -> unit + GlobRef.t -> Constr.named_context -> unit val check_primitive_type : env -> CPrimitives.op_or_type -> types -> unit diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml index 33336079bb..4d15ce741c 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -128,7 +128,7 @@ let enforce_leq_alg u v g = | exception (UniverseInconsistency _ as e) -> Inr e) in (* max(us) <= max(vs) <-> forall u in us, exists v in vs, u <= v *) - let c = Universe.map (fun u -> Universe.map (fun v -> (u,v)) v) u in + let c = List.map (fun u -> List.map (fun v -> (u,v)) (Universe.repr v)) (Universe.repr u) in let c = List.cartesians enforce_one (Inl (Constraint.empty,g)) c in (* We pick a best constraint: smallest number of constraints, not an error if possible. *) let order x y = match x, y with diff --git a/kernel/univ.ml b/kernel/univ.ml index 0712774576..94f7076c02 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -42,6 +42,8 @@ struct let make dp i = (DirPath.hcons dp,i) + let repr x : t = x + let equal (d, i) (d', i') = DirPath.equal d d' && Int.equal i i' let hash (d,i) = Hashset.Combine.combine i (DirPath.hash d) @@ -320,8 +322,9 @@ struct if u == v then 0 else let (x, n) = u and (x', n') = v in - if Int.equal n n' then Level.compare x x' - else n - n' + let c = Int.compare n n' in + if Int.equal 0 c then Level.compare x x' + else c let sprop = hcons (Level.sprop, 0) let prop = hcons (Level.prop, 0) @@ -427,6 +430,10 @@ struct let hcons = Hashcons.recursive_hcons Huniv.generate Huniv.hcons Expr.hcons + module Self = struct type nonrec t = t let compare = compare end + module Map = CMap.Make(Self) + module Set = CSet.Make(Self) + let make l = tip (Expr.make l) let tip x = tip x @@ -524,15 +531,10 @@ struct Used to type the products. *) let sup x y = merge_univs x y - let empty = [] - let exists = List.exists let for_all = List.for_all - - let smart_map = List.Smart.map - - let map = List.map + let repr x : t = x end type universe = Universe.t @@ -550,8 +552,6 @@ let pr_uni = Universe.pr let sup = Universe.sup let super = Universe.super -open Universe - let universe_level = Universe.level @@ -576,7 +576,7 @@ type univ_inconsistency = constraint_type * universe * universe * explanation La exception UniverseInconsistency of univ_inconsistency let error_inconsistency o u v p = - raise (UniverseInconsistency (o,make u,make v,p)) + raise (UniverseInconsistency (o,Universe.make u,Universe.make v,p)) (* Constraints and sets of constraints. *) @@ -677,7 +677,7 @@ let enforce_eq u v c = let constraint_add_leq v u c = (* We just discard trivial constraints like u<=u *) - if Expr.equal v u then c + if Universe.Expr.equal v u then c else match v, u with | (x,n), (y,m) -> @@ -695,13 +695,13 @@ let constraint_add_leq v u c = else if Level.is_small x then c (* Prop,Set <= u+S k, trivial *) else Constraint.add (x,Le,y) c (* u <= v implies u <= v+k *) -let check_univ_leq_one u v = Universe.exists (Expr.leq u) v +let check_univ_leq_one u v = Universe.exists (Universe.Expr.leq u) v let check_univ_leq u v = Universe.for_all (fun u -> check_univ_leq_one u v) u let enforce_leq u v c = - match is_sprop u, is_sprop v with + match Universe.is_sprop u, Universe.is_sprop v with | true, true -> c | true, false | false, true -> raise (UniverseInconsistency (Le, u, v, None)) @@ -925,7 +925,7 @@ let subst_instance_instance s i = let subst_instance_universe s u = let f x = Universe.Expr.map (fun u -> subst_instance_level s u) x in - let u' = Universe.smart_map f u in + let u' = List.Smart.map f u in if u == u' then u else Universe.sort u' @@ -1108,7 +1108,7 @@ let subst_univs_level_level subst l = let subst_univs_level_universe subst u = let f x = Universe.Expr.map (fun u -> subst_univs_level_level subst u) x in - let u' = Universe.smart_map f u in + let u' = List.Smart.map f u in if u == u' then u else Universe.sort u' @@ -1150,7 +1150,7 @@ let subst_univs_universe fn ul = if CList.is_empty subst then ul else let substs = - List.fold_left Universe.merge_univs Universe.empty subst + List.fold_left Universe.merge_univs [] subst in List.fold_left (fun acc u -> Universe.merge_univs acc (Universe.tip u)) substs nosubst diff --git a/kernel/univ.mli b/kernel/univ.mli index f7c984870f..94e57b9efc 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -16,6 +16,7 @@ sig type t val make : Names.DirPath.t -> int -> t + val repr : t -> Names.DirPath.t * int val equal : t -> t -> bool val hash : t -> int val compare : t -> t -> int @@ -138,8 +139,10 @@ sig val exists : (Level.t * int -> bool) -> t -> bool val for_all : (Level.t * int -> bool) -> t -> bool + val repr : t -> (Level.t * int) list - val map : (Level.t * int -> 'a) -> t -> 'a list + module Set : CSet.S with type elt = t + module Map : CMap.ExtS with type key = t and module Set := Set end diff --git a/lib/cErrors.ml b/lib/cErrors.ml index b9735d0579..9f496f5845 100644 --- a/lib/cErrors.ml +++ b/lib/cErrors.ml @@ -12,7 +12,7 @@ open Pp (** Aliases *) -let push = Backtrace.add_backtrace +let push = Exninfo.capture (* Errors *) @@ -51,12 +51,10 @@ let raw_anomaly e = match e with | _ -> str "Uncaught exception " ++ str (Printexc.to_string e) ++ str "." -let print_backtrace e = match Backtrace.get_backtrace e with +let print_backtrace e = match Exninfo.get_backtrace e with | None -> mt () | Some bt -> - let bt = Backtrace.repr bt in - let pr_frame f = str (Backtrace.print_frame f) in - let bt = prlist_with_sep fnl pr_frame bt in + let bt = str (Exninfo.backtrace_to_string bt) in fnl () ++ hov 0 bt let print_anomaly askreport e = diff --git a/lib/control.ml b/lib/control.ml index 7d54838df8..e67e88ee95 100644 --- a/lib/control.ml +++ b/lib/control.ml @@ -38,7 +38,7 @@ let unix_timeout n f x e = restore_timeout (); res with e -> - let e = Backtrace.add_backtrace e in + let e = Exninfo.capture e in restore_timeout (); Exninfo.iraise e @@ -76,7 +76,7 @@ let windows_timeout n f x e = else raise e | e -> let () = killed := true in - let e = Backtrace.add_backtrace e in + let e = Exninfo.capture e in Exninfo.iraise e type timeout = { timeout : 'a 'b. int -> ('a -> 'b) -> 'a -> exn -> 'b } @@ -102,7 +102,7 @@ let protect_sigalrm f x = | true, Sys.Signal_handle f -> f Sys.sigalrm; res | _, _ -> res with e -> - let e = Backtrace.add_backtrace e in + let e = Exninfo.capture e in Sys.set_signal Sys.sigalrm old_handler; Exninfo.iraise e with Invalid_argument _ -> (* This happens on Windows, as handling SIGALRM does not seem supported *) diff --git a/lib/flags.ml b/lib/flags.ml index b87ba46634..ad48024761 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -19,7 +19,7 @@ let with_modified_ref ?(restore=true) r nf f x = if restore || pre == !r then r := old_ref; res with reraise -> - let reraise = Backtrace.add_backtrace reraise in + let reraise = Exninfo.capture reraise in r := old_ref; Exninfo.iraise reraise @@ -37,7 +37,7 @@ let with_options ol f x = let r = f x in let () = List.iter2 (:=) ol vl in r with reraise -> - let reraise = Backtrace.add_backtrace reraise in + let reraise = Exninfo.capture reraise in let () = List.iter2 (:=) ol vl in Exninfo.iraise reraise @@ -203,7 +203,7 @@ let pp_with ft pp = in try pp_cmd pp with reraise -> - let reraise = Backtrace.add_backtrace reraise in + let reraise = Exninfo.capture reraise in let () = Format.pp_print_flush ft () in Exninfo.iraise reraise diff --git a/library/global.ml b/library/global.ml index fbbe09301b..8706238f5a 100644 --- a/library/global.ml +++ b/library/global.ml @@ -192,8 +192,6 @@ let is_polymorphic r = Environ.is_polymorphic (env()) r let is_template_polymorphic r = is_template_polymorphic (env ()) r -let is_template_checked r = is_template_checked (env ()) r - let get_template_polymorphic_variables r = get_template_polymorphic_variables (env ()) r let is_type_in_type r = is_type_in_type (env ()) r diff --git a/library/global.mli b/library/global.mli index a38fde41a5..0198ac5952 100644 --- a/library/global.mli +++ b/library/global.mli @@ -47,8 +47,8 @@ val push_named_def : (Id.t * Entries.section_def_entry) -> unit val push_section_context : (Name.t array * Univ.UContext.t) -> unit val export_private_constants : - Safe_typing.private_constants Entries.proof_output -> - Constr.constr Univ.in_universe_context_set * Safe_typing.exported_private_constant list + Safe_typing.private_constants -> + Safe_typing.exported_private_constant list val add_constant : Id.t -> Safe_typing.global_declaration -> Constant.t @@ -150,7 +150,6 @@ val is_joined_environment : unit -> bool val is_polymorphic : GlobRef.t -> bool val is_template_polymorphic : GlobRef.t -> bool -val is_template_checked : GlobRef.t -> bool val get_template_polymorphic_variables : GlobRef.t -> Univ.Level.t list val is_type_in_type : GlobRef.t -> bool diff --git a/library/globnames.ml b/library/globnames.ml index acb05f9ac0..e55a7b5499 100644 --- a/library/globnames.ml +++ b/library/globnames.ml @@ -73,13 +73,7 @@ let global_of_constr c = match kind c with | Var id -> VarRef id | _ -> raise Not_found -let is_global c t = - match c, kind t with - | ConstRef c, Const (c', _) -> Constant.equal c c' - | IndRef i, Ind (i', _) -> eq_ind i i' - | ConstructRef i, Construct (i', _) -> eq_constructor i i' - | VarRef id, Var id' -> Id.equal id id' - | _ -> false +let is_global = Constr.isRefX let printable_constr_of_global = function | VarRef id -> mkVar id @@ -123,7 +117,3 @@ module ExtRefOrdered = struct | SynDef kn -> combinesmall 2 (KerName.hash kn) end - -type global_reference_or_constr = - | IsGlobal of GlobRef.t - | IsConstr of constr diff --git a/library/globnames.mli b/library/globnames.mli index 48cbb11b66..fb59cbea4e 100644 --- a/library/globnames.mli +++ b/library/globnames.mli @@ -32,6 +32,7 @@ val destIndRef : GlobRef.t -> inductive val destConstructRef : GlobRef.t -> constructor val is_global : GlobRef.t -> constr -> bool +[@@ocaml.deprecated "Use [Constr.isRefX] instead."] val subst_constructor : substitution -> constructor -> constructor val subst_global : substitution -> GlobRef.t -> GlobRef.t * constr Univ.univ_abstracted option @@ -44,6 +45,7 @@ val printable_constr_of_global : GlobRef.t -> constr (** Turn a construction denoting a global reference into a global reference; raise [Not_found] if not a global reference *) val global_of_constr : constr -> GlobRef.t +[@@ocaml.deprecated "Use [Constr.destRef] instead (throws DestKO instead of Not_found)."] (** {6 Extended global references } *) @@ -59,7 +61,3 @@ module ExtRefOrdered : sig val equal : t -> t -> bool val hash : t -> int end - -type global_reference_or_constr = - | IsGlobal of GlobRef.t - | IsConstr of constr diff --git a/library/goptions.ml b/library/goptions.ml index 6e53bed349..616f6edf72 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -27,7 +27,6 @@ type option_value = (** Summary of an option status *) type option_state = { opt_depr : bool; - opt_name : string; opt_value : option_value; } @@ -190,7 +189,6 @@ module MakeRefTable = type 'a option_sig = { optdepr : bool; - optname : string; optkey : option_name; optread : unit -> 'a; optwrite : 'a -> unit } @@ -229,7 +227,7 @@ let warn_deprecated_option = strbrk " is deprecated") let declare_option cast uncast append ?(preprocess = fun x -> x) - { optdepr=depr; optname=name; optkey=key; optread=read; optwrite=write } = + { optdepr=depr; optkey=key; optread=read; optwrite=write } = check_key key; let default = read() in let change = @@ -275,7 +273,7 @@ let declare_option cast uncast append ?(preprocess = fun x -> x) let cread () = cast (read ()) in let cwrite l v = warn (); change l OptSet (uncast v) in let cappend l v = warn (); change l OptAppend (uncast v) in - value_tab := OptionMap.add key (name, depr, (cread,cwrite,cappend)) !value_tab + value_tab := OptionMap.add key (depr, (cread,cwrite,cappend)) !value_tab let declare_int_option = declare_option @@ -298,13 +296,12 @@ let declare_stringopt_option = (function StringOptValue v -> v | _ -> anomaly (Pp.str "async_option.")) (fun _ _ -> anomaly (Pp.str "async_option.")) -let declare_bool_option_and_ref ~depr ~name ~key ~(value:bool) = +let declare_bool_option_and_ref ~depr ~key ~(value:bool) = let r_opt = ref value in let optwrite v = r_opt := v in let optread () = !r_opt in let _ = declare_bool_option { optdepr = depr; - optname = name; optkey = key; optread; optwrite } in @@ -323,7 +320,7 @@ let set_option_value ?(locality = OptDefault) check_and_cast key v = let opt = try Some (get_option key) with Not_found -> None in match opt with | None -> warn_unknown_option key - | Some (name, depr, (read,write,append)) -> + | Some (depr, (read,write,append)) -> write locality (check_and_cast v (read ())) let show_value_type = function @@ -373,7 +370,7 @@ let set_string_option_append_value_gen ?(locality = OptDefault) key v = let opt = try Some (get_option key) with Not_found -> None in match opt with | None -> warn_unknown_option key - | Some (name, depr, (read,write,append)) -> + | Some (depr, (read,write,append)) -> append locality (check_string_value v (read ())) let set_int_option_value opt v = set_int_option_value_gen opt v @@ -382,7 +379,7 @@ let set_string_option_value opt v = set_string_option_value_gen opt v (* Printing options/tables *) -let msg_option_value (name,v) = +let msg_option_value v = match v with | BoolValue true -> str "on" | BoolValue false -> str "off" @@ -394,19 +391,18 @@ let msg_option_value (name,v) = (* | IdentValue r -> pr_global_env Id.Set.empty r *) let print_option_value key = - let (name, depr, (read,_,_)) = get_option key in + let (depr, (read,_,_)) = get_option key in let s = read () in match s with | BoolValue b -> - Feedback.msg_notice (str "The " ++ str name ++ str " mode is " ++ str (if b then "on" else "off")) + Feedback.msg_notice (prlist_with_sep spc str key ++ str " is " ++ str (if b then "on" else "off")) | _ -> - Feedback.msg_notice (str "Current value of " ++ str name ++ str " is " ++ msg_option_value (name, s)) + Feedback.msg_notice (str "Current value of " ++ prlist_with_sep spc str key ++ str " is " ++ msg_option_value s) let get_tables () = let tables = !value_tab in - let fold key (name, depr, (read,_,_)) accu = + let fold key (depr, (read,_,_)) accu = let state = { - opt_name = name; opt_depr = depr; opt_value = read (); } in @@ -415,15 +411,15 @@ let get_tables () = OptionMap.fold fold tables OptionMap.empty let print_tables () = - let print_option key name value depr = - let msg = str " " ++ str (nickname key) ++ str ": " ++ msg_option_value (name, value) in + let print_option key value depr = + let msg = str " " ++ str (nickname key) ++ str ": " ++ msg_option_value value in if depr then msg ++ str " [DEPRECATED]" ++ fnl () else msg ++ fnl () in str "Options:" ++ fnl () ++ OptionMap.fold - (fun key (name, depr, (read,_,_)) p -> - p ++ print_option key name (read ()) depr) + (fun key (depr, (read,_,_)) p -> + p ++ print_option key (read ()) depr) !value_tab (mt ()) ++ str "Tables:" ++ fnl () ++ List.fold_right diff --git a/library/goptions.mli b/library/goptions.mli index 29af196654..e3791dffb1 100644 --- a/library/goptions.mli +++ b/library/goptions.mli @@ -111,8 +111,6 @@ end type 'a option_sig = { optdepr : bool; (** whether the option is DEPRECATED *) - optname : string; - (** a short string describing the option *) optkey : option_name; (** the low-level name of this option *) optread : unit -> 'a; @@ -133,7 +131,7 @@ val declare_stringopt_option: ?preprocess:(string option -> string option) -> (** Helper to declare a reference controlled by an option. Read-only as to avoid races. *) -val declare_bool_option_and_ref : depr:bool -> name:string -> key:option_name -> value:bool -> (unit -> bool) +val declare_bool_option_and_ref : depr:bool -> key:option_name -> value:bool -> (unit -> bool) (** {6 Special functions supposed to be used only in vernacentries.ml } *) @@ -181,7 +179,6 @@ val set_option_value : ?locality:option_locality -> (** Summary of an option status *) type option_state = { opt_depr : bool; - opt_name : string; opt_value : option_value; } diff --git a/library/lib.ml b/library/lib.ml index 9cce9b92ad..7f96adeecf 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -500,7 +500,7 @@ let close_section () = type frozen = lib_state -let freeze ~marshallable = !lib_state +let freeze () = !lib_state let unfreeze st = lib_state := st diff --git a/library/lib.mli b/library/lib.mli index 0d03046dc2..1fe72389f6 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -151,7 +151,7 @@ val close_section : unit -> unit type frozen -val freeze : marshallable:bool -> frozen +val freeze : unit -> frozen val unfreeze : frozen -> unit (** Keep only the libobject structure, not the objects themselves *) diff --git a/library/libobject.ml b/library/libobject.ml index c9ea6bcff8..28d0654444 100644 --- a/library/libobject.ml +++ b/library/libobject.ml @@ -82,8 +82,6 @@ and objects = (Names.Id.t * t) list and substitutive_objects = MBId.t list * algebraic_objects -let object_tag (Dyn.Dyn (t, _)) = Dyn.repr t - module DynMap = Dyn.Map (struct type 'a t = 'a object_declaration end) let cache_tab = ref DynMap.empty @@ -92,14 +90,12 @@ let declare_object_full odecl = let na = odecl.object_name in let tag = Dyn.create na in let () = cache_tab := DynMap.add tag odecl !cache_tab in - let infun v = Dyn.Dyn (tag, v) in - let outfun v = match Dyn.Easy.prj v tag with - | None -> assert false - | Some v -> v - in - (infun,outfun) + tag -let declare_object odecl = fst (declare_object_full odecl) +let declare_object odecl = + let tag = declare_object_full odecl in + let infun v = Dyn.Dyn (tag, v) in + infun let cache_object (sp, Dyn.Dyn (tag, v)) = let decl = DynMap.find tag !cache_tab in diff --git a/library/libobject.mli b/library/libobject.mli index 146ccc293f..c25345994a 100644 --- a/library/libobject.mli +++ b/library/libobject.mli @@ -101,7 +101,9 @@ val ident_subst_function : substitution * 'a -> 'a will hand back two functions, the "injection" and "projection" functions for dynamically typed library-objects. *) -type obj +module Dyn : Dyn.S + +type obj = Dyn.t type algebraic_objects = | Objs of objects @@ -120,13 +122,11 @@ and objects = (Names.Id.t * t) list and substitutive_objects = Names.MBId.t list * algebraic_objects val declare_object_full : - 'a object_declaration -> ('a -> obj) * (obj -> 'a) + 'a object_declaration -> 'a Dyn.tag val declare_object : 'a object_declaration -> ('a -> obj) -val object_tag : obj -> string - val cache_object : object_name * obj -> unit val load_object : int -> object_name * obj -> unit val open_object : int -> object_name * obj -> unit diff --git a/library/states.ml b/library/states.ml index 0be153d96a..90303a2a5c 100644 --- a/library/states.ml +++ b/library/states.ml @@ -18,7 +18,7 @@ let replace_summary (lib,_) st = lib, st let replace_lib (_,st) lib = lib, st let freeze ~marshallable = - (Lib.freeze ~marshallable, Summary.freeze_summaries ~marshallable) + (Lib.freeze (), Summary.freeze_summaries ~marshallable) let unfreeze (fl,fs) = Lib.unfreeze fl; diff --git a/man/coqdep.1 b/man/coqdep.1 index 02c9d4390c..4223482c99 100644 --- a/man/coqdep.1 +++ b/man/coqdep.1 @@ -6,9 +6,6 @@ coqdep \- Compute inter-module dependencies for Coq and Caml programs .SH SYNOPSIS .B coqdep [ -.BI \-w -] -[ .BI \-I \ directory ] [ @@ -21,9 +18,6 @@ coqdep \- Compute inter-module dependencies for Coq and Caml programs .BI \-i ] [ -.BI \-D -] -[ .BI \-slash ] .I filename ... @@ -61,25 +55,6 @@ directives and the dot notation .BI \-c Prints the dependencies of Caml modules. (On Caml modules, the behaviour is exactly the same as ocamldep). -\" THESE OPTIONS ARE BROKEN CURRENTLY -\" .TP -\" .BI \-w -\" Prints a warning if a Coq command -\" .IR Declare \& -\" .IR ML \& -\" .IR Module \& -\" is incorrect. (For instance, you wrote `Declare ML Module "A".', -\" but the module A contains #open "B"). The correct command is printed -\" (see option \-D). The warning is printed on standard error. -\" .TP -\" .BI \-D -\" This commands looks for every command -\" .IR Declare \& -\" .IR ML \& -\" .IR Module \& -\" of each Coq file given as argument and complete (if needed) -\" the list of Caml modules. The new command is printed on -\" the standard output. No dependency is computed with this option. .TP .BI \-f \ file Read filenames and options -I, -R and -Q from a _CoqProject FILE. @@ -93,10 +68,6 @@ Indicates where is the Coq library. The default value has been determined at installation time, and therefore this option should not be used under normal circumstances. .TP -.BI \-dumpgraph[box] \ file -Dumps a dot dependency graph in file -.IR file \&. -.TP .BI \-exclude-dir \ dir Skips subdirectory .IR dir \ during @@ -169,7 +140,7 @@ example% coqdep \-I . *.v With a warning: .IP .B -example% coqdep \-w \-I . *.v +example% coqdep \-I . *.v .RS .sp .5 .nf diff --git a/parsing/g_constr.mlg b/parsing/g_constr.mlg index af1e973261..dcc3a87b11 100644 --- a/parsing/g_constr.mlg +++ b/parsing/g_constr.mlg @@ -205,7 +205,7 @@ GRAMMAR EXTEND Gram | "{"; c = binder_constr ; "}" -> { CAst.make ~loc @@ CNotation((InConstrEntrySomeLevel,"{ _ }"),([c],[],[],[])) } | "`{"; c = operconstr LEVEL "200"; "}" -> - { CAst.make ~loc @@ CGeneralization (Implicit, None, c) } + { CAst.make ~loc @@ CGeneralization (MaxImplicit, None, c) } | "`("; c = operconstr LEVEL "200"; ")" -> { CAst.make ~loc @@ CGeneralization (Explicit, None, c) } ] ] ; @@ -431,17 +431,27 @@ GRAMMAR EXTEND Gram | "("; id = name; ":"; t = lconstr; ":="; c = lconstr; ")" -> { [CLocalDef (id,c,Some t)] } | "{"; id = name; "}" -> - { [CLocalAssum ([id],Default Implicit, CAst.make ~loc @@ CHole (None, IntroAnonymous, None))] } + { [CLocalAssum ([id],Default MaxImplicit, CAst.make ~loc @@ CHole (None, IntroAnonymous, None))] } | "{"; id = name; idl = LIST1 name; ":"; c = lconstr; "}" -> - { [CLocalAssum (id::idl,Default Implicit,c)] } + { [CLocalAssum (id::idl,Default MaxImplicit,c)] } | "{"; id = name; ":"; c = lconstr; "}" -> - { [CLocalAssum ([id],Default Implicit,c)] } + { [CLocalAssum ([id],Default MaxImplicit,c)] } | "{"; id = name; idl = LIST1 name; "}" -> - { List.map (fun id -> CLocalAssum ([id],Default Implicit, CAst.make ~loc @@ CHole (None, IntroAnonymous, None))) (id::idl) } + { List.map (fun id -> CLocalAssum ([id],Default MaxImplicit, CAst.make ~loc @@ CHole (None, IntroAnonymous, None))) (id::idl) } + | "["; id = name; "]" -> + { [CLocalAssum ([id],Default NonMaxImplicit, CAst.make ~loc @@ CHole (None, IntroAnonymous, None))] } + | "["; id = name; idl = LIST1 name; ":"; c = lconstr; "]" -> + { [CLocalAssum (id::idl,Default NonMaxImplicit,c)] } + | "["; id = name; ":"; c = lconstr; "]" -> + { [CLocalAssum ([id],Default NonMaxImplicit,c)] } + | "["; id = name; idl = LIST1 name; "]" -> + { List.map (fun id -> CLocalAssum ([id],Default NonMaxImplicit, CAst.make ~loc @@ CHole (None, IntroAnonymous, None))) (id::idl) } | "`("; tc = LIST1 typeclass_constraint SEP "," ; ")" -> { List.map (fun (n, b, t) -> CLocalAssum ([n], Generalized (Explicit, b), t)) tc } | "`{"; tc = LIST1 typeclass_constraint SEP "," ; "}" -> - { List.map (fun (n, b, t) -> CLocalAssum ([n], Generalized (Implicit, b), t)) tc } + { List.map (fun (n, b, t) -> CLocalAssum ([n], Generalized (MaxImplicit, b), t)) tc } + | "`["; tc = LIST1 typeclass_constraint SEP "," ; "]" -> + { List.map (fun (n, b, t) -> CLocalAssum ([n], Generalized (NonMaxImplicit, b), t)) tc } | "'"; p = pattern LEVEL "0" -> { let (p, ty) = match p.CAst.v with diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 500f464ea7..f9078c4bdc 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -33,7 +33,6 @@ let debug x = let () = let gdopt= { optdepr=false; - optname="Congruence Verbose"; optkey=["Congruence";"Verbose"]; optread=(fun ()-> !cc_verbose); optwrite=(fun b -> cc_verbose := b)} @@ -492,7 +491,7 @@ let rec add_term state t= Not_found -> let b=next uf in let trm = constr_of_term t in - let typ = Typing.unsafe_type_of state.env state.sigma (EConstr.of_constr trm) in + let typ = Retyping.get_type_of state.env state.sigma (EConstr.of_constr trm) in let typ = canonize_name state.sigma typ in let new_node= match t with @@ -809,23 +808,23 @@ let new_state_var typ state = let complete_one_class state i= match (get_representative state.uf i).inductive_status with - Partial pac -> - let rec app t typ n = - if n<=0 then t else - let _,etyp,rest= destProd typ in - let id = new_state_var (EConstr.of_constr etyp) state in - app (Appli(t,Eps id)) (substl [mkVar id] rest) (n-1) in - let _c = Typing.unsafe_type_of state.env state.sigma - (EConstr.of_constr (constr_of_term (term state.uf pac.cnode))) in - let _c = EConstr.Unsafe.to_constr _c in - let _args = - List.map (fun i -> constr_of_term (term state.uf i)) - pac.args in - let typ = Term.prod_applist _c (List.rev _args) in - let ct = app (term state.uf i) typ pac.arity in - state.uf.epsilons <- pac :: state.uf.epsilons; - ignore (add_term state ct) - | _ -> anomaly (Pp.str "wrong incomplete class.") + | Partial pac -> + let rec app t typ n = + if n<=0 then t else + let _,etyp,rest= destProd typ in + let id = new_state_var (EConstr.of_constr etyp) state in + app (Appli(t,Eps id)) (substl [mkVar id] rest) (n-1) in + let c = Retyping.get_type_of state.env state.sigma + (EConstr.of_constr (constr_of_term (term state.uf pac.cnode))) in + let c = EConstr.Unsafe.to_constr c in + let args = + List.map (fun i -> constr_of_term (term state.uf i)) + pac.args in + let typ = Term.prod_applist c (List.rev args) in + let ct = app (term state.uf i) typ pac.arity in + state.uf.epsilons <- pac :: state.uf.epsilons; + ignore (add_term state ct) + | _ -> anomaly (Pp.str "wrong incomplete class.") let complete state = Int.Set.iter (complete_one_class state) state.pa_classes diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 556e6b48e6..9ea2224272 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -90,14 +90,13 @@ let rec decompose_term env sigma t= if closed0 sigma t then Symb (EConstr.to_constr ~abort_on_undefined_evars:false sigma t) else raise Not_found (* decompose equality in members and type *) -open Termops let atom_of_constr env sigma term = let wh = whd_delta env sigma term in let kot = EConstr.kind sigma wh in match kot with App (f,args)-> - if is_global sigma (Lazy.force _eq) f && Int.equal (Array.length args) 3 + if isRefX sigma (Lazy.force _eq) f && Int.equal (Array.length args) 3 then `Eq (args.(0), decompose_term env sigma args.(1), decompose_term env sigma args.(2)) @@ -132,7 +131,7 @@ let non_trivial = function let patterns_of_constr env sigma nrels term= let f,args= try destApp sigma (whd_delta env sigma term) with DestKO -> raise Not_found in - if is_global sigma (Lazy.force _eq) f && Int.equal (Array.length args) 3 + if isRefX sigma (Lazy.force _eq) f && Int.equal (Array.length args) 3 then let patt1,rels1 = pattern_of_constr env sigma args.(1) and patt2,rels2 = pattern_of_constr env sigma args.(2) in @@ -153,7 +152,7 @@ let patterns_of_constr env sigma nrels term= let rec quantified_atom_of_constr env sigma nrels term = match EConstr.kind sigma (whd_delta env sigma term) with Prod (id,atom,ff) -> - if is_global sigma (Lazy.force _False) ff then + if isRefX sigma (Lazy.force _False) ff then let patts=patterns_of_constr env sigma nrels atom in `Nrule patts else @@ -165,7 +164,7 @@ let rec quantified_atom_of_constr env sigma nrels term = let litteral_of_constr env sigma term= match EConstr.kind sigma (whd_delta env sigma term) with | Prod (id,atom,ff) -> - if is_global sigma (Lazy.force _False) ff then + if isRefX sigma (Lazy.force _False) ff then match (atom_of_constr env sigma atom) with `Eq(t,a,b) -> `Neq(t,a,b) | `Other(p) -> `Nother(p) @@ -277,10 +276,12 @@ let refresh_type env evm ty = Evarsolve.refresh_universes ~status:Evd.univ_flexible ~refreshset:true (Some false) env evm ty -let refresh_universes ty k = +let type_and_refresh c k = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let evm = Tacmach.New.project gl in + (* XXX is get_type_of enough? *) + let evm, ty = Typing.type_of env evm c in let evm, ty = refresh_type env evm ty in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evm) (k ty) end @@ -289,7 +290,6 @@ let constr_of_term c = EConstr.of_constr (constr_of_term c) let rec proof_tac p : unit Proofview.tactic = Proofview.Goal.enter begin fun gl -> - let type_of t = Tacmach.New.pf_unsafe_type_of gl t in try (* type_of can raise exceptions *) match p.p_rule with Ax c -> exact_check (EConstr.of_constr c) @@ -297,17 +297,17 @@ let rec proof_tac p : unit Proofview.tactic = let c = EConstr.of_constr c in let l=constr_of_term p.p_lhs and r=constr_of_term p.p_rhs in - refresh_universes (type_of l) (fun typ -> + type_and_refresh l (fun typ -> app_global _sym_eq [|typ;r;l;c|] exact_check) | Refl t -> let lr = constr_of_term t in - refresh_universes (type_of lr) (fun typ -> + type_and_refresh lr (fun typ -> app_global _refl_equal [|typ;constr_of_term t|] exact_check) | Trans (p1,p2)-> let t1 = constr_of_term p1.p_lhs and t2 = constr_of_term p1.p_rhs and t3 = constr_of_term p2.p_rhs in - refresh_universes (type_of t2) (fun typ -> + type_and_refresh t2 (fun typ -> let prf = app_global_with_holes _trans_eq [|typ;t1;t2;t3;|] 2 in Tacticals.New.tclTHENS prf [(proof_tac p1);(proof_tac p2)]) | Congr (p1,p2)-> @@ -315,9 +315,9 @@ let rec proof_tac p : unit Proofview.tactic = and tx1=constr_of_term p2.p_lhs and tf2=constr_of_term p1.p_rhs and tx2=constr_of_term p2.p_rhs in - refresh_universes (type_of tf1) (fun typf -> - refresh_universes (type_of tx1) (fun typx -> - refresh_universes (type_of (mkApp (tf1,[|tx1|]))) (fun typfx -> + type_and_refresh tf1 (fun typf -> + type_and_refresh tx1 (fun typx -> + type_and_refresh (mkApp (tf1,[|tx1|])) (fun typfx -> let id = Tacmach.New.pf_get_new_id (Id.of_string "f") gl in let appx1 = mkLambda(make_annot (Name id) Sorts.Relevant,typf,mkApp(mkRel 1,[|tx1|])) in let lemma1 = app_global_with_holes _f_equal [|typf;typfx;appx1;tf1;tf2|] 1 in @@ -341,8 +341,8 @@ let rec proof_tac p : unit Proofview.tactic = let tj=constr_of_term prf.p_rhs in let default=constr_of_term p.p_lhs in let special=mkRel (1+nargs-argind) in - refresh_universes (type_of ti) (fun intype -> - refresh_universes (type_of default) (fun outtype -> + type_and_refresh ti (fun intype -> + type_and_refresh default (fun outtype -> let sigma, proj = build_projection intype cstr special default gl in @@ -362,7 +362,7 @@ let refute_tac c t1 t2 p = let neweq= app_global _eq [|intype;tt1;tt2|] in Tacticals.New.tclTHENS (neweq (assert_before (Name hid))) [proof_tac p; simplest_elim false_t] - in refresh_universes (Tacmach.New.pf_unsafe_type_of gl tt1) k + in type_and_refresh tt1 k end let refine_exact_check c = @@ -382,7 +382,7 @@ let convert_to_goal_tac c t1 t2 p = let endt = app_global _eq_rect [|sort;tt1;identity;c;tt2;mkVar e|] in Tacticals.New.tclTHENS (neweq (assert_before (Name e))) [proof_tac p; endt refine_exact_check] - in refresh_universes (Tacmach.New.pf_unsafe_type_of gl tt2) k + in type_and_refresh tt2 k end let convert_to_hyp_tac c1 t1 c2 t2 p = @@ -401,7 +401,8 @@ let discriminate_tac cstru p = let lhs=constr_of_term p.p_lhs and rhs=constr_of_term p.p_rhs in let env = Proofview.Goal.env gl in let evm = Tacmach.New.project gl in - let evm, intype = refresh_type env evm (Tacmach.New.pf_unsafe_type_of gl lhs) in + let evm, intype = Typing.type_of env evm lhs in + let evm, intype = refresh_type env evm intype in let hid = Tacmach.New.pf_get_new_id (Id.of_string "Heq") gl in let neweq=app_global _eq [|intype;lhs;rhs|] in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS evm) @@ -515,7 +516,7 @@ let f_equal = in Proofview.tclORELSE begin match EConstr.kind sigma concl with - | App (r,[|_;t;t'|]) when is_global sigma (Lazy.force _eq) r -> + | App (r,[|_;t;t'|]) when isRefX sigma (Lazy.force _eq) r -> begin match EConstr.kind sigma t, EConstr.kind sigma t' with | App (f,v), App (f',v') when Int.equal (Array.length v) (Array.length v') -> let rec cuts i = diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 35110552ab..853be82eb8 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -27,32 +27,7 @@ open Common (***************************************) let toplevel_env () = - let get_reference = function - | (_,kn), Lib.Leaf Libobject.AtomicObject o -> - let mp,l = KerName.repr kn in - begin match Libobject.object_tag o with - | "CONSTANT" -> - let constant = Global.lookup_constant (Constant.make1 kn) in - Some (l, SFBconst constant) - | "INDUCTIVE" -> - let inductive = Global.lookup_mind (MutInd.make1 kn) in - Some (l, SFBmind inductive) - | _ -> None - end - | (_,kn), Lib.Leaf Libobject.ModuleObject _ -> - let mp,l = KerName.repr kn in - let modl = Global.lookup_module (MPdot (mp, l)) in - Some (l, SFBmodule modl) - | (_,kn), Lib.Leaf Libobject.ModuleTypeObject _ -> - let mp,l = KerName.repr kn in - let modtype = Global.lookup_modtype (MPdot (mp, l)) in - Some (l, SFBmodtype modtype) - | (_,kn), Lib.Leaf Libobject.IncludeObject _ -> - user_err Pp.(str "No extraction of toplevel Include yet.") - | _ -> None - in - List.rev (List.map_filter get_reference (Lib.contents ())) - + List.rev (Safe_typing.structure_body_of_safe_env (Global.safe_env ())) let environment_until dir_opt = let rec parse = function diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index 7b64706138..9d07cd7d93 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -503,7 +503,6 @@ let my_bool_option name initval = let access = fun () -> !flag in let () = declare_bool_option {optdepr = false; - optname = "Extraction "^name; optkey = ["Extraction"; name]; optread = access; optwrite = (:=) flag } @@ -575,14 +574,12 @@ let optims () = !opt_flag_ref let () = declare_bool_option {optdepr = false; - optname = "Extraction Optimize"; optkey = ["Extraction"; "Optimize"]; optread = (fun () -> not (Int.equal !int_flag_ref 0)); optwrite = (fun b -> chg_flag (if b then int_flag_init else 0))} let () = declare_int_option { optdepr = false; - optname = "Extraction Flag"; optkey = ["Extraction";"Flag"]; optread = (fun _ -> Some !int_flag_ref); optwrite = (function @@ -596,7 +593,6 @@ let conservative_types () = !conservative_types_ref let () = declare_bool_option {optdepr = false; - optname = "Extraction Conservative Types"; optkey = ["Extraction"; "Conservative"; "Types"]; optread = (fun () -> !conservative_types_ref); optwrite = (fun b -> conservative_types_ref := b) } @@ -608,7 +604,6 @@ let file_comment () = !file_comment_ref let () = declare_string_option {optdepr = false; - optname = "Extraction File Comment"; optkey = ["Extraction"; "File"; "Comment"]; optread = (fun () -> !file_comment_ref); optwrite = (fun s -> file_comment_ref := s) } diff --git a/plugins/firstorder/g_ground.mlg b/plugins/firstorder/g_ground.mlg index 8946587a02..930801f6fd 100644 --- a/plugins/firstorder/g_ground.mlg +++ b/plugins/firstorder/g_ground.mlg @@ -36,7 +36,6 @@ let ground_depth=ref 3 let ()= let gdopt= { optdepr=false; - optname="Firstorder Depth"; optkey=["Firstorder";"Depth"]; optread=(fun ()->Some !ground_depth); optwrite= @@ -88,7 +87,7 @@ let gen_ground_tac flag taco ids bases = Proofview.Goal.enter begin fun gl -> let seq=empty_seq !ground_depth in let seq, sigma = extend_with_ref_list (pf_env gl) (project gl) ids seq in - let seq, sigma = extend_with_auto_hints (pf_env gl) (project gl) bases seq in + let seq, sigma = extend_with_auto_hints (pf_env gl) sigma bases seq in tclTHEN (Proofview.Unsafe.tclEVARS sigma) (k seq) end in diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index e131cad7da..866b45e4df 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -100,25 +100,28 @@ let rec collect_quantified sigma seq= let dummy_bvid=Id.of_string "x" -let mk_open_instance env evmap id idc m t = - let var_id= - if id==dummy_id then dummy_bvid else - let typ=Typing.unsafe_type_of env evmap idc in +let mk_open_instance env sigma id idc m t = + let var_id = + (* XXX why physical equality? *) + if id == dummy_id then dummy_bvid else + let typ = Retyping.get_type_of env sigma idc in (* since we know we will get a product, reduction is not too expensive *) - let (nam,_,_)=destProd evmap (whd_all env evmap typ) in + let (nam,_,_) = destProd sigma (whd_all env sigma typ) in match nam.Context.binder_name with - Name id -> id - | Anonymous -> dummy_bvid in - let revt=substl (List.init m (fun i->mkRel (m-i))) t in - let rec aux n avoid env evmap decls = - if Int.equal n 0 then evmap, decls else - let nid=(fresh_id_in_env avoid var_id env) in - let (evmap, (c, _)) = Evarutil.new_type_evar env evmap Evd.univ_flexible in + | Name id -> id + | Anonymous -> dummy_bvid + in + let revt = substl (List.init m (fun i->mkRel (m-i))) t in + let rec aux n avoid env sigma decls = + if Int.equal n 0 then sigma, decls else + let nid = fresh_id_in_env avoid var_id env in + let (sigma, (c, _)) = Evarutil.new_type_evar env sigma Evd.univ_flexible in let decl = LocalAssum (Context.make_annot (Name nid) Sorts.Relevant, c) in - aux (n-1) (Id.Set.add nid avoid) (EConstr.push_rel decl env) evmap (decl::decls) in - let evmap, decls = aux m Id.Set.empty env evmap [] in - (evmap, decls, revt) + aux (n-1) (Id.Set.add nid avoid) (EConstr.push_rel decl env) sigma (decl::decls) + in + let sigma, decls = aux m Id.Set.empty env sigma [] in + (sigma, decls, revt) (* tactics *) diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml index 7d84ee6851..c77ddeb040 100644 --- a/plugins/firstorder/sequent.ml +++ b/plugins/firstorder/sequent.ml @@ -204,28 +204,28 @@ let extend_with_ref_list env sigma l seq = open Hints let extend_with_auto_hints env sigma l seq = - let seqref=ref seq in - let f p_a_t = + let f (seq,sigma) p_a_t = match repr_hint p_a_t.code with - Res_pf (c,_) | Give_exact (c,_) - | Res_pf_THEN_trivial_fail (c,_) -> - let (c, _, _) = c in - (try - let (gr, _) = Termops.global_of_constr sigma c in - let typ=(Typing.unsafe_type_of env sigma c) in - seqref:=add_formula env sigma Hint gr typ !seqref - with Not_found->()) - | _-> () in - let g _ _ l = List.iter f l in - let h dbname= - let hdb= + | Res_pf (c,_) | Give_exact (c,_) + | Res_pf_THEN_trivial_fail (c,_) -> + let (c, _, _) = c in + (match EConstr.destRef sigma c with + | exception Constr.DestKO -> seq, sigma + | gr, _ -> + let sigma, typ = Typing.type_of env sigma c in + add_formula env sigma Hint gr typ seq, sigma) + | _ -> seq, sigma + in + let h acc dbname = + let hdb = try searchtable_map dbname with Not_found-> - user_err Pp.(str ("Firstorder: "^dbname^" : No such Hint database")) in - Hint_db.iter g hdb in - List.iter h l; - !seqref, sigma (*FIXME: forgetting about universes*) + user_err Pp.(str ("Firstorder: "^dbname^" : No such Hint database")) + in + Hint_db.fold (fun _ _ l acc -> List.fold_left f acc l) hdb acc + in + List.fold_left h (seq,sigma) l let print_cmap map= let print_entry c l s= diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 6db0a1119b..9749af1e66 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -475,7 +475,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = tclIDTAC in try - scan_type [] (Typing.unsafe_type_of env sigma (mkVar hyp_id)), [hyp_id] + scan_type [] (Typing.type_of_variable env hyp_id), [hyp_id] with TOREMOVE -> thin [hyp_id],[] @@ -525,7 +525,7 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = tclMAP (fun id -> Proofview.V82.of_tactic (introduction id)) dyn_infos.rec_hyps; observe_tac "after_introduction" (fun g' -> (* We get infos on the equations introduced*) - let new_term_value_eq = pf_unsafe_type_of g' (mkVar heq_id) in + let new_term_value_eq = pf_get_hyp_typ g' heq_id in (* compute the new value of the body *) let new_term_value = match EConstr.kind (project g') new_term_value_eq with @@ -536,22 +536,23 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = ); anomaly (Pp.str "cannot compute new term value.") in - let fun_body = - mkLambda(make_annot Anonymous Sorts.Relevant, - pf_unsafe_type_of g' term, - Termops.replace_term (project g') term (mkRel 1) dyn_infos.info - ) - in - let new_body = pf_nf_betaiota g' (mkApp(fun_body,[| new_term_value |])) in - let new_infos = - {dyn_infos with + let g', termtyp = tac_type_of g' term in + let fun_body = + mkLambda(make_annot Anonymous Sorts.Relevant, + termtyp, + Termops.replace_term (project g') term (mkRel 1) dyn_infos.info + ) + in + let new_body = pf_nf_betaiota g' (mkApp(fun_body,[| new_term_value |])) in + let new_infos = + {dyn_infos with info = new_body; eq_hyps = heq_id::dyn_infos.eq_hyps - } - in - clean_goal_with_heq ptes_infos continue_tac new_infos g' - )]) - ] + } + in + clean_goal_with_heq ptes_infos continue_tac new_infos g' + )]) + ] g @@ -633,7 +634,7 @@ let build_proof let dyn_infos = {dyn_info' with info = mkCase(ci,ct,t,cb)} in let g_nb_prod = nb_prod (project g) (pf_concl g) in - let type_of_term = pf_unsafe_type_of g t in + let g, type_of_term = tac_type_of g t in let term_eq = make_refl_eq (Lazy.force refl_equal) type_of_term t in @@ -849,7 +850,7 @@ let generalize_non_dep hyp g = (* observe (str "rec id := " ++ Ppconstr.pr_id hyp); *) let hyps = [hyp] in let env = Global.env () in - let hyp_typ = pf_unsafe_type_of g (mkVar hyp) in + let hyp_typ = pf_get_hyp_typ g hyp in let to_revert,_ = let open Context.Named.Declaration in Environ.fold_named_context_reverse (fun (clear,keep) decl -> @@ -1351,7 +1352,7 @@ let backtrack_eqs_until_hrec hrec eqs : tactic = let rewrite = tclFIRST (List.map (fun x -> Proofview.V82.of_tactic (Equality.rewriteRL x)) eqs ) in - let _,hrec_concl = decompose_prod (project gls) (pf_unsafe_type_of gls (mkVar hrec)) in + let _,hrec_concl = decompose_prod (project gls) (pf_get_hyp_typ gls hrec) in let f_app = Array.last (snd (destApp (project gls) hrec_concl)) in let f = (fst (destApp (project gls) f_app)) in let rec backtrack : tactic = @@ -1573,19 +1574,16 @@ let prove_principle_for_gen (List.rev_map (get_name %> Nameops.Name.get_id) (princ_info.args@princ_info.branches@princ_info.predicates@princ_info.params) ); - (* observe_tac "" *) Proofview.V82.of_tactic (assert_by - (Name acc_rec_arg_id) - (mkApp (delayed_force acc_rel,[|input_type;relation;mkVar rec_arg_id|])) - (Proofview.V82.tactic prove_rec_arg_acc) - ); -(* observe_tac "reverting" *) (revert (List.rev (acc_rec_arg_id::args_ids))); -(* (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl () ++ *) -(* str "fix arg num" ++ int (List.length args_ids + 1) ); tclIDTAC g); *) - (* observe_tac "h_fix " *) (Proofview.V82.of_tactic (fix fix_id (List.length args_ids + 1))); -(* (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl() ++ pr_lconstr_env (pf_env g ) (pf_unsafe_type_of g (mkVar fix_id) )); tclIDTAC g); *) + Proofview.V82.of_tactic + (assert_by + (Name acc_rec_arg_id) + (mkApp (delayed_force acc_rel,[|input_type;relation;mkVar rec_arg_id|])) + (Proofview.V82.tactic prove_rec_arg_acc)); + (revert (List.rev (acc_rec_arg_id::args_ids))); + (Proofview.V82.of_tactic (fix fix_id (List.length args_ids + 1))); h_intros (List.rev (acc_rec_arg_id::args_ids)); Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_ref)); - (* observe_tac "finish" *) (fun gl' -> + (fun gl' -> let body = let _,args = destApp (project gl') (pf_concl gl') in Array.last args diff --git a/plugins/funind/gen_principle.ml b/plugins/funind/gen_principle.ml index 58efee1518..68661174ac 100644 --- a/plugins/funind/gen_principle.ml +++ b/plugins/funind/gen_principle.ml @@ -617,7 +617,7 @@ let prove_fun_correct evd funs_constr graphs_constr schemes lemmas_types_infos i let constructor_args g = List.fold_right (fun hid acc -> - let type_of_hid = pf_unsafe_type_of g (mkVar hid) in + let type_of_hid = pf_get_hyp_typ g hid in let sigma = project g in match EConstr.kind sigma type_of_hid with | Prod(_,_,t') -> @@ -953,7 +953,7 @@ let rec reflexivity_with_destruct_cases g = match sc with None -> tclIDTAC g | Some id -> - match EConstr.kind (project g) (pf_unsafe_type_of g (mkVar id)) with + match EConstr.kind (project g) (pf_get_hyp_typ g id) with | App(eq,[|_;t1;t2|]) when EConstr.eq_constr (project g) eq eq_ind -> if Equality.discriminable (pf_env g) (project g) t1 t2 then Proofview.V82.of_tactic (Equality.discrHyp id) g @@ -993,7 +993,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tacti (* We get the constant and the principle corresponding to this lemma *) let f = funcs.(i) in let graph_principle = Reductionops.nf_zeta (pf_env g) (project g) (EConstr.of_constr schemes.(i)) in - let princ_type = pf_unsafe_type_of g graph_principle in + let g, princ_type = tac_type_of g graph_principle in let princ_infos = Tactics.compute_elim_sig (project g) princ_type in (* Then we get the number of argument of the function and compute a fresh name for each of them @@ -1210,7 +1210,7 @@ let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : Evd.side_ef in let _ = evd := sigma in let l_schemes = - List.map (EConstr.of_constr %> Typing.unsafe_type_of env sigma %> EConstr.Unsafe.to_constr) schemes + List.map (EConstr.of_constr %> Retyping.get_type_of env sigma %> EConstr.Unsafe.to_constr) schemes in let i = ref (-1) in let sorts = @@ -2051,7 +2051,7 @@ let build_case_scheme fa = let (sigma, scheme) = Indrec.build_case_analysis_scheme_default env sigma ind sf in - let scheme_type = EConstr.Unsafe.to_constr ((Typing.unsafe_type_of env sigma) (EConstr.of_constr scheme)) in + let scheme_type = EConstr.Unsafe.to_constr ((Retyping.get_type_of env sigma) (EConstr.of_constr scheme)) in let sorts = (fun (_,_,x) -> fst @@ UnivGen.fresh_sort_in_family x diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index e41b92d4dc..fdbad2ab9e 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -514,8 +514,9 @@ let rec build_entry_lc env sigma funnames avoid rt : glob_constr build_entry_ret a pseudo value "v1 ... vn". The "value" of this branch is then simply [res] *) + (* XXX here and other [understand] calls drop the ctx *) let rt_as_constr,ctx = Pretyping.understand env (Evd.from_env env) rt in - let rt_typ = Typing.unsafe_type_of env (Evd.from_env env) rt_as_constr in + let rt_typ = Retyping.get_type_of env (Evd.from_env env) rt_as_constr in let res_raw_type = Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_env env) rt_typ in let res = fresh_id args_res.to_avoid "_res" in let new_avoid = res::args_res.to_avoid in @@ -629,7 +630,7 @@ let rec build_entry_lc env sigma funnames avoid rt : glob_constr build_entry_ret let v = match typ with None -> v | Some t -> DAst.make ?loc:rt.loc @@ GCast (v,CastConv t) in let v_res = build_entry_lc env sigma funnames avoid v in let v_as_constr,ctx = Pretyping.understand env (Evd.from_env env) v in - let v_type = Typing.unsafe_type_of env (Evd.from_env env) v_as_constr in + let v_type = Retyping.get_type_of env (Evd.from_env env) v_as_constr in let v_r = Sorts.Relevant in (* TODO relevance *) let new_env = match n with @@ -646,7 +647,7 @@ let rec build_entry_lc env sigma funnames avoid rt : glob_constr build_entry_ret build_entry_lc_from_case env sigma funnames make_discr el brl avoid | GIf(b,(na,e_option),lhs,rhs) -> let b_as_constr,ctx = Pretyping.understand env (Evd.from_env env) b in - let b_typ = Typing.unsafe_type_of env (Evd.from_env env) b_as_constr in + let b_typ = Retyping.get_type_of env (Evd.from_env env) b_as_constr in let (ind,_) = try Inductiveops.find_inductive env (Evd.from_env env) b_typ with Not_found -> @@ -678,7 +679,7 @@ let rec build_entry_lc env sigma funnames avoid rt : glob_constr build_entry_ret nal in let b_as_constr,ctx = Pretyping.understand env (Evd.from_env env) b in - let b_typ = Typing.unsafe_type_of env (Evd.from_env env) b_as_constr in + let b_typ = Retyping.get_type_of env (Evd.from_env env) b_as_constr in let (ind,_) = try Inductiveops.find_inductive env (Evd.from_env env) b_typ with Not_found -> @@ -723,7 +724,7 @@ and build_entry_lc_from_case env sigma funname make_discr let types = List.map (fun (case_arg,_) -> let case_arg_as_constr,ctx = Pretyping.understand env (Evd.from_env env) case_arg in - EConstr.Unsafe.to_constr (Typing.unsafe_type_of env (Evd.from_env env) case_arg_as_constr) + EConstr.Unsafe.to_constr (Retyping.get_type_of env (Evd.from_env env) case_arg_as_constr) ) el in (****** The next works only if the match is not dependent ****) @@ -769,9 +770,7 @@ and build_entry_lc_from_case_term env sigma types funname make_discr patterns_to let env_with_pat_ids = add_pat_variables sigma pat typ new_env in List.fold_right (fun id acc -> - let typ_of_id = - Typing.unsafe_type_of env_with_pat_ids (Evd.from_env env) (EConstr.mkVar id) - in + let typ_of_id = Typing.type_of_variable env_with_pat_ids id in let raw_typ_of_id = Detyping.detype Detyping.Now false Id.Set.empty env_with_pat_ids (Evd.from_env env) typ_of_id @@ -832,7 +831,7 @@ and build_entry_lc_from_case_term env sigma types funname make_discr patterns_to (fun id acc -> if Id.Set.mem id this_pat_ids then (Prod (Name id), - let typ_of_id = Typing.unsafe_type_of new_env (Evd.from_env env) (EConstr.mkVar id) in + let typ_of_id = Typing.type_of_variable new_env id in let raw_typ_of_id = Detyping.detype Detyping.Now false Id.Set.empty new_env (Evd.from_env env) typ_of_id in @@ -1166,7 +1165,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let evd = (Evd.from_env env) in let t',ctx = Pretyping.understand env evd t in let evd = Evd.from_ctx ctx in - let type_t' = Typing.unsafe_type_of env evd t' in + let type_t' = Retyping.get_type_of env evd t' in let t' = EConstr.Unsafe.to_constr t' in let type_t' = EConstr.Unsafe.to_constr type_t' in let new_env = Environ.push_rel (LocalDef (make_annot n Sorts.Relevant,t',type_t')) env in @@ -1513,12 +1512,12 @@ let do_build_inductive let _time3 = System.get_time () in (* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) let repacked_rel_inds = - List.map (fun ((a , b , c , l),ntn) -> ((false,(a,None)) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn ) + List.map (fun ((a , b , c , l),ntn) -> ((false,(a,None)) , b, c, Vernacexpr.Constructors l),ntn ) rel_inds in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac (CAst.make Vernacexpr.{ control = []; attrs = []; expr = VernacInductive(None,false,Declarations.Finite,repacked_rel_inds)}) + Ppvernac.pr_vernac (CAst.make Vernacexpr.{ control = []; attrs = []; expr = VernacInductive(None,false,Vernacexpr.Inductive_kw,repacked_rel_inds)}) ++ fnl () ++ msg in @@ -1528,12 +1527,12 @@ let do_build_inductive let _time3 = System.get_time () in (* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) let repacked_rel_inds = - List.map (fun ((a , b , c , l),ntn) -> ((false,(a,None)) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn ) + List.map (fun ((a , b , c , l),ntn) -> ((false,(a,None)) , b, c, Vernacexpr.Constructors l),ntn ) rel_inds in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac (CAst.make @@ Vernacexpr.{ control = []; attrs = []; expr = VernacInductive(None,false,Declarations.Finite,repacked_rel_inds)}) + Ppvernac.pr_vernac (CAst.make @@ Vernacexpr.{ control = []; attrs = []; expr = VernacInductive(None,false,Vernacexpr.Inductive_kw,repacked_rel_inds)}) ++ fnl () ++ CErrors.print reraise in diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index a205c0744a..f28e98dcc2 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -64,12 +64,10 @@ let functional_induction with_clean c princl pat = | InSet -> finfo.rec_lemma | InType -> finfo.rect_lemma in - let princ = (* then we get the principle *) + let sigma, princ = (* then we get the principle *) match princ_option with | Some princ -> - let sigma, princ = Evd.fresh_global (pf_env gl) (project gl) (GlobRef.ConstRef princ) in - Proofview.Unsafe.tclEVARS sigma >>= fun () -> - Proofview.tclUNIT princ + Evd.fresh_global (pf_env gl) (project gl) (GlobRef.ConstRef princ) | None -> (*i If there is not default lemma defined then, we cross our finger and try to find a lemma named f_ind @@ -87,19 +85,18 @@ let functional_induction with_clean c princl pat = user_err (str "Cannot find induction principle for " ++ Printer.pr_leconstr_env (pf_env gl) sigma (mkConst c') ) in - let sigma, princ = Evd.fresh_global (pf_env gl) (project gl) princ_ref in - Proofview.Unsafe.tclEVARS sigma >>= fun () -> - Proofview.tclUNIT princ + Evd.fresh_global (pf_env gl) (project gl) princ_ref in - princ >>= fun princ -> - (* We need to refresh gl due to the updated evar_map in princ *) - Proofview.Goal.enter_one (fun gl -> - Proofview.tclUNIT (princ, Tactypes.NoBindings, pf_unsafe_type_of gl princ, args)) + let princt = Retyping.get_type_of (pf_env gl) sigma princ in + Proofview.Unsafe.tclEVARS sigma <*> + Proofview.tclUNIT (princ, Tactypes.NoBindings, princt, args) | _ -> CErrors.user_err (str "functional induction must be used with a function" ) end | Some ((princ,binding)) -> - Proofview.tclUNIT (princ, binding, pf_unsafe_type_of gl princ, args) + let sigma, princt = pf_type_of gl princ in + Proofview.Unsafe.tclEVARS sigma <*> + Proofview.tclUNIT (princ, binding, princt, args) ) >>= fun (princ, bindings, princ_type, args) -> Proofview.Goal.enter (fun gl -> let sigma = project gl in diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index b55d8537d6..b2ee0f9370 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -320,7 +320,6 @@ open Goptions let functional_induction_rewrite_dependent_proofs_sig = { optdepr = false; - optname = "Functional Induction Rewrite Dependent"; optkey = ["Functional";"Induction";"Rewrite";"Dependent"]; optread = (fun () -> !functional_induction_rewrite_dependent_proofs); optwrite = (fun b -> functional_induction_rewrite_dependent_proofs := b) @@ -332,7 +331,6 @@ let do_rewrite_dependent () = !functional_induction_rewrite_dependent_proofs = t let function_debug_sig = { optdepr = false; - optname = "Function debug"; optkey = ["Function_debug"]; optread = (fun () -> !function_debug); optwrite = (fun b -> function_debug := b) @@ -416,7 +414,6 @@ let is_strict_tcc () = !strict_tcc let strict_tcc_sig = { optdepr = false; - optname = "Raw Function Tcc"; optkey = ["Function_raw_tcc"]; optread = (fun () -> !strict_tcc); optwrite = (fun b -> strict_tcc := b) @@ -526,3 +523,7 @@ let funind_purify f x = let e = CErrors.push e in Vernacstate.unfreeze_interp_state st; Exninfo.iraise e + +let tac_type_of g c = + let sigma, t = Tacmach.pf_type_of g c in + {g with Evd.sigma}, t diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index 550f727951..bd8b34088b 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -119,3 +119,5 @@ type tcc_lemma_value = | Not_needed val funind_purify : ('a -> 'b) -> ('a -> 'b) + +val tac_type_of : Goal.goal Evd.sigma -> EConstr.constr -> Goal.goal Evd.sigma * EConstr.types diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index d72319d078..332d058ce7 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -28,7 +28,7 @@ open Indfun_common *) let revert_graph kn post_tac hid = Proofview.Goal.enter (fun gl -> let sigma = project gl in - let typ = pf_unsafe_type_of gl (mkVar hid) in + let typ = pf_get_hyp_typ hid gl in match EConstr.kind sigma typ with | App(i,args) when isInd sigma i -> let ((kn',num) as ind'),u = destInd sigma i in @@ -77,7 +77,7 @@ let revert_graph kn post_tac hid = Proofview.Goal.enter (fun gl -> let functional_inversion kn hid fconst f_correct = Proofview.Goal.enter (fun gl -> let old_ids = List.fold_right Id.Set.add (pf_ids_of_hyps gl) Id.Set.empty in let sigma = project gl in - let type_of_h = pf_unsafe_type_of gl (mkVar hid) in + let type_of_h = pf_get_hyp_typ hid gl in match EConstr.kind sigma type_of_h with | App(eq,args) when EConstr.eq_constr sigma eq (make_eq ()) -> let pre_tac,f_args,res = @@ -128,7 +128,7 @@ let invfun qhyp f = | None -> let tac_action hid gl = let sigma = project gl in - let hyp_typ = pf_unsafe_type_of gl (mkVar hid) in + let hyp_typ = pf_get_hyp_typ hid gl in match EConstr.kind sigma hyp_typ with | App(eq,args) when EConstr.eq_constr sigma eq (make_eq ()) -> begin diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 66ed1961ba..f7f8004998 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -31,7 +31,6 @@ open Tactics open Nametab open Declare open Tacred -open Goal open Glob_term open Pretyping open Termops @@ -110,9 +109,10 @@ let pf_get_new_ids idl g = let next_ident_away_in_goal ids avoid = next_ident_away_in_goal ids (Id.Set.of_list avoid) -let compute_renamed_type gls c = +let compute_renamed_type gls id = rename_bound_vars_as_displayed (project gls) (*no avoid*) Id.Set.empty (*no rels*) [] - (pf_unsafe_type_of gls c) + (pf_get_hyp_typ gls id) + let h'_id = Id.of_string "h'" let teq_id = Id.of_string "teq" let ano_id = Id.of_string "anonymous" @@ -370,7 +370,7 @@ let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = Proofview.V82.of_tactic (clear to_intros); h_intros to_intros; (fun g' -> - let ty_teq = pf_unsafe_type_of g' (mkVar heq) in + let ty_teq = pf_get_hyp_typ g' heq in let teq_lhs,teq_rhs = let _,args = try destApp (project g') ty_teq with DestKO -> assert false in args.(1),args.(2) @@ -487,13 +487,13 @@ let rec prove_lt hyple g = in let h = List.find (fun id -> - match decompose_app sigma (pf_unsafe_type_of g (mkVar id)) with + match decompose_app sigma (pf_get_hyp_typ g id) with | _, t::_ -> EConstr.eq_constr sigma t varx | _ -> false ) hyple in let y = - List.hd (List.tl (snd (decompose_app sigma (pf_unsafe_type_of g (mkVar h))))) in + List.hd (List.tl (snd (decompose_app sigma (pf_get_hyp_typ g h)))) in observe_tclTHENLIST (fun _ _ -> str "prove_lt1")[ Proofview.V82.of_tactic (apply (mkApp(le_lt_trans (),[|varx;y;varz;mkVar h|]))); observe_tac (fun _ _ -> str "prove_lt") (prove_lt hyple) @@ -645,9 +645,7 @@ let pf_typel l tac = modified hypotheses are generalized in the process and should be introduced back later; the result is the pair of the tactic and the list of hypotheses that have been generalized and cleared. *) -let mkDestructEq : - Id.t list -> constr -> goal Evd.sigma -> tactic * Id.t list = - fun not_on_hyp expr g -> +let mkDestructEq not_on_hyp expr g = let hyps = pf_hyps g in let to_revert = Util.List.map_filter @@ -657,9 +655,9 @@ let mkDestructEq : if Id.List.mem id not_on_hyp || not (Termops.dependent (project g) expr (get_type decl)) then None else Some id) hyps in let to_revert_constr = List.rev_map mkVar to_revert in - let type_of_expr = pf_unsafe_type_of g expr in - let new_hyps = mkApp(Lazy.force refl_equal, [|type_of_expr; expr|]):: - to_revert_constr in + let g, type_of_expr = tac_type_of g expr in + let new_hyps = mkApp(Lazy.force refl_equal, [|type_of_expr; expr|])::to_revert_constr in + let tac = pf_typel new_hyps (fun _ -> observe_tclTHENLIST (fun _ _ -> str "mkDestructEq") [Proofview.V82.of_tactic (generalize new_hyps); @@ -668,7 +666,9 @@ let mkDestructEq : pattern_occs [Locus.AllOccurrencesBut [1], expr] (pf_env g2) sigma (pf_concl g2) in Proofview.V82.of_tactic (change_in_concl ~check:true None changefun) g2); - Proofview.V82.of_tactic (simplest_case expr)]), to_revert + Proofview.V82.of_tactic (simplest_case expr)]) + in + g, tac, to_revert let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = let sigma = project g in @@ -686,7 +686,7 @@ let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = info = mkCase(ci,t,a',l); is_main_branch = expr_info.is_main_branch; is_final = expr_info.is_final} in - let destruct_tac,rev_to_thin_intro = + let g,destruct_tac,rev_to_thin_intro = mkDestructEq [expr_info.rec_arg_id] a' g in let to_thin_intro = List.rev rev_to_thin_intro in observe_tac (fun _ _ -> str "treating cases (" ++ int (Array.length l) ++ str")" ++ spc () ++ Printer.pr_leconstr_env (pf_env g) sigma a') @@ -842,7 +842,7 @@ let rec make_rewrite_list expr_info max = function (observe_tac (fun _ _ -> str "rewrite heq on " ++ Id.print p ) ( (fun g -> let sigma = project g in - let t_eq = compute_renamed_type g (mkVar hp) in + let t_eq = compute_renamed_type g hp in let k,def = let k_na,_,t = destProd sigma t_eq in let _,_,t = destProd sigma t in @@ -868,7 +868,7 @@ let make_rewrite expr_info l hp max = (observe_tac (fun _ _ -> str "make_rewrite") (tclTHENS (fun g -> let sigma = project g in - let t_eq = compute_renamed_type g (mkVar hp) in + let t_eq = compute_renamed_type g hp in let k,def = let k_na,_,t = destProd sigma t_eq in let _,_,t = destProd sigma t in diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index 6c63a891e8..513f5ca77b 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -736,7 +736,7 @@ let refl_equal () = Coqlib.lib_ref "core.eq.type" call it before it is defined. *) let mkCaseEq a : unit Proofview.tactic = Proofview.Goal.enter begin fun gl -> - let type_of_a = Tacmach.New.pf_unsafe_type_of gl a in + let type_of_a = Tacmach.New.pf_get_type_of gl a in Tacticals.New.pf_constr_of_global (delayed_force refl_equal) >>= fun req -> Tacticals.New.tclTHENLIST [Tactics.generalize [(mkApp(req, [| type_of_a; a|]))]; @@ -794,7 +794,7 @@ let destauto t = let destauto_in id = Proofview.Goal.enter begin fun gl -> - let ctype = Tacmach.New.pf_unsafe_type_of gl (mkVar id) in + let ctype = Tacmach.New.pf_get_type_of gl (mkVar id) in (* Pp.msgnl (Printer.pr_lconstr (mkVar id)); *) (* Pp.msgnl (Printer.pr_lconstr (ctype)); *) destauto ctype diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index 81a6651745..7ea843ca69 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -368,7 +368,6 @@ let print_info_trace = ref None let () = declare_int_option { optdepr = false; - optname = "print info trace"; optkey = ["Info" ; "Level"]; optread = (fun () -> !print_info_trace); optwrite = fun n -> print_info_trace := n; diff --git a/plugins/ltac/profile_ltac.ml b/plugins/ltac/profile_ltac.ml index fe5ebf1172..7529f9fce6 100644 --- a/plugins/ltac/profile_ltac.ml +++ b/plugins/ltac/profile_ltac.ml @@ -450,7 +450,6 @@ let () = let open Goptions in declare_bool_option { optdepr = false; - optname = "Ltac Profiling"; optkey = ["Ltac"; "Profiling"]; optread = get_profiling; optwrite = set_profiling } diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 98d14f3d33..fbc64d95d0 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -289,18 +289,18 @@ end) = struct if Int.equal n 0 then c else match EConstr.kind sigma c with - | App (f, [| a; b; relb |]) when Termops.is_global sigma (pointwise_relation_ref ()) f -> + | App (f, [| a; b; relb |]) when isRefX sigma (pointwise_relation_ref ()) f -> decomp_pointwise sigma (pred n) relb - | App (f, [| a; b; arelb |]) when Termops.is_global sigma (forall_relation_ref ()) f -> + | App (f, [| a; b; arelb |]) when isRefX sigma (forall_relation_ref ()) f -> decomp_pointwise sigma (pred n) (Reductionops.beta_applist sigma (arelb, [mkRel 1])) | _ -> invalid_arg "decomp_pointwise" let rec apply_pointwise sigma rel = function | arg :: args -> (match EConstr.kind sigma rel with - | App (f, [| a; b; relb |]) when Termops.is_global sigma (pointwise_relation_ref ()) f -> + | App (f, [| a; b; relb |]) when isRefX sigma (pointwise_relation_ref ()) f -> apply_pointwise sigma relb args - | App (f, [| a; b; arelb |]) when Termops.is_global sigma (forall_relation_ref ()) f -> + | App (f, [| a; b; arelb |]) when isRefX sigma (forall_relation_ref ()) f -> apply_pointwise sigma (Reductionops.beta_applist sigma (arelb, [arg])) args | _ -> invalid_arg "apply_pointwise") | [] -> rel @@ -357,7 +357,7 @@ end) = struct match EConstr.kind sigma t with | App (c, args) when Array.length args >= 2 -> let head = if isApp sigma c then fst (destApp sigma c) else c in - if Termops.is_global sigma (coq_eq_ref ()) head then None + if isRefX sigma (coq_eq_ref ()) head then None else (try let params, args = Array.chop (Array.length args - 2) args in @@ -483,7 +483,7 @@ let rec decompose_app_rel env evd t = | App (f, [||]) -> assert false | App (f, [|arg|]) -> let (f', argl, argr) = decompose_app_rel env evd arg in - let ty = Typing.unsafe_type_of env evd argl in + let ty = Retyping.get_type_of env evd argl in let r = Retyping.relevance_of_type env evd ty in let f'' = mkLambda (make_annot (Name default_dependent_ident) r, ty, mkLambda (make_annot (Name (Id.of_string "y")) r, lift 1 ty, @@ -789,7 +789,8 @@ let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' (b,cstr) ev let morphargs, morphobjs = Array.chop first args in let morphargs', morphobjs' = Array.chop first args' in let appm = mkApp(m, morphargs) in - let appmtype = Typing.unsafe_type_of env (goalevars evars) appm in + let evd, appmtype = Typing.type_of env (goalevars evars) appm in + let evars = evd, snd evars in let cstrs = List.map (Option.map (fun r -> r.rew_car, get_opt_rew_rel r.rew_prf)) (Array.to_list morphobjs') @@ -1879,13 +1880,13 @@ let declare_projection n instance_id r = let rec aux t = match EConstr.kind sigma t with | App (f, [| a ; a' ; rel; rel' |]) - when Termops.is_global sigma (PropGlobal.respectful_ref ()) f -> + when isRefX sigma (PropGlobal.respectful_ref ()) f -> succ (aux rel') | _ -> 0 in let init = match EConstr.kind sigma typ with - App (f, args) when Termops.is_global sigma (PropGlobal.respectful_ref ()) f -> + App (f, args) when isRefX sigma (PropGlobal.respectful_ref ()) f -> mkApp (f, fst (Array.chop (Array.length args - 2) args)) | _ -> typ in aux init @@ -1906,7 +1907,7 @@ let declare_projection n instance_id r = let build_morphism_signature env sigma m = let m,ctx = Constrintern.interp_constr env sigma m in let sigma = Evd.from_ctx ctx in - let t = Typing.unsafe_type_of env sigma m in + let t = Retyping.get_type_of env sigma m in let cstrs = let rec aux t = match EConstr.kind sigma t with @@ -1936,7 +1937,7 @@ let build_morphism_signature env sigma m = let default_morphism sign m = let env = Global.env () in let sigma = Evd.from_env env in - let t = Typing.unsafe_type_of env sigma m in + let t = Retyping.get_type_of env sigma m in let evars, _, sign, cstrs = PropGlobal.build_signature (sigma, Evar.Set.empty) env t (fst sign) (snd sign) in @@ -2195,10 +2196,10 @@ let setoid_transitivity c = (transitivity_red true c) let setoid_symmetry_in id = - let open Tacmach.New in Proofview.Goal.enter begin fun gl -> - let sigma = project gl in - let ctype = pf_unsafe_type_of gl (mkVar id) in + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let ctype = Retyping.get_type_of env sigma (mkVar id) in let binders,concl = decompose_prod_assum sigma ctype in let (equiv, args) = decompose_app sigma concl in let rec split_last_two = function diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml index a57cc76faa..de70fb292a 100644 --- a/plugins/ltac/taccoerce.ml +++ b/plugins/ltac/taccoerce.ml @@ -341,8 +341,8 @@ let coerce_to_reference sigma v = match Value.to_constr v with | Some c -> begin - try fst (Termops.global_of_constr sigma c) - with Not_found -> raise (CannotCoerceTo "a reference") + try fst (EConstr.destRef sigma c) + with DestKO -> raise (CannotCoerceTo "a reference") end | None -> raise (CannotCoerceTo "a reference") diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 98aa649b62..6e620b71db 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -2082,7 +2082,6 @@ let () = let open Goptions in declare_bool_option { optdepr = false; - optname = "Ltac debug"; optkey = ["Ltac";"Debug"]; optread = (fun () -> get_debug () != Tactic_debug.DebugOff); optwrite = vernac_debug } @@ -2091,7 +2090,6 @@ let () = let open Goptions in declare_bool_option { optdepr = false; - optname = "Ltac Backtrace"; optkey = ["Ltac"; "Backtrace"]; optread = (fun () -> !log_trace); optwrite = (fun b -> log_trace := b) } diff --git a/plugins/ltac/tactic_debug.ml b/plugins/ltac/tactic_debug.ml index 539536911c..0e9465839a 100644 --- a/plugins/ltac/tactic_debug.ml +++ b/plugins/ltac/tactic_debug.ml @@ -86,7 +86,6 @@ open Goptions let () = declare_bool_option { optdepr = false; - optname = "Ltac batch debug"; optkey = ["Ltac";"Batch";"Debug"]; optread = (fun () -> !batch); optwrite = (fun x -> batch := x) } diff --git a/plugins/ltac/tauto.ml b/plugins/ltac/tauto.ml index ba759441e5..92110d7a43 100644 --- a/plugins/ltac/tauto.ml +++ b/plugins/ltac/tauto.ml @@ -68,7 +68,6 @@ open Goptions let () = declare_bool_option { optdepr = false; - optname = "unfolding of not in intuition"; optkey = ["Intuition";"Negation";"Unfolding"]; optread = (fun () -> !negation_unfolding); optwrite = (:=) negation_unfolding } diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 92a2222cfa..4b656f8e61 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -55,7 +55,6 @@ let use_csdp_cache = ref true let () = let int_opt l vref = { optdepr = false - ; optname = List.fold_right ( ^ ) l "" ; optkey = l ; optread = (fun () -> Some !vref) ; optwrite = @@ -63,42 +62,36 @@ let () = in let lia_enum_opt = { optdepr = false - ; optname = "Lia Enum" ; optkey = ["Lia"; "Enum"] ; optread = (fun () -> !lia_enum) ; optwrite = (fun x -> lia_enum := x) } in let solver_opt = { optdepr = false - ; optname = "Use the Simplex instead of Fourier elimination" ; optkey = ["Simplex"] ; optread = (fun () -> !Certificate.use_simplex) ; optwrite = (fun x -> Certificate.use_simplex := x) } in let dump_file_opt = { optdepr = false - ; optname = "Generate Coq goals in file from calls to 'lia' 'nia'" ; optkey = ["Dump"; "Arith"] ; optread = (fun () -> !Certificate.dump_file) ; optwrite = (fun x -> Certificate.dump_file := x) } in let lia_cache_opt = { optdepr = false - ; optname = "cache of lia (.lia.cache)" ; optkey = ["Lia"; "Cache"] ; optread = (fun () -> !use_lia_cache) ; optwrite = (fun x -> use_lia_cache := x) } in let nia_cache_opt = { optdepr = false - ; optname = "cache of nia (.nia.cache)" ; optkey = ["Nia"; "Cache"] ; optread = (fun () -> !use_nia_cache) ; optwrite = (fun x -> use_nia_cache := x) } in let nra_cache_opt = { optdepr = false - ; optname = "cache of nra (.nra.cache)" ; optkey = ["Nra"; "Cache"] ; optread = (fun () -> !use_nra_cache) ; optwrite = (fun x -> use_nra_cache := x) } @@ -2416,6 +2409,36 @@ let nqa = (fun _ x -> x) Mc.cnfQ qq_domain_spec dump_qexpr nlinear_prover_R +let print_lia_profile () = + Simplex.( + let { number_of_successes + ; number_of_failures + ; success_pivots + ; failure_pivots + ; average_pivots + ; maximum_pivots } = + Simplex.get_profile_info () + in + Feedback.msg_notice + Pp.( + (* successes *) + str "number of successes: " + ++ int number_of_successes ++ fnl () + (* success pivots *) + ++ str "number of success pivots: " + ++ int success_pivots ++ fnl () + (* failure *) + ++ str "number of failures: " + ++ int number_of_failures ++ fnl () + (* failure pivots *) + ++ str "number of failure pivots: " + ++ int failure_pivots ++ fnl () + (* Other *) + ++ str "average number of pivots: " + ++ int average_pivots ++ fnl () + ++ str "maximum number of pivots: " + ++ int maximum_pivots ++ fnl ())) + (* Local Variables: *) (* coding: utf-8 *) (* End: *) diff --git a/plugins/micromega/coq_micromega.mli b/plugins/micromega/coq_micromega.mli index 37ea560241..bcfc47357f 100644 --- a/plugins/micromega/coq_micromega.mli +++ b/plugins/micromega/coq_micromega.mli @@ -8,7 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(*val is_ground_tac : EConstr.constr -> unit Proofview.tactic*) val psatz_Z : int -> unit Proofview.tactic -> unit Proofview.tactic val psatz_Q : int -> unit Proofview.tactic -> unit Proofview.tactic val psatz_R : int -> unit Proofview.tactic -> unit Proofview.tactic @@ -21,6 +20,7 @@ val sos_Q : unit Proofview.tactic -> unit Proofview.tactic val sos_R : unit Proofview.tactic -> unit Proofview.tactic val lra_Q : unit Proofview.tactic -> unit Proofview.tactic val lra_R : unit Proofview.tactic -> unit Proofview.tactic +val print_lia_profile : unit -> unit (** {5 Use Micromega independently from tactics. } *) diff --git a/plugins/micromega/g_micromega.mlg b/plugins/micromega/g_micromega.mlg index edf8106f30..d0f70bceac 100644 --- a/plugins/micromega/g_micromega.mlg +++ b/plugins/micromega/g_micromega.mlg @@ -28,10 +28,6 @@ open Tacarg DECLARE PLUGIN "micromega_plugin" -TACTIC EXTEND RED -| [ "myred" ] -> { Tactics.red_in_concl } -END - TACTIC EXTEND PsatzZ | [ "psatz_Z" int_or_var(i) tactic(t) ] -> { (Coq_micromega.psatz_Z i (Tacinterp.tactic_of_value ist t)) @@ -87,3 +83,6 @@ TACTIC EXTEND PsatzQ | [ "psatz_Q" tactic(t) ] -> { (Coq_micromega.psatz_Q (-1) (Tacinterp.tactic_of_value ist t)) } END +VERNAC COMMAND EXTEND ShowLiaProfile CLASSIFIED AS QUERY +| [ "Show" "Lia" "Profile" ] -> { Coq_micromega.print_lia_profile () } +END diff --git a/plugins/micromega/simplex.ml b/plugins/micromega/simplex.ml index ade8143f3c..54976221bc 100644 --- a/plugins/micromega/simplex.ml +++ b/plugins/micromega/simplex.ml @@ -18,6 +18,49 @@ type ('a, 'b) sum = Inl of 'a | Inr of 'b let debug = false +(** Exploiting profiling information *) + +let profile_info = ref [] +let nb_pivot = ref 0 + +type profile_info = + { number_of_successes : int + ; number_of_failures : int + ; success_pivots : int + ; failure_pivots : int + ; average_pivots : int + ; maximum_pivots : int } + +let init_profile = + { number_of_successes = 0 + ; number_of_failures = 0 + ; success_pivots = 0 + ; failure_pivots = 0 + ; average_pivots = 0 + ; maximum_pivots = 0 } + +let get_profile_info () = + let update_profile + { number_of_successes + ; number_of_failures + ; success_pivots + ; failure_pivots + ; average_pivots + ; maximum_pivots } (b, i) = + { number_of_successes = (number_of_successes + if b then 1 else 0) + ; number_of_failures = (number_of_failures + if b then 0 else 1) + ; success_pivots = (success_pivots + if b then i else 0) + ; failure_pivots = (failure_pivots + if b then 0 else i) + ; average_pivots = average_pivots + 1 (* number of proofs *) + ; maximum_pivots = max maximum_pivots i } + in + let p = List.fold_left update_profile init_profile !profile_info in + profile_info := []; + { p with + average_pivots = + ( try (p.success_pivots + p.failure_pivots) / p.average_pivots + with Division_by_zero -> 0 ) } + type iset = unit IMap.t type tableau = Vect.t IMap.t @@ -60,10 +103,7 @@ let output_tableau o t = t let output_env o t = - IMap.iter - (fun k v -> - Printf.fprintf o "%a : %a\n" LinPoly.pp_var k WithProof.output v) - t + IMap.iter (fun k v -> Printf.fprintf o "%i : %a\n" k WithProof.output v) t let output_vars o m = IMap.iter (fun k _ -> Printf.fprintf o "%a " LinPoly.pp_var k) m @@ -224,6 +264,7 @@ let pivot_with (m : tableau) (v : var) (p : Vect.t) = IMap.map (fun (r : Vect.t) -> pivot_row r v p) m let pivot (m : tableau) (r : var) (c : var) = + incr nb_pivot; let row = safe_find "pivot" r m in let piv = solve_column c r row in IMap.add c piv (pivot_with (IMap.remove r m) c piv) @@ -477,8 +518,11 @@ let make_farkas_proof (env : WithProof.t IMap.t) vm v = try let x', b = IMap.find x vm in let n = if b then n else Num.minus_num n in - WithProof.mult (Vect.cst n) (IMap.find x' env) - with Not_found -> WithProof.mult (Vect.cst n) (IMap.find x env) + let prf = IMap.find x' env in + WithProof.mult (Vect.cst n) prf + with Not_found -> + let prf = IMap.find x env in + WithProof.mult (Vect.cst n) prf end) WithProof.zero v @@ -493,21 +537,43 @@ 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 f = frac_num n in - if f =/ Int 0 then Forget (* The solution is integral *) + let fn = frac_num n in + if fn =/ Int 0 then Forget (* The solution is integral *) else - (* This is potentially a cut *) - let t = - if f </ Int 1 // Int 2 then - let t' = Int 1 // f in - if Num.is_integer_num t' then t' -/ Int 1 else Num.floor_num t' - else Int 1 - in - let cut_coeff1 v = + (* 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 - if fv <=/ Int 1 -/ f then fv // (Int 1 -/ f) else (Int 1 -/ fv) // f + Num.min_num fv (fn */ (Int 1 -/ fv) // (Int 1 -/ fn)) in - let cut_coeff2 v = frac_num (t */ v) 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 + (* 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) + else + (* multiply by -1 & t-cut *) + minus_num (Num.ceiling_num (n0_5 // (Int 1 -/ fn))) + in + ("Prop2", fun v -> frac_num (v */ tmin)) + in + let ccoeff = ccoeff_prop2 in let cut_vector ccoeff = Vect.fold (fun acc x n -> @@ -516,35 +582,31 @@ let cut env rmin sol vm (rst : Restricted.t) tbl (x, v) = Vect.null r in let lcut = - List.map - (fun cv -> Vect.normalise (cut_vector cv)) - [cut_coeff1; cut_coeff2] + ( fst ccoeff + , make_farkas_proof env vm (Vect.normalise (cut_vector (snd ccoeff))) ) in - let lcut = List.map (make_farkas_proof env vm) lcut in - let check_cutting_plane c = + let check_cutting_plane (p, c) = match WithProof.cutting_plane c with | None -> if debug then - Printf.printf "This is not a cutting plane for %a\n%a:" LinPoly.pp_var - x WithProof.output c; + Printf.printf "%s: This is not a cutting plane for %a\n%a:" p + LinPoly.pp_var x WithProof.output c; None | Some (v, prf) -> if debug then ( - Printf.printf "This is a cutting plane for %a:" LinPoly.pp_var x; + Printf.printf "%s: This is a cutting plane for %a:" p LinPoly.pp_var x; Printf.printf " %a\n" WithProof.output (v, prf) ); - if snd v = Eq then (* Unsat *) Some (x, (v, prf)) - else - let vl = Vect.dotproduct (fst v) (Vect.set 0 (Int 1) sol) in - if eval_op Ge vl (Int 0) then ( - if debug then - Printf.printf "The cut is feasible %s >= 0 \n" - (Num.string_of_num vl); - None ) - else Some (x, (v, prf)) + Some (x, (v, prf)) in - match find_some check_cutting_plane lcut with + match check_cutting_plane lcut with | Some r -> Hit r - | None -> Keep (x, v) + | None -> + let has_unrestricted = + Vect.fold + (fun acc v vl -> acc || not (Restricted.is_restricted v rst)) + false r + in + if has_unrestricted then Keep (x, v) else Forget let merge_result_old oldr f x = match oldr with @@ -681,12 +743,16 @@ let integer_solver lp = isolve env None vr res let integer_solver lp = + nb_pivot := 0; if debug then Printf.printf "Input integer solver\n%a\n" WithProof.output_sys (List.map WithProof.of_cstr lp); match integer_solver lp with - | None -> None + | None -> + profile_info := (false, !nb_pivot) :: !profile_info; + None | Some prf -> + profile_info := (true, !nb_pivot) :: !profile_info; if debug then Printf.fprintf stdout "Proof %a\n" ProofFormat.output_proof prf; Some prf diff --git a/plugins/micromega/simplex.mli b/plugins/micromega/simplex.mli index 19bcce3590..ff672edafd 100644 --- a/plugins/micromega/simplex.mli +++ b/plugins/micromega/simplex.mli @@ -9,6 +9,20 @@ (************************************************************************) open Polynomial +(** Profiling *) + +type profile_info = + { number_of_successes : int + ; number_of_failures : int + ; success_pivots : int + ; failure_pivots : int + ; average_pivots : int + ; maximum_pivots : int } + +val get_profile_info : unit -> profile_info + +(** Simplex interface *) + val optimise : Vect.t -> cstr list -> (Num.num option * Num.num option) option val find_point : cstr list -> Vect.t option val find_unsat_certificate : cstr list -> Vect.t option diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index dcd85401d6..118db01ecb 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -67,7 +67,6 @@ open Goptions let () = declare_bool_option { optdepr = false; - optname = "Omega system time displaying flag"; optkey = ["Omega";"System"]; optread = read display_system_flag; optwrite = write display_system_flag } @@ -75,7 +74,6 @@ let () = let () = declare_bool_option { optdepr = false; - optname = "Omega action display flag"; optkey = ["Omega";"Action"]; optread = read display_action_flag; optwrite = write display_action_flag } @@ -83,7 +81,6 @@ let () = let () = declare_bool_option { optdepr = false; - optname = "Omega old style flag"; optkey = ["Omega";"OldStyle"]; optread = read old_style_flag; optwrite = write old_style_flag } @@ -91,7 +88,6 @@ let () = let () = declare_bool_option { optdepr = true; - optname = "Omega automatic reset of generated names"; optkey = ["Stable";"Omega"]; optread = read reset_flag; optwrite = write reset_flag } @@ -99,7 +95,6 @@ let () = let () = declare_bool_option { optdepr = false; - optname = "Omega takes advantage of context variables with body"; optkey = ["Omega";"UseLocalDefs"]; optread = read letin_flag; optwrite = write letin_flag } @@ -1713,7 +1708,6 @@ let onClearedName2 id tac = let destructure_hyps = Proofview.Goal.enter begin fun gl -> - let type_of = Tacmach.New.pf_unsafe_type_of gl in let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let decidability = decidability env sigma in @@ -1759,7 +1753,7 @@ let destructure_hyps = | Kimp(t1,t2) -> (* t1 and t2 might be in Type rather than Prop. For t1, the decidability check will ensure being Prop. *) - if Termops.is_Prop sigma (type_of t2) + if Termops.is_Prop sigma (Retyping.get_type_of env sigma t2) then let d1 = decidability t1 in tclTHENLIST [ diff --git a/plugins/rtauto/proof_search.ml b/plugins/rtauto/proof_search.ml index 4cc32cfb26..ab34489de9 100644 --- a/plugins/rtauto/proof_search.ml +++ b/plugins/rtauto/proof_search.ml @@ -49,7 +49,6 @@ let pruning = ref true let opt_pruning= {optdepr=false; - optname="Rtauto Pruning"; optkey=["Rtauto";"Pruning"]; optread=(fun () -> !pruning); optwrite=(fun b -> pruning:=b)} diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index 0c155c9d0a..b86c8d096c 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -227,7 +227,6 @@ let verbose = ref false let opt_verbose= {optdepr=false; - optname="Rtauto Verbose"; optkey=["Rtauto";"Verbose"]; optread=(fun () -> !verbose); optwrite=(fun b -> verbose:=b)} @@ -238,7 +237,6 @@ let check = ref false let opt_check= {optdepr=false; - optname="Rtauto Check"; optkey=["Rtauto";"Check"]; optread=(fun () -> !check); optwrite=(fun b -> check:=b)} diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index f7e4a95a22..3841501b6a 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -18,7 +18,6 @@ open EConstr open Vars open CClosure open Environ -open Globnames open Glob_term open Locus open Tacexpr @@ -43,12 +42,12 @@ type protection = Evd.evar_map -> EConstr.t -> GlobRef.t -> (Int.t -> protect_fl let global_head_of_constr sigma c = let f, args = decompose_app sigma c in - try fst (Termops.global_of_constr sigma f) - with Not_found -> CErrors.anomaly (str "global_head_of_constr.") + try fst (EConstr.destRef sigma f) + with DestKO -> CErrors.anomaly (str "global_head_of_constr.") let global_of_constr_nofail c = - try global_of_constr c - with Not_found -> GlobRef.VarRef (Id.of_string "dummy") + try fst @@ Constr.destRef c + with DestKO -> GlobRef.VarRef (Id.of_string "dummy") let rec mk_clos_but f_map n t = let (f, args) = Constr.decompose_appvect t in @@ -97,9 +96,9 @@ let protect_tac_in map id = let rec closed_under sigma cset t = try - let (gr, _) = Termops.global_of_constr sigma t in + let (gr, _) = destRef sigma t in GlobRef.Set_env.mem gr cset - with Not_found -> + with DestKO -> match EConstr.kind sigma t with | Cast(c,_,_) -> closed_under sigma cset c | App(f,l) -> closed_under sigma cset f && Array.for_all (closed_under sigma cset) l @@ -758,22 +757,21 @@ let af_ar = my_reference"AF_AR" let f_r = my_reference"F_R" let sf_sr = my_reference"SF_SR" let dest_field env evd th_spec = - let open Termops in let th_typ = Retyping.get_type_of env !evd th_spec in match EConstr.kind !evd th_typ with | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|]) - when is_global !evd (Lazy.force afield_theory) f -> + when isRefX !evd (Lazy.force afield_theory) f -> let rth = plapp evd af_ar [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in (None,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth) | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|]) - when is_global !evd (Lazy.force field_theory) f -> + when isRefX !evd (Lazy.force field_theory) f -> let rth = plapp evd f_r [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in (Some false,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth) | App(f,[|r;zero;one;add;mul;div;inv;req|]) - when is_global !evd (Lazy.force sfield_theory) f -> + when isRefX !evd (Lazy.force sfield_theory) f -> let rth = plapp evd sf_sr [|r;zero;one;add;mul;div;inv;req;th_spec|] in (Some true,r,zero,one,add,mul,None,None,div,inv,req,rth) diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index de3c660938..f95672a15d 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -906,10 +906,11 @@ let pf_interp_ty ?(resolve_typeclasses=false) ist gl ty = | _ -> (mkCCast ty (mkCType None)).v)) ty in mk_term ' ' (force_type ty) in let strip_cast (sigma, t) = - let rec aux t = match EConstr.kind_of_type sigma t with - | CastType (t, ty) when !n_binders = 0 && EConstr.isSort sigma ty -> t - | ProdType(n,s,t) -> decr n_binders; EConstr.mkProd (n, s, aux t) - | LetInType(n,v,ty,t) -> decr n_binders; EConstr.mkLetIn (n, v, ty, aux t) + let open EConstr in + let rec aux t = match kind_of_type sigma t with + | CastType (t, ty) when !n_binders = 0 && isSort sigma ty -> t + | ProdType(n,s,t) -> decr n_binders; mkProd (n, s, aux t) + | LetInType(n,v,ty,t) -> decr n_binders; mkLetIn (n, v, ty, aux t) | _ -> anomaly "pf_interp_ty: ssr Type cast deleted by typecheck" in sigma, aux t in let sigma, cty as ty = strip_cast (interp_term ist gl ty) in @@ -930,11 +931,12 @@ exception NotEnoughProducts let saturate ?(beta=false) ?(bi_types=false) env sigma c ?(ty=Retyping.get_type_of env sigma c) m = let rec loop ty args sigma n = + let open EConstr in if n = 0 then let args = List.rev args in (if beta then Reductionops.whd_beta sigma else fun x -> x) (EConstr.mkApp (c, Array.of_list (List.map snd args))), ty, args, sigma - else match EConstr.kind_of_type sigma ty with + else match kind_of_type sigma ty with | ProdType (_, src, tgt) -> let sigma = create_evar_defs sigma in let (sigma, x) = @@ -947,7 +949,7 @@ let saturate ?(beta=false) ?(bi_types=false) env sigma c ?(ty=Retyping.get_type_ | AtomicType _ -> let ty = (* FIXME *) (Reductionops.whd_all env sigma) ty in - match EConstr.kind_of_type sigma ty with + match kind_of_type sigma ty with | ProdType _ -> loop ty args sigma n | _ -> raise NotEnoughProducts in diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml index 26962ee87b..7baccd3d75 100644 --- a/plugins/ssr/ssrelim.ml +++ b/plugins/ssr/ssrelim.ml @@ -13,7 +13,6 @@ open Util open Names open Printer -open Term open Constr open Context open Termops @@ -35,16 +34,17 @@ module RelDecl = Context.Rel.Declaration * argument (index), it computes it's arity and the arity of the eliminator and * checks if the eliminator is recursive or not *) let analyze_eliminator elimty env sigma = - let rec loop ctx t = match EConstr.kind_of_type sigma t with - | AtomicType (hd, args) when EConstr.isRel sigma hd -> - ctx, EConstr.destRel sigma hd, not (EConstr.Vars.noccurn sigma 1 t), Array.length args, t + let open EConstr in + let rec loop ctx t = match kind_of_type sigma t with + | AtomicType (hd, args) when isRel sigma hd -> + ctx, destRel sigma hd, not (Vars.noccurn sigma 1 t), Array.length args, t | CastType (t, _) -> loop ctx t | ProdType (x, ty, t) -> loop (RelDecl.LocalAssum (x, ty) :: ctx) t - | LetInType (x,b,ty,t) -> loop (RelDecl.LocalDef (x, b, ty) :: ctx) (EConstr.Vars.subst1 b t) + | LetInType (x,b,ty,t) -> loop (RelDecl.LocalDef (x, b, ty) :: ctx) (Vars.subst1 b t) | _ -> - let env' = EConstr.push_rel_context ctx env in + let env' = push_rel_context ctx env in let t' = Reductionops.whd_all env' sigma t in - if not (EConstr.eq_constr sigma t t') then loop ctx t' else + if not (eq_constr sigma t t') then loop ctx t' else errorstrm Pp.(str"The eliminator has the wrong shape."++spc()++ str"A (applied) bound variable was expected as the conclusion of "++ str"the eliminator's"++Pp.cut()++str"type:"++spc()++pr_econstr_env env' sigma elimty) in @@ -243,7 +243,8 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let sigma = project gl in ppdebug(lazy Pp.(str"elim= "++ pr_econstr_pat env sigma elim)); ppdebug(lazy Pp.(str"elimty= "++ pr_econstr_pat env sigma elimty)) in - let inf_deps_r = match EConstr.kind_of_type (project gl) elimty with + let open EConstr in + let inf_deps_r = match kind_of_type (project gl) elimty with | AtomicType (_, args) -> List.rev (Array.to_list args) | _ -> assert false in let saturate_until gl c c_ty f = diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index cdda84a18d..895f491510 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -13,7 +13,6 @@ open Ltac_plugin open Util open Names -open Term open Constr open Context open Vars @@ -34,8 +33,7 @@ open Tacmach let ssroldreworder = Summary.ref ~name:"SSR:oldreworder" false let () = Goptions.(declare_bool_option - { optname = "ssreflect 1.3 compatibility flag"; - optkey = ["SsrOldRewriteGoalsOrder"]; + { optkey = ["SsrOldRewriteGoalsOrder"]; optread = (fun _ -> !ssroldreworder); optdepr = false; optwrite = (fun b -> ssroldreworder := b) }) @@ -380,7 +378,8 @@ let pirrel_rewrite ?(under=false) ?(map_redex=id_map_redex) pred rdx rdx_ty new_ let hd_ty = Retyping.get_type_of env sigma hd in let names = let rec aux t = function 0 -> [] | n -> let t = Reductionops.whd_all env sigma t in - match EConstr.kind_of_type sigma t with + let open EConstr in + match kind_of_type sigma t with | ProdType (name, _, t) -> name.binder_name :: aux t (n-1) | _ -> assert false in aux hd_ty (Array.length args) in hd_ty, Util.List.map_filter (fun (t, name) -> @@ -413,7 +412,8 @@ let rwcltac ?under ?map_redex cl rdx dir sr gl = let env, sigma, c, c_eq = pf_env gl, fst sr, snd sr, Coqlib.(lib_ref "core.eq.type") in let sigma, c_ty = Typing.type_of env sigma c in ppdebug(lazy Pp.(str"c_ty@rwcltac=" ++ pr_econstr_env env sigma c_ty)); - match EConstr.kind_of_type sigma (Reductionops.whd_all env sigma c_ty) with + let open EConstr in + match kind_of_type sigma (Reductionops.whd_all env sigma c_ty) with | AtomicType(e, a) when Ssrcommon.is_ind_ref sigma e c_eq -> let new_rdx = if dir = L2R then a.(2) else a.(1) in pirrel_rewrite ?under ?map_redex cl rdx rdxt new_rdx dir (sigma,c) c_ty, tclIDTAC, gl diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml index f486d1e457..a6b9a43778 100644 --- a/plugins/ssr/ssrfwd.ml +++ b/plugins/ssr/ssrfwd.ml @@ -69,8 +69,7 @@ let ssrhaveNOtcresolution = Summary.ref ~name:"SSR:havenotcresolution" false let () = Goptions.(declare_bool_option - { optname = "have type classes"; - optkey = ["SsrHave";"NoTCResolution"]; + { optkey = ["SsrHave";"NoTCResolution"]; optread = (fun _ -> !ssrhaveNOtcresolution); optdepr = false; optwrite = (fun b -> ssrhaveNOtcresolution := b); @@ -362,8 +361,9 @@ let intro_lock ipats = let c = Proofview.Goal.concl gl in let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in - match EConstr.kind_of_type sigma c with - | Term.AtomicType(hd, args) when + let open EConstr in + match kind_of_type sigma c with + | AtomicType(hd, args) when Array.length args >= 2 && is_app_evar sigma (Array.last args) && Ssrequality.ssr_is_setoid env sigma hd args (* if the last condition above [ssr_is_setoid ...] holds @@ -376,8 +376,8 @@ let intro_lock ipats = protect_subgoal env sigma hd args | _ -> let t = Reductionops.whd_all env sigma c in - match EConstr.kind_of_type sigma t with - | Term.AtomicType(hd, args) when + match kind_of_type sigma t with + | AtomicType(hd, args) when Ssrcommon.is_ind_ref sigma hd (Coqlib.lib_ref "core.eq.type") && Array.length args = 3 && is_app_evar sigma args.(2) -> protect_subgoal env sigma hd args diff --git a/plugins/ssr/ssripats.ml b/plugins/ssr/ssripats.ml index 580c0423e9..843adb40ac 100644 --- a/plugins/ssr/ssripats.ml +++ b/plugins/ssr/ssripats.ml @@ -610,8 +610,9 @@ let tclCompileIPats = IpatMachine.tclCompileIPats let with_defective maintac deps clr = Goal.enter begin fun g -> let sigma, concl = Goal.(sigma g, concl g) in let top_id = - match EConstr.kind_of_type sigma concl with - | Term.ProdType ({binder_name=Name id}, _, _) + let open EConstr in + match kind_of_type sigma concl with + | ProdType ({binder_name=Name id}, _, _) when Ssrcommon.is_discharged_id id -> id | _ -> Ssrcommon.top_id in let top_gen = Ssrequality.mkclr clr, Ssrmatching.cpattern_of_id top_id in @@ -641,10 +642,11 @@ let elim_intro_tac ipats ?seed what eqid ssrelim is_rec clr = | Some (IPatId ipat) when not is_rec -> let rec intro_eq () = Goal.enter begin fun g -> let sigma, env, concl = Goal.(sigma g, env g, concl g) in - match EConstr.kind_of_type sigma concl with - | Term.ProdType (_, src, tgt) -> begin - match EConstr.kind_of_type sigma src with - | Term.AtomicType (hd, _) when Ssrcommon.is_protect hd env sigma -> + let open EConstr in + match kind_of_type sigma concl with + | ProdType (_, src, tgt) -> begin + match kind_of_type sigma src with + | AtomicType (hd, _) when Ssrcommon.is_protect hd env sigma -> V82.tactic ~nf_evars:false Ssrcommon.unprotecttac <*> Ssrcommon.tclINTRO_ID ipat | _ -> Ssrcommon.tclINTRO_ANON () <*> intro_eq () @@ -669,8 +671,9 @@ let elim_intro_tac ipats ?seed what eqid ssrelim is_rec clr = let sigma, eq = EConstr.fresh_global env sigma (Coqlib.lib_ref "core.eq.type") in let ctx, last = EConstr.decompose_prod_assum sigma concl in - let args = match EConstr.kind_of_type sigma last with - | Term.AtomicType (hd, args) -> + let open EConstr in + let args = match kind_of_type sigma last with + | AtomicType (hd, args) -> if Ssrcommon.is_protect hd env sigma then args else Ssrcommon.errorstrm (Pp.str "Too many names in intro pattern") diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index 22325f3fc3..21b832a326 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -1662,8 +1662,7 @@ let ssr_reserved_ids = Summary.ref ~name:"SSR:idents" true let () = Goptions.(declare_bool_option - { optname = "ssreflect identifiers"; - optkey = ["SsrIdents"]; + { optkey = ["SsrIdents"]; optdepr = false; optread = (fun _ -> !ssr_reserved_ids); optwrite = (fun b -> ssr_reserved_ids := b) @@ -2395,8 +2394,7 @@ let ssr_rw_syntax = Summary.ref ~name:"SSR:rewrite" true let () = Goptions.(declare_bool_option - { optname = "ssreflect rewrite"; - optkey = ["SsrRewrite"]; + { optkey = ["SsrRewrite"]; optread = (fun _ -> !ssr_rw_syntax); optdepr = false; optwrite = (fun b -> ssr_rw_syntax := b) }) diff --git a/plugins/ssr/ssrprinters.ml b/plugins/ssr/ssrprinters.ml index f0aed1a934..22250202b5 100644 --- a/plugins/ssr/ssrprinters.ml +++ b/plugins/ssr/ssrprinters.ml @@ -134,8 +134,7 @@ let ppdebug_ref = ref (fun _ -> ()) let ssr_pp s = Feedback.msg_debug (str"SSR: "++Lazy.force s) let () = Goptions.(declare_bool_option - { optname = "ssreflect debugging"; - optkey = ["Debug";"Ssreflect"]; + { optkey = ["Debug";"Ssreflect"]; optdepr = false; optread = (fun _ -> !ppdebug_ref == ssr_pp); optwrite = (fun b -> diff --git a/plugins/ssr/ssrvernac.mlg b/plugins/ssr/ssrvernac.mlg index d8dbf2f3dc..b212e7046a 100644 --- a/plugins/ssr/ssrvernac.mlg +++ b/plugins/ssr/ssrvernac.mlg @@ -151,7 +151,7 @@ let declare_one_prenex_implicit locality f = with _ -> errorstrm (pr_qualid f ++ str " is not declared") in let rec loop = function | a :: args' when Impargs.is_status_implicit a -> - Impargs.MaximallyImplicit :: loop args' + MaxImplicit :: loop args' | args' when List.exists Impargs.is_status_implicit args' -> errorstrm (str "Expected prenex implicits for " ++ pr_qualid f) | _ -> [] in diff --git a/plugins/ssr/ssrview.ml b/plugins/ssr/ssrview.ml index f91b5e7aa2..d051836ebc 100644 --- a/plugins/ssr/ssrview.ml +++ b/plugins/ssr/ssrview.ml @@ -95,8 +95,9 @@ applied to the first assumption in the goal *) let vsBOOTSTRAP = Goal.enter_one ~__LOC__ begin fun gl -> let concl = Goal.concl gl in let id = (* We keep the orig name for checks in "in" tcl *) - match EConstr.kind_of_type (Goal.sigma gl) concl with - | Term.ProdType({binder_name=Name.Name id}, _, _) + let open EConstr in + match kind_of_type (Goal.sigma gl) concl with + | ProdType({binder_name=Name.Name id}, _, _) when Ssrcommon.is_discharged_id id -> id | _ -> mk_anon_id "view_subject" (Tacmach.New.pf_ids_of_hyps gl) in let view = EConstr.mkVar id in diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index 6cb464918a..e45bae19ca 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -34,7 +34,6 @@ open Tacinterp open Pretyping open Ppconstr open Printer -open Globnames open Namegen open Evar_kinds open Constrexpr @@ -55,8 +54,7 @@ let debug b = if b then pp_ref := ssr_pp else pp_ref := fun _ -> () let _ = Goptions.declare_bool_option - { Goptions.optname = "ssrmatching debugging"; - Goptions.optkey = ["Debug";"SsrMatching"]; + { Goptions.optkey = ["Debug";"SsrMatching"]; Goptions.optdepr = false; Goptions.optread = (fun _ -> !pp_ref == ssr_pp); Goptions.optwrite = debug } @@ -464,7 +462,7 @@ let nb_cs_proj_args pc f u = | Sort s -> na (Sort_cs (Sorts.family s)) | Const (c',_) when Constant.equal c' pc -> nargs_of_proj u.up_f | Proj (c',_) when Constant.equal (Projection.constant c') pc -> nargs_of_proj u.up_f - | Var _ | Ind _ | Construct _ | Const _ -> na (Const_cs (global_of_constr f)) + | Var _ | Ind _ | Construct _ | Const _ -> na (Const_cs (fst @@ destRef f)) | _ -> -1 with Not_found -> -1 diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index 70c1077106..f6fbdaa958 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -164,7 +164,7 @@ let rawnum_of_r c = match DAst.get c with let s, i = if is_pos_or_zero i then SPlus, i else SMinus, neg i in let i = Bigint.to_string i in let se = if is_gr md glob_Rdiv then "-" else "" in - let e = se ^ Bigint.to_string e in + let e = "e" ^ se ^ Bigint.to_string e in s, { NumTok.int = i; frac = ""; exp = e } | _ -> raise Non_closed_number end diff --git a/pretyping/arguments_renaming.ml b/pretyping/arguments_renaming.ml index 36f35a67c3..59ca418a39 100644 --- a/pretyping/arguments_renaming.ml +++ b/pretyping/arguments_renaming.ml @@ -11,7 +11,6 @@ (*i*) open Names open Globnames -open Term open Constr open Context open Environ @@ -78,14 +77,14 @@ let rename_type ty ref = let rec rename_type_aux c = function | [] -> c | rename :: rest as renamings -> - match kind_of_type c with - | ProdType (old, s, t) -> + match Constr.kind c with + | Prod (old, s, t) -> mkProd (name_override old rename, s, rename_type_aux t rest) - | LetInType(old, s, b, t) -> + | LetIn (old, s, b, t) -> mkLetIn (old ,s, b, rename_type_aux t renamings) - | CastType (t,_) -> rename_type_aux t renamings - | SortType _ -> c - | AtomicType _ -> c in + | Cast (t,_, _) -> rename_type_aux t renamings + | _ -> c + in try rename_type_aux ty (arguments_names ref) with Not_found -> ty diff --git a/pretyping/cases.ml b/pretyping/cases.ml index cbd04a76ad..29d6726262 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -2164,7 +2164,7 @@ let constr_of_pat env sigma arsign pat avoid = let IndType (indf, _) = try find_rectype env sigma (lift (-(List.length realargs)) ty) with Not_found -> error_case_not_inductive env sigma - {uj_val = ty; uj_type = Typing.unsafe_type_of env sigma ty} + {uj_val = ty; uj_type = Retyping.get_type_of env sigma ty} in let (ind,u), params = dest_ind_family indf in let params = List.map EConstr.of_constr params in diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index 2b7ccbbcad..11c97221ec 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -196,7 +196,6 @@ let cofixp_reducible flgs _ stk = let get_debug_cbv = Goptions.declare_bool_option_and_ref ~depr:false ~value:false - ~name:"cbv visited constants display" ~key:["Debug";"Cbv"] (* Reduction of primitives *) diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 3c7f9a8f00..c4aa3479bf 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -36,7 +36,6 @@ open Globnames let get_use_typeclasses_for_conversion = Goptions.declare_bool_option_and_ref ~depr:false - ~name:"use typeclass resolution during conversion" ~key:["Typeclass"; "Resolution"; "For"; "Conversion"] ~value:true diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 037006bc47..83078660c5 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -228,7 +228,6 @@ let force_wildcard () = !wildcard_value let () = declare_bool_option { optdepr = false; - optname = "forced wildcard"; optkey = ["Printing";"Wildcard"]; optread = force_wildcard; optwrite = (:=) wildcard_value } @@ -237,7 +236,6 @@ let fast_name_generation = ref false let () = declare_bool_option { optdepr = false; - optname = "fast bound name generation algorithm"; optkey = ["Fast";"Name";"Printing"]; optread = (fun () -> !fast_name_generation); optwrite = (:=) fast_name_generation; @@ -248,7 +246,6 @@ let synthetize_type () = !synth_type_value let () = declare_bool_option { optdepr = false; - optname = "pattern matching return type synthesizability"; optkey = ["Printing";"Synth"]; optread = synthetize_type; optwrite = (:=) synth_type_value } @@ -258,7 +255,6 @@ let reverse_matching () = !reverse_matching_value let () = declare_bool_option { optdepr = false; - optname = "pattern-matching reversibility"; optkey = ["Printing";"Matching"]; optread = reverse_matching; optwrite = (:=) reverse_matching_value } @@ -268,7 +264,6 @@ let print_primproj_params () = !print_primproj_params_value let () = declare_bool_option { optdepr = false; - optname = "printing of primitive projection parameters"; optkey = ["Printing";"Primitive";"Projection";"Parameters"]; optread = print_primproj_params; optwrite = (:=) print_primproj_params_value } @@ -348,7 +343,6 @@ let print_factorize_match_patterns = ref true let () = declare_bool_option { optdepr = false; - optname = "factorization of \"match\" patterns in printing"; optkey = ["Printing";"Factorizable";"Match";"Patterns"]; optread = (fun () -> !print_factorize_match_patterns); optwrite = (fun b -> print_factorize_match_patterns := b) } @@ -358,7 +352,6 @@ let print_allow_match_default_clause = ref true let () = declare_bool_option { optdepr = false; - optname = "possible use of \"match\" default pattern in printing"; optkey = ["Printing";"Allow";"Match";"Default";"Clause"]; optread = (fun () -> !print_allow_match_default_clause); optwrite = (fun b -> print_allow_match_default_clause := b) } @@ -696,7 +689,7 @@ let detype_universe sigma u = if Univ.Level.is_set l then GSet else GType (hack_qualid_of_univ_level sigma l) in (s, n) in - Univ.Universe.map fn u + List.map fn (Univ.Universe.repr u) let detype_sort sigma = function | SProp -> UNamed [GSProp,0] diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 3bd52088c7..c67019c7ac 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -50,8 +50,6 @@ let default_flags env = let debug_unification = ref (false) let () = Goptions.(declare_bool_option { optdepr = false; - optname = - "Print states sent to Evarconv unification"; optkey = ["Debug";"Unification"]; optread = (fun () -> !debug_unification); optwrite = (fun a -> debug_unification:=a); @@ -60,8 +58,6 @@ let () = Goptions.(declare_bool_option { let debug_ho_unification = ref (false) let () = Goptions.(declare_bool_option { optdepr = false; - optname = - "Print higher-order unification debug information"; optkey = ["Debug";"HO";"Unification"]; optread = (fun () -> !debug_ho_unification); optwrite = (fun a -> debug_ho_unification:=a); @@ -269,7 +265,7 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) = let sk2 = Stack.append_app args sk2 in lookup_canonical_conversion (proji, Const_cs c2), sk2 | _ -> - let (c2, _) = Termops.global_of_constr sigma t2 in + let (c2, _) = try destRef sigma t2 with DestKO -> raise Not_found in lookup_canonical_conversion (proji, Const_cs c2),sk2 with Not_found -> let (c, cs) = lookup_canonical_conversion (proji,Default_cs) in diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index b54a713a16..aafd662f7d 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -311,21 +311,47 @@ let eq_alias a b = match a, b with | VarAlias id1, VarAlias id2 -> Id.equal id1 id2 | _ -> false -type aliasing = EConstr.t option * alias list +type 'a aliasing = 'a option * alias list let empty_aliasing = None, [] let make_aliasing c = Some c, [] let push_alias (alias, l) a = (alias, a :: l) + +module Alias = +struct +type t = { mutable lift : int; mutable data : EConstr.t } + +let make c = { lift = 0; data = c } + +let lift n { lift; data } = { lift = lift + n; data } + +let eval alias = + let c = EConstr.Vars.lift alias.lift alias.data in + let () = alias.lift <- 0 in + let () = alias.data <- c in + c + +let repr sigma alias = match EConstr.kind sigma alias.data with +| Rel n -> Some (RelAlias (n + alias.lift)) +| Var id -> Some (VarAlias id) +| _ -> None + +end + let lift_aliasing n (alias, l) = let map a = match a with | VarAlias _ -> a | RelAlias m -> RelAlias (m + n) in - (Option.map (fun c -> lift n c) alias, List.map map l) + (Option.map (fun c -> Alias.lift n c) alias, List.map map l) + +let cast_aliasing (alias, l) = match alias with +| None -> (None, l) +| Some c -> (Some (Alias.make c), l) type aliases = { - rel_aliases : aliasing Int.Map.t; - var_aliases : aliasing Id.Map.t; + rel_aliases : Alias.t aliasing Int.Map.t; + var_aliases : EConstr.t aliasing Id.Map.t; (** Only contains [VarAlias] *) } @@ -359,13 +385,14 @@ let compute_rel_aliases var_aliases rels sigma = | Var id' -> let aliases_of_n = try Id.Map.find id' var_aliases with Not_found -> empty_aliasing in - Int.Map.add n (push_alias aliases_of_n (VarAlias id')) aliases + Int.Map.add n (push_alias (cast_aliasing aliases_of_n) (VarAlias id')) aliases | Rel p -> let aliases_of_n = try Int.Map.find (p+n) aliases with Not_found -> empty_aliasing in Int.Map.add n (push_alias aliases_of_n (RelAlias (p+n))) aliases | _ -> - Int.Map.add n (make_aliasing (lift n (mkCast(t,DEFAULTcast,u)))) aliases) + let alias = Alias.lift n (Alias.make @@ mkCast(t,DEFAULTcast, u)) in + Int.Map.add n (make_aliasing alias) aliases) | LocalAssum _ -> aliases) ) rels @@ -387,7 +414,7 @@ let lift_aliases n aliases = let get_alias_chain_of sigma aliases x = match x with | RelAlias n -> (try Int.Map.find n aliases.rel_aliases with Not_found -> empty_aliasing) - | VarAlias id -> (try Id.Map.find id aliases.var_aliases with Not_found -> empty_aliasing) + | VarAlias id -> (try cast_aliasing (Id.Map.find id aliases.var_aliases) with Not_found -> empty_aliasing) let normalize_alias_opt_alias sigma aliases x = match get_alias_chain_of sigma aliases x with @@ -420,13 +447,14 @@ let extend_alias sigma decl { var_aliases; rel_aliases } = | Var id' -> let aliases_of_binder = try Id.Map.find id' var_aliases with Not_found -> empty_aliasing in - Int.Map.add 1 (push_alias aliases_of_binder (VarAlias id')) rel_aliases + Int.Map.add 1 (push_alias (cast_aliasing aliases_of_binder) (VarAlias id')) rel_aliases | Rel p -> let aliases_of_binder = try Int.Map.find (p+1) rel_aliases with Not_found -> empty_aliasing in Int.Map.add 1 (push_alias aliases_of_binder (RelAlias (p+1))) rel_aliases | _ -> - Int.Map.add 1 (make_aliasing (lift 1 t)) rel_aliases) + let alias = Alias.lift 1 (Alias.make t) in + Int.Map.add 1 (make_aliasing alias) rel_aliases) | LocalAssum _ -> rel_aliases in { var_aliases; rel_aliases } @@ -434,7 +462,7 @@ let expand_alias_once sigma aliases x = match get_alias_chain_of sigma aliases x with | None, [] -> None | Some a, [] -> Some a - | _, l -> Some (of_alias (List.last l)) + | _, l -> Some (Alias.make (of_alias (List.last l))) let expansions_of_var sigma aliases x = let (_, l) = get_alias_chain_of sigma aliases x in @@ -442,9 +470,9 @@ let expansions_of_var sigma aliases x = let expansion_of_var sigma aliases x = match get_alias_chain_of sigma aliases x with - | None, [] -> (false, of_alias x) - | Some a, _ -> (true, a) - | None, a :: _ -> (true, of_alias a) + | None, [] -> (false, Some x) + | Some a, _ -> (true, Alias.repr sigma a) + | None, a :: _ -> (true, Some a) let rec expand_vars_in_term_using sigma aliases t = match EConstr.kind sigma t with | Rel n -> of_alias (normalize_alias sigma aliases (RelAlias n)) @@ -482,10 +510,10 @@ let free_vars_and_rels_up_alias_expansion env sigma aliases c = match ck with | VarAlias id -> acc4 := Id.Set.add id !acc4 | RelAlias n -> if n >= depth+1 then acc3 := Int.Set.add (n-depth) !acc3); - match EConstr.kind sigma c' with - | Var id -> acc2 := Id.Set.add id !acc2 - | Rel n -> if n >= depth+1 then acc1 := Int.Set.add (n-depth) !acc1 - | _ -> frec (aliases,depth) c end + match c' with + | Some (VarAlias id) -> acc2 := Id.Set.add id !acc2 + | Some (RelAlias n) -> if n >= depth+1 then acc1 := Int.Set.add (n-depth) !acc1 + | None -> frec (aliases,depth) c end | Const _ | Ind _ | Construct _ -> acc2 := Id.Set.union (vars_of_global env (fst @@ EConstr.destRef sigma c)) !acc2 | _ -> @@ -971,7 +999,7 @@ let invert_arg_from_subst evd aliases k0 subst_in_env_extended_with_k_binders c_ with Not_found -> match expand_alias_once evd aliases t with | None -> raise Not_found - | Some c -> aux k (lift k c) in + | Some c -> aux k (Alias.eval (Alias.lift k c)) in try let c = aux 0 c_in_env_extended_with_k_binders in Invertible (UniqueProjection (c,!effects)) @@ -1223,7 +1251,7 @@ let rec is_constrainable_in top env evd k (ev,(fv_rels,fv_ids) as g) t = let has_constrainable_free_vars env evd aliases force k ev (fv_rels,fv_ids,let_rels,let_ids) t = match to_alias evd t with | Some t -> - let expanded, t' = expansion_of_var evd aliases t in + let expanded, _ = expansion_of_var evd aliases t in if expanded then (* t is a local definition, we keep it only if appears in the list *) (* of let-in variables effectively occurring on the right-hand side, *) diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index 02c2fc4a13..0969b3cc03 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -68,8 +68,9 @@ let glob_sort_eq u1 u2 = match u1, u2 with let binding_kind_eq bk1 bk2 = match bk1, bk2 with | Explicit, Explicit -> true - | Implicit, Implicit -> true - | (Explicit | Implicit), _ -> false + | NonMaxImplicit, NonMaxImplicit -> true + | MaxImplicit, MaxImplicit -> true + | (Explicit | NonMaxImplicit | MaxImplicit), _ -> false let case_style_eq s1 s2 = let open Constr in match s1, s2 with | LetStyle, LetStyle -> true diff --git a/pretyping/glob_term.ml b/pretyping/glob_term.ml index 44323441b6..485a19421d 100644 --- a/pretyping/glob_term.ml +++ b/pretyping/glob_term.ml @@ -65,7 +65,7 @@ and 'a cases_pattern_g = ('a cases_pattern_r, 'a) DAst.t type cases_pattern = [ `any ] cases_pattern_g -type binding_kind = Explicit | Implicit +type binding_kind = Explicit | MaxImplicit | NonMaxImplicit (** Representation of an internalized (or in other words globalized) term. *) type 'a glob_constr_r = diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 36b405e981..816a8c4703 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -28,14 +28,14 @@ open Context.Rel.Declaration let type_of_inductive env (ind,u) = let (mib,_ as specif) = Inductive.lookup_mind_specif env ind in - Typeops.check_hyps_inclusion env mkInd ind mib.mind_hyps; + Typeops.check_hyps_inclusion env (GlobRef.IndRef ind) mib.mind_hyps; Inductive.type_of_inductive env (specif,u) (* Return type as quoted by the user *) let type_of_constructor env (cstr,u) = let (mib,_ as specif) = Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in - Typeops.check_hyps_inclusion env mkConstruct cstr mib.mind_hyps; + Typeops.check_hyps_inclusion env (GlobRef.ConstructRef cstr) mib.mind_hyps; Inductive.type_of_constructor (cstr,u) specif (* Return constructor types in user form *) diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index 2db674d397..97fffbd7c8 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -26,6 +26,10 @@ open Context.Rel.Declaration exception Find_at of int +(* timing *) + +let timing_enabled = ref false + (* profiling *) let profiling_enabled = ref false @@ -79,6 +83,12 @@ let get_profiling_enabled () = let set_profiling_enabled b = profiling_enabled := b +let get_timing_enabled () = + !timing_enabled + +let set_timing_enabled b = + timing_enabled := b + let invert_tag cst tag reloc_tbl = try for j = 0 to Array.length reloc_tbl - 1 do @@ -496,19 +506,23 @@ let native_norm env sigma c ty = let ml_filename, prefix = Nativelib.get_ml_filename () in let code, upd = mk_norm_code env (evars_of_evar_map sigma) prefix c in let profile = get_profiling_enabled () in + let print_timing = get_timing_enabled () in + let tc0 = Sys.time () in let fn = Nativelib.compile ml_filename code ~profile:profile in - if !Flags.debug then Feedback.msg_debug (Pp.str "Running norm ..."); + let tc1 = Sys.time () in + let time_info = Format.sprintf "native_compute: Compilation done in %.5f@." (tc1 -. tc0) in + if print_timing then Feedback.msg_info (Pp.str time_info); let profiler_pid = if profile then start_profiler () else None in let t0 = Sys.time () in Nativelib.call_linker ~fatal:true env ~prefix fn (Some upd); let t1 = Sys.time () in if profile then stop_profiler profiler_pid; - let time_info = Format.sprintf "Evaluation done in %.5f@." (t1 -. t0) in - if !Flags.debug then Feedback.msg_debug (Pp.str time_info); + let time_info = Format.sprintf "native_compute: Evaluation done in %.5f@." (t1 -. t0) in + if print_timing then Feedback.msg_info (Pp.str time_info); let res = nf_val env sigma !Nativelib.rt1 ty in let t2 = Sys.time () in - let time_info = Format.sprintf "Reification done in %.5f@." (t2 -. t1) in - if !Flags.debug then Feedback.msg_debug (Pp.str time_info); + let time_info = Format.sprintf "native_compute: Reification done in %.5f@." (t2 -. t1) in + if print_timing then Feedback.msg_info (Pp.str time_info); EConstr.of_constr res let native_conv_generic pb sigma t = diff --git a/pretyping/nativenorm.mli b/pretyping/nativenorm.mli index 02de034fcb..458fe70e2c 100644 --- a/pretyping/nativenorm.mli +++ b/pretyping/nativenorm.mli @@ -20,6 +20,9 @@ val set_profile_filename : string -> unit val get_profiling_enabled : unit -> bool val set_profiling_enabled : bool -> unit +val get_timing_enabled : unit -> bool +val set_timing_enabled : bool -> unit + val native_norm : env -> evar_map -> constr -> types -> constr diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index bf61d44a10..ac1a4e88ef 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -47,7 +47,7 @@ open Evarconv module NamedDecl = Context.Named.Declaration -type typing_constraint = OfType of types | IsType | WithoutTypeConstraint +type typing_constraint = UnknownIfTermOrType | IsType | OfType of types | WithoutTypeConstraint let (!!) env = GlobEnv.env env @@ -125,7 +125,6 @@ let esearch_guard ?loc env sigma indexes fix = let is_strict_universe_declarations = Goptions.declare_bool_option_and_ref ~depr:false - ~name:"strict universe declaration" ~key:["Strict";"Universe";"Declaration"] ~value:true @@ -446,7 +445,7 @@ let pretype_ref ?loc sigma env ref us = Pretype_errors.error_var_not_found ?loc !!env sigma id) | ref -> let sigma, c = pretype_global ?loc univ_flexible env sigma ref us in - let ty = unsafe_type_of !!env sigma c in + let sigma, ty = type_of !!env sigma c in sigma, make_judge c ty let interp_sort ?loc evd : glob_sort -> _ = function @@ -1290,7 +1289,7 @@ let ise_pretype_gen flags env sigma lvar kind c = in let env = GlobEnv.make ~hypnaming env sigma lvar in let sigma', c', c'_ty = match kind with - | WithoutTypeConstraint -> + | WithoutTypeConstraint | UnknownIfTermOrType -> let sigma, j = pretype ~program_mode ~poly flags.use_typeclasses empty_tycon env sigma c in sigma, j.uj_val, j.uj_type | OfType exptyp -> diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index 18e416596e..ee57f690a1 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -38,7 +38,11 @@ val interp_known_glob_level : ?loc:Loc.t -> Evd.evar_map -> val search_guard : ?loc:Loc.t -> env -> int list list -> Constr.rec_declaration -> int array -type typing_constraint = OfType of types | IsType | WithoutTypeConstraint +type typing_constraint = + | UnknownIfTermOrType (** E.g., unknown if manual implicit arguments allowed *) + | IsType (** Necessarily a type *) + | OfType of types (** A term of the expected type *) + | WithoutTypeConstraint (** A term of unknown expected type *) type inference_hook = env -> evar_map -> Evar.t -> evar_map * constr diff --git a/pretyping/program.ml b/pretyping/program.ml index 1bc31646dd..9c478844aa 100644 --- a/pretyping/program.ml +++ b/pretyping/program.ml @@ -78,7 +78,6 @@ open Goptions let () = declare_bool_option { optdepr = false; - optname = "preferred transparency of Program obligations"; optkey = ["Transparent";"Obligations"]; optread = get_proofs_transparency; optwrite = set_proofs_transparency; } @@ -86,7 +85,6 @@ let () = let () = declare_bool_option { optdepr = false; - optname = "program cases"; optkey = ["Program";"Cases"]; optread = (fun () -> !program_cases); optwrite = (:=) program_cases } @@ -94,7 +92,6 @@ let () = let () = declare_bool_option { optdepr = false; - optname = "program generalized coercion"; optkey = ["Program";"Generalized";"Coercion"]; optread = (fun () -> !program_generalized_coercion); optwrite = (:=) program_generalized_coercion } diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 3b918b5396..879c007198 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -189,7 +189,7 @@ let rec cs_pattern_of_constr env t = let _, params = Inductive.find_rectype env ty in Const_cs (GlobRef.ConstRef (Projection.constant p)), None, params @ [c] | Sort s -> Sort_cs (Sorts.family s), None, [] - | _ -> Const_cs (Globnames.global_of_constr t) , None, [] + | _ -> Const_cs (fst @@ destRef t) , None, [] let warn_projection_no_head_constant = CWarnings.create ~name:"projection-no-head-constant" ~category:"typechecker" @@ -234,7 +234,7 @@ let compute_canonical_projections env ~warn (gref,ind) = ((GlobRef.ConstRef proji_sp, (patt, t)), { o_ORIGIN = gref ; o_DEF ; o_CTX ; o_INJ ; o_TABS ; o_TPARAMS ; o_NPARAMS ; o_TCOMPS }) :: acc - | exception Not_found -> + | exception DestKO -> if warn then warn_projection_no_head_constant (sign, env, t, gref, proji_sp); acc ) acc spopt diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 4d4fe13983..bfee07e7f0 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -32,8 +32,6 @@ exception Elimconst let () = Goptions.(declare_bool_option { optdepr = false; - optname = - "Generate weak constraints between Irrelevant universes"; optkey = ["Cumulativity";"Weak";"Constraints"]; optread = (fun () -> not !UState.drop_weak_constraints); optwrite = (fun a -> UState.drop_weak_constraints:=not a); @@ -722,32 +720,31 @@ let magicaly_constant_of_fixbody env sigma reference bd = function | Name.Anonymous -> bd | Name.Name id -> let open UnivProblem in - try - let (cst_mod,_) = Constant.repr2 reference in - let cst = Constant.make2 cst_mod (Label.of_id id) in + let (cst_mod,_) = Constant.repr2 reference in + let cst = Constant.make2 cst_mod (Label.of_id id) in + if not (Environ.mem_constant cst env) then bd + else let (cst, u), ctx = UnivGen.fresh_constant_instance env cst in match constant_opt_value_in env (cst,u) with | None -> bd | Some t -> let csts = EConstr.eq_constr_universes env sigma (EConstr.of_constr t) bd in begin match csts with - | Some csts -> - let subst = Set.fold (fun cst acc -> - let l, r = match cst with - | ULub (u, v) | UWeak (u, v) -> u, v - | UEq (u, v) | ULe (u, v) -> - let get u = Option.get (Universe.level u) in - get u, get v - in - Univ.LMap.add l r acc) - csts Univ.LMap.empty - in - let inst = Instance.subst_fn (fun u -> Univ.LMap.find u subst) u in - mkConstU (cst, EInstance.make inst) - | None -> bd + | Some csts -> + let subst = Set.fold (fun cst acc -> + let l, r = match cst with + | ULub (u, v) | UWeak (u, v) -> u, v + | UEq (u, v) | ULe (u, v) -> + let get u = Option.get (Universe.level u) in + get u, get v + in + Univ.LMap.add l r acc) + csts Univ.LMap.empty + in + let inst = Instance.subst_fn (fun u -> Univ.LMap.find u subst) u in + mkConstU (cst, EInstance.make inst) + | None -> bd end - with - | Not_found -> bd let contract_cofix ?env sigma ?reference (bodynum,(names,types,bodies as typedbodies)) = let nbodies = Array.length bodies in @@ -973,8 +970,6 @@ module CredNative = RedNative(CNativeEntries) let debug_RAKAM = ref (false) let () = Goptions.(declare_bool_option { optdepr = false; - optname = - "Print states of the Reductionops abstract machine"; optkey = ["Debug";"RAKAM"]; optread = (fun () -> !debug_RAKAM); optwrite = (fun a -> debug_RAKAM:=a); diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 10e8cf7e0f..4afed07eda 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -1197,7 +1197,7 @@ let abstract_scheme env sigma (locc,a) (c, sigma) = let pattern_occs loccs_trm = begin fun env sigma c -> let abstr_trm, sigma = List.fold_right (abstract_scheme env sigma) loccs_trm (c,sigma) in try - let _ = Typing.unsafe_type_of env sigma abstr_trm in + let sigma, _ = Typing.type_of env sigma abstr_trm in (sigma, applist(abstr_trm, List.map snd loccs_trm)) with Type_errors.TypeError (env',t) -> raise (ReductionTacticError (InvalidAbstraction (env,sigma,abstr_trm,(env',t)))) @@ -1311,11 +1311,9 @@ let reduce_to_ref_gen allow_product env sigma ref t = else error_cannot_recognize ref | _ -> - try - if GlobRef.equal (fst (global_of_constr sigma c)) ref - then it_mkProd_or_LetIn t l - else raise Not_found - with Not_found -> + if isRefX sigma ref c + then it_mkProd_or_LetIn t l + else try let t' = nf_betaiota env sigma (one_step_reduce env sigma t) in elimrec env t' l diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index 1541e96635..aa2e96c2d7 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -31,7 +31,6 @@ type hint_info = (Pattern.patvar list * Pattern.constr_pattern) hint_info_gen let get_typeclasses_unique_solutions = Goptions.declare_bool_option_and_ref ~depr:false - ~name:"check that typeclasses proof search returns unique solutions" ~key:["Typeclasses";"Unique";"Solutions"] ~value:false @@ -107,9 +106,9 @@ let class_info env sigma c = not_a_class env sigma (EConstr.of_constr (printable_constr_of_global c)) let global_class_of_constr env sigma c = - try let gr, u = Termops.global_of_constr sigma c in + try let gr, u = EConstr.destRef sigma c in GlobRef.Map.find gr !classes, u - with Not_found -> not_a_class env sigma c + with DestKO | Not_found -> not_a_class env sigma c let dest_class_app env sigma c = let cl, args = EConstr.decompose_app sigma c in @@ -125,9 +124,9 @@ let class_of_constr env sigma c = with e when CErrors.noncritical e -> None let is_class_constr sigma c = - try let gr, u = Termops.global_of_constr sigma c in + try let gr, u = EConstr.destRef sigma c in GlobRef.Map.mem gr !classes - with Not_found -> false + with DestKO | Not_found -> false let rec is_class_type evd c = let c, _ = Termops.decompose_app_vect evd c in @@ -140,9 +139,9 @@ let is_class_evar evd evi = is_class_type evd evi.Evd.evar_concl let is_class_constr sigma c = - try let gr, u = Termops.global_of_constr sigma c in + try let gr, u = EConstr.destRef sigma c in GlobRef.Map.mem gr !classes - with Not_found -> false + with DestKO | Not_found -> false let rec is_maybe_class_type evd c = let c, _ = Termops.decompose_app_vect evd c in diff --git a/pretyping/typing.ml b/pretyping/typing.ml index a15134f58d..b4c19775a7 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -27,6 +27,8 @@ open Arguments_renaming open Pretype_errors open Context.Rel.Declaration +module GR = Names.GlobRef + let meta_type evd mv = let ty = try Evd.meta_ftype evd mv @@ -253,6 +255,9 @@ let judge_of_type u = let judge_of_relative env v = Environ.on_judgment EConstr.of_constr (judge_of_relative env v) +let type_of_variable env id = + EConstr.of_constr (type_of_variable env id) + let judge_of_variable env id = Environ.on_judgment EConstr.of_constr (judge_of_variable env id) @@ -284,37 +289,36 @@ let judge_of_letin env name defj typj j = { uj_val = mkLetIn (make_annot name r, defj.uj_val, typj.utj_val, j.uj_val) ; uj_type = subst1 defj.uj_val j.uj_type } -let check_hyps_inclusion env sigma f x hyps = +let check_hyps_inclusion env sigma x hyps = let evars = Evarutil.safe_evar_value sigma, Evd.universes sigma in - let f x = EConstr.Unsafe.to_constr (f x) in - Typeops.check_hyps_inclusion env ~evars f x hyps + Typeops.check_hyps_inclusion env ~evars x hyps let type_of_constant env sigma (c,u) = let open Declarations in let cb = Environ.lookup_constant c env in - let () = check_hyps_inclusion env sigma mkConstU (c,u) cb.const_hyps in + let () = check_hyps_inclusion env sigma (GR.ConstRef c) cb.const_hyps in let u = EInstance.kind sigma u in let ty, csts = Environ.constant_type env (c,u) in let sigma = Evd.add_constraints sigma csts in - sigma, (EConstr.of_constr (rename_type ty (Names.GlobRef.ConstRef c))) + sigma, (EConstr.of_constr (rename_type ty (GR.ConstRef c))) let type_of_inductive env sigma (ind,u) = let open Declarations in let (mib,_ as specif) = Inductive.lookup_mind_specif env ind in - let () = check_hyps_inclusion env sigma mkIndU (ind,u) mib.mind_hyps in + let () = check_hyps_inclusion env sigma (GR.IndRef ind) mib.mind_hyps in let u = EInstance.kind sigma u in let ty, csts = Inductive.constrained_type_of_inductive env (specif,u) in let sigma = Evd.add_constraints sigma csts in - sigma, (EConstr.of_constr (rename_type ty (Names.GlobRef.IndRef ind))) + sigma, (EConstr.of_constr (rename_type ty (GR.IndRef ind))) let type_of_constructor env sigma ((ind,_ as ctor),u) = let open Declarations in let (mib,_ as specif) = Inductive.lookup_mind_specif env ind in - let () = check_hyps_inclusion env sigma mkIndU (ind,u) mib.mind_hyps in + let () = check_hyps_inclusion env sigma (GR.IndRef ind) mib.mind_hyps in let u = EInstance.kind sigma u in let ty, csts = Inductive.constrained_type_of_constructor (ctor,u) specif in let sigma = Evd.add_constraints sigma csts in - sigma, (EConstr.of_constr (rename_type ty (Names.GlobRef.ConstructRef ctor))) + sigma, (EConstr.of_constr (rename_type ty (GR.ConstructRef ctor))) let judge_of_int env v = Environ.on_judgment EConstr.of_constr (judge_of_int env v) diff --git a/pretyping/typing.mli b/pretyping/typing.mli index 1b07b2bb78..fd2dc7c2fc 100644 --- a/pretyping/typing.mli +++ b/pretyping/typing.mli @@ -30,6 +30,9 @@ val sort_of : env -> evar_map -> types -> evar_map * Sorts.t (** Typecheck a term has a given type (assuming the type is OK) *) val check : env -> evar_map -> constr -> types -> evar_map +(** Type of a variable. *) +val type_of_variable : env -> variable -> types + (** Returns the instantiated type of a metavariable *) val meta_type : evar_map -> metavariable -> types diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 6486435ca2..5b87603d54 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -46,7 +46,6 @@ module NamedDecl = Context.Named.Declaration let keyed_unification = ref (false) let () = Goptions.(declare_bool_option { optdepr = false; - optname = "Unification is keyed"; optkey = ["Keyed";"Unification"]; optread = (fun () -> !keyed_unification); optwrite = (fun a -> keyed_unification:=a); @@ -57,8 +56,6 @@ let is_keyed_unification () = !keyed_unification let debug_unification = ref (false) let () = Goptions.(declare_bool_option { optdepr = false; - optname = - "Print states sent to tactic unification"; optkey = ["Debug";"Tactic";"Unification"]; optread = (fun () -> !debug_unification); optwrite = (fun a -> debug_unification:=a); @@ -1274,12 +1271,14 @@ let applyHead env evd n c = else match EConstr.kind evd (whd_all env evd cty) with | Prod (_,c1,c2) -> - let (evd',evar) = - Evarutil.new_evar env evd ~src:(Loc.tag Evar_kinds.GoalEvar) c1 in - apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) evd' + let (evd,evar) = + Evarutil.new_evar env evd ~src:(Loc.tag Evar_kinds.GoalEvar) c1 + in + apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) evd | _ -> user_err Pp.(str "Apply_Head_Then") in - apprec n c (Typing.unsafe_type_of env evd c) evd + let evd, t = Typing.type_of env evd c in + apprec n c t evd let is_mimick_head sigma ts f = match EConstr.kind sigma f with diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index b55a41471a..f9f46e1ceb 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -143,7 +143,8 @@ let tag_var = tag Tag.variable let pr_generalization bk ak c = let hd, tl = match bk with - | Implicit -> "{", "}" + | NonMaxImplicit -> "[", "]" + | MaxImplicit -> "{", "}" | Explicit -> "(", ")" in (* TODO: syntax Abstraction Kind *) str "`" ++ str hd ++ c ++ str tl @@ -223,7 +224,7 @@ let tag_var = tag Tag.variable let pr_opt_type_spc pr = function | { CAst.v = CHole (_,IntroAnonymous,_) } -> mt () - | t -> str " :" ++ pr_sep_com (fun()->brk(1,2)) (pr ltop) t + | t -> str " :" ++ pr_sep_com (fun()->brk(1,4)) (pr ltop) t let pr_prim_token = function | Numeral (SPlus,n) -> str (NumTok.to_string n) @@ -324,12 +325,14 @@ let tag_var = tag Tag.variable let surround_impl k p = match k with | Explicit -> str"(" ++ p ++ str")" - | Implicit -> str"{" ++ p ++ str"}" + | NonMaxImplicit -> str"[" ++ p ++ str"]" + | MaxImplicit -> str"{" ++ p ++ str"}" let surround_implicit k p = match k with | Explicit -> p - | Implicit -> (str"{" ++ p ++ str"}") + | NonMaxImplicit -> str"[" ++ p ++ str"]" + | MaxImplicit -> (str"{" ++ p ++ str"}") let pr_binder many pr (nal,k,t) = match k with @@ -384,12 +387,12 @@ let tag_var = tag Tag.variable if is_open then pr_delimited_binders pr_com_at sep pr_c else pr_undelimited_binders sep pr_c - let pr_recursive_decl pr pr_dangling dangling_with_for id bl annot t c = + let pr_recursive_decl pr pr_dangling kw dangling_with_for id bl annot t c = let pr_body = if dangling_with_for then pr_dangling else pr in - pr_id id ++ (if bl = [] then mt () else str" ") ++ + hov 0 (str kw ++ brk(1,2) ++ pr_id id ++ (if bl = [] then mt () else brk(1,2)) ++ hov 0 (pr_undelimited_binders spc (pr ltop) bl ++ annot) ++ - pr_opt_type_spc pr t ++ str " :=" ++ + pr_opt_type_spc pr t ++ str " :=") ++ pr_sep_com (fun () -> brk(1,2)) (pr_body ltop) c let pr_guard_annot pr_aux bl ro = @@ -404,28 +407,28 @@ let tag_var = tag Tag.variable | CLocalPattern _ -> assert false in let ids = List.flatten (List.map names_of_binder bl) in if List.length ids > 1 then - spc() ++ str "{" ++ keyword "struct" ++ spc () ++ pr_id id ++ str"}" + spc() ++ str "{" ++ keyword "struct" ++ brk (1,1) ++ pr_id id ++ str"}" else mt() | CWfRec (id,c) -> - spc() ++ str "{" ++ keyword "wf" ++ spc () ++ pr_aux c ++ spc() ++ pr_lident id ++ str"}" + spc() ++ str "{" ++ keyword "wf" ++ brk (1,1) ++ pr_aux c ++ brk (1,1) ++ pr_lident id ++ str"}" | CMeasureRec (id,m,r) -> - spc() ++ str "{" ++ keyword "measure" ++ spc () ++ pr_aux m ++ - match id with None -> mt() | Some id -> spc () ++ pr_lident id ++ + spc() ++ str "{" ++ keyword "measure" ++ brk (1,1) ++ pr_aux m ++ + match id with None -> mt() | Some id -> brk (1,1) ++ pr_lident id ++ (match r with None -> mt() | Some r -> str" on " ++ pr_aux r) ++ str"}" - let pr_fixdecl pr prd dangling_with_for ({v=id},ro,bl,t,c) = + let pr_fixdecl pr prd kw dangling_with_for ({v=id},ro,bl,t,c) = let annot = pr_guard_annot (pr lsimpleconstr) bl ro in - pr_recursive_decl pr prd dangling_with_for id bl annot t c + pr_recursive_decl pr prd kw dangling_with_for id bl annot t c - let pr_cofixdecl pr prd dangling_with_for ({v=id},bl,t,c) = - pr_recursive_decl pr prd dangling_with_for id bl (mt()) t c + let pr_cofixdecl pr prd kw dangling_with_for ({v=id},bl,t,c) = + pr_recursive_decl pr prd kw dangling_with_for id bl (mt()) t c - let pr_recursive pr_decl id = function + let pr_recursive kw pr_decl id = function | [] -> anomaly (Pp.str "(co)fixpoint with no definition.") - | [d1] -> pr_decl false d1 + | [d1] -> pr_decl kw false d1 | dl -> - prlist_with_sep (fun () -> fnl() ++ keyword "with" ++ spc ()) - (pr_decl true) dl ++ + prlist_with_sep (fun () -> fnl()) + (pr_decl "with" true) dl ++ fnl() ++ keyword "for" ++ spc () ++ pr_id id let pr_asin pr na indnalopt = @@ -491,15 +494,13 @@ let tag_var = tag Tag.variable return (pr_cref r us, latom) | CFix (id,fix) -> return ( - hov 0 (keyword "fix" ++ spc () ++ - pr_recursive + hv 0 (pr_recursive "fix" (pr_fixdecl (pr mt) (pr_dangling_with_for mt pr)) id.v fix), lfix ) | CCoFix (id,cofix) -> return ( - hov 0 (keyword "cofix" ++ spc () ++ - pr_recursive + hv 0 (pr_recursive "cofix" (pr_cofixdecl (pr mt) (pr_dangling_with_for mt pr)) id.v cofix), lfix ) diff --git a/printing/printer.ml b/printing/printer.ml index 97e0528939..cc83a1dde0 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -38,7 +38,6 @@ let () = let open Goptions in declare_bool_option { optdepr = false; - optname = "printing of unfocused goal"; optkey = ["Printing";"Unfocused"]; optread = (fun () -> !enable_unfocused_goal_printing); optwrite = (fun b -> enable_unfocused_goal_printing:=b) } @@ -49,7 +48,6 @@ let () = let open Goptions in declare_bool_option { optdepr = false; - optname = "printing of goal tags"; optkey = ["Printing";"Goal";"Tags"]; optread = (fun () -> !enable_goal_tags_printing); optwrite = (fun b -> enable_goal_tags_printing:=b) } @@ -59,7 +57,6 @@ let () = let open Goptions in declare_bool_option { optdepr = false; - optname = "printing of goal names"; optkey = ["Printing";"Goal";"Names"]; optread = (fun () -> !enable_goal_names_printing); optwrite = (fun b -> enable_goal_names_printing:=b) } @@ -416,7 +413,6 @@ let () = let open Goptions in declare_int_option { optdepr = false; - optname = "the hypotheses limit"; optkey = ["Hyps";"Limit"]; optread = (fun () -> !print_hyps_limit); optwrite = (fun x -> print_hyps_limit := x) } @@ -625,7 +621,6 @@ let () = let open Goptions in declare_bool_option { optdepr = false; - optname = "Printing Dependent Evars Line"; optkey = ["Printing";"Dependent";"Evars";"Line"]; optread = (fun () -> !should_print_dependent_evars); optwrite = (fun v -> should_print_dependent_evars := v) } @@ -859,8 +854,6 @@ type axiom = | Constant of Constant.t (* An axiom or a constant. *) | Positive of MutInd.t (* A mutually inductive definition which has been assumed positive. *) | Guarded of GlobRef.t (* a constant whose (co)fixpoints have been assumed to be guarded *) - | TemplatePolymorphic of MutInd.t (* A mutually inductive definition whose template polymorphism - on parameter universes has not been checked. *) | TypeInType of GlobRef.t (* a constant which relies on type in type *) type context_object = @@ -880,13 +873,10 @@ struct Constant.CanOrd.compare k1 k2 | Positive m1 , Positive m2 -> MutInd.CanOrd.compare m1 m2 - | TemplatePolymorphic m1, TemplatePolymorphic m2 -> - MutInd.CanOrd.compare m1 m2 | Guarded k1 , Guarded k2 -> GlobRef.Ordered.compare k1 k2 | _ , Constant _ -> 1 | _ , Positive _ -> 1 - | _, TemplatePolymorphic _ -> 1 | _ -> -1 let compare x y = @@ -947,9 +937,6 @@ let pr_assumptionset env sigma s = hov 2 (safe_pr_inductive env m ++ spc () ++ strbrk"is assumed to be positive.") | Guarded gr -> hov 2 (safe_pr_global env gr ++ spc () ++ strbrk"is assumed to be guarded.") - | TemplatePolymorphic m -> - hov 2 (safe_pr_inductive env m ++ spc () ++ - strbrk"is assumed template polymorphic on all its universe parameters.") | TypeInType gr -> hov 2 (safe_pr_global env gr ++ spc () ++ strbrk"relies on an unsafe hierarchy.") in diff --git a/printing/printer.mli b/printing/printer.mli index 1d7a25cbb6..cd5151bd8f 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -231,8 +231,6 @@ type axiom = | Constant of Constant.t (* An axiom or a constant. *) | Positive of MutInd.t (* A mutually inductive definition which has been assumed positive. *) | Guarded of GlobRef.t (* a constant whose (co)fixpoints have been assumed to be guarded *) - | TemplatePolymorphic of MutInd.t (* A mutually inductive definition whose template polymorphism - on parameter universes has not been checked. *) | TypeInType of GlobRef.t (* a constant which relies on type in type *) type context_object = diff --git a/printing/printmod.ml b/printing/printmod.ml index 85bb287c22..a5fd7f69ed 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -44,7 +44,6 @@ let short = ref false let () = declare_bool_option { optdepr = false; - optname = "short module printing"; optkey = ["Short";"Module";"Printing"]; optread = (fun () -> !short) ; optwrite = ((:=) short) } diff --git a/printing/proof_diffs.ml b/printing/proof_diffs.ml index dec87f8071..d93dd15f91 100644 --- a/printing/proof_diffs.ml +++ b/printing/proof_diffs.ml @@ -69,7 +69,6 @@ let write_diffs_option opt = let () = Goptions.(declare_string_option { optdepr = false; - optname = "show diffs in proofs"; optkey = ["Diffs"]; optread = read_diffs_option; optwrite = write_diffs_option diff --git a/proofs/clenv.ml b/proofs/clenv.ml index e466992721..b0eb8dc646 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -128,8 +128,6 @@ let mk_clenv_from_n gls n (c,cty) = let mk_clenv_from gls = mk_clenv_from_n gls None -let mk_clenv_type_of gls t = mk_clenv_from gls (t,Tacmach.New.pf_unsafe_type_of gls t) - (******************************************************************) (* [mentions clenv mv0 mv1] is true if mv1 is defined and mentions diff --git a/proofs/clenv.mli b/proofs/clenv.mli index 3fca967395..7213c9318c 100644 --- a/proofs/clenv.mli +++ b/proofs/clenv.mli @@ -46,7 +46,6 @@ val clenv_meta_type : clausenv -> metavariable -> types val mk_clenv_from : Proofview.Goal.t -> EConstr.constr * EConstr.types -> clausenv val mk_clenv_from_n : Proofview.Goal.t -> int option -> EConstr.constr * EConstr.types -> clausenv -val mk_clenv_type_of : Proofview.Goal.t -> EConstr.constr -> clausenv val mk_clenv_from_env : env -> evar_map -> int option -> EConstr.constr * EConstr.types -> clausenv (** Refresh the universes in a clenv *) diff --git a/proofs/goal_select.ml b/proofs/goal_select.ml index a6e27c238f..36b50d9e9f 100644 --- a/proofs/goal_select.ml +++ b/proofs/goal_select.ml @@ -56,7 +56,6 @@ let parse_goal_selector = function let () = let open Goptions in declare_string_option { optdepr = false; - optname = "default goal selector" ; optkey = ["Default";"Goal";"Selector"] ; optread = begin fun () -> Pp.string_of_ppcmds diff --git a/proofs/logic.ml b/proofs/logic.ml index a361c4208e..bac13fcfc3 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -79,7 +79,7 @@ let check = ref false let with_check = Flags.with_option check let check_typability env sigma c = - if !check then let _ = unsafe_type_of env sigma (EConstr.of_constr c) in () + if !check then fst (type_of env sigma (EConstr.of_constr c)) else sigma (************************************************************************) (************************************************************************) @@ -363,7 +363,7 @@ let rec mk_refgoals sigma goal goalacc conclty trm = gl::goalacc, conclty, sigma, ev | Cast (t,k, ty) -> - check_typability env sigma ty; + let sigma = check_typability env sigma ty in let sigma = check_conv_leq_goal env sigma trm ty conclty in let res = mk_refgoals sigma goal goalacc ty t in (* we keep the casts (in particular VMcast and NATIVEcast) except @@ -430,13 +430,13 @@ and mk_hdgoals sigma goal goalacc trm = Goal.V82.mk_goal sigma hyps concl in match kind trm with | Cast (c,_, ty) when isMeta c -> - check_typability env sigma ty; + let sigma = check_typability env sigma ty in let (gl,ev,sigma) = mk_goal hyps (nf_betaiota env sigma (EConstr.of_constr ty)) in let ev = EConstr.Unsafe.to_constr ev in gl::goalacc,ty,sigma,ev | Cast (t,_, ty) -> - check_typability env sigma ty; + let sigma = check_typability env sigma ty in mk_refgoals sigma goal goalacc ty t | App (f,l) -> diff --git a/proofs/proof.ml b/proofs/proof.ml index 5ab4409f8b..e2ee5426b5 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -69,18 +69,15 @@ exception FullyUnfocused let _ = CErrors.register_handler begin function | CannotUnfocusThisWay -> - CErrors.user_err Pp.(str "This proof is focused, but cannot be unfocused this way") + Pp.str "This proof is focused, but cannot be unfocused this way" | NoSuchGoals (i,j) when Int.equal i j -> - CErrors.user_err ~hdr:"Focus" Pp.(str"No such goal (" ++ int i ++ str").") + Pp.(str "[Focus] No such goal (" ++ int i ++ str").") | NoSuchGoals (i,j) -> - CErrors.user_err ~hdr:"Focus" Pp.( - str"Not every goal in range ["++ int i ++ str","++int j++str"] exist." - ) + Pp.(str "[Focus] Not every goal in range ["++ int i ++ str","++int j++str"] exist.") | NoSuchGoal id -> - CErrors.user_err - ~hdr:"Focus" - Pp.(str "No such goal: " ++ str (Names.Id.to_string id) ++ str ".") - | FullyUnfocused -> CErrors.user_err Pp.(str "The proof is not focused") + Pp.(str "[Focus] No such goal: " ++ str (Names.Id.to_string id) ++ str ".") + | FullyUnfocused -> + Pp.str "The proof is not focused" | _ -> raise CErrors.Unhandled end diff --git a/proofs/proof_bullet.ml b/proofs/proof_bullet.ml index 66e2ae5c29..3ff0533b6b 100644 --- a/proofs/proof_bullet.ml +++ b/proofs/proof_bullet.ml @@ -79,7 +79,7 @@ module Strict = struct (function | FailedBullet (b,sugg) -> let prefix = Pp.(str"Wrong bullet " ++ pr_bullet b ++ str": ") in - CErrors.user_err ~hdr:"Focus" Pp.(prefix ++ suggest_on_error sugg) + Pp.(str "[Focus]" ++ spc () ++ prefix ++ suggest_on_error sugg) | _ -> raise CErrors.Unhandled) @@ -179,7 +179,6 @@ let current_behavior = ref Strict.strict let () = Goptions.(declare_string_option { optdepr = false; - optname = "bullet behavior"; optkey = ["Bullet";"Behavior"]; optread = begin fun () -> (!current_behavior).name @@ -204,8 +203,7 @@ exception SuggestNoSuchGoals of int * Proof.t let _ = CErrors.register_handler begin function | SuggestNoSuchGoals(n,proof) -> let suffix = suggest proof in - CErrors.user_err - Pp.(str "No such " ++ str (CString.plural n "goal") ++ str "." ++ - pr_non_empty_arg (fun x -> x) suffix) + Pp.(str "No such " ++ str (CString.plural n "goal") ++ str "." ++ + pr_non_empty_arg (fun x -> x) suffix) | _ -> raise CErrors.Unhandled end diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index 909804d0c9..fd689602df 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -138,7 +138,7 @@ module Make(T : Task) () = struct set_slave_opt tl (* We need to pass some options with one argument *) | ( "-I" | "-include" | "-top" | "-topfile" | "-coqlib" | "-exclude-dir" | "-compat" - | "-load-ml-object" | "-load-ml-source" | "-require" | "-w" | "-color" | "-init-file" + | "-require" | "-w" | "-color" | "-init-file" | "-profile-ltac-cutoff" | "-main-channel" | "-control-channel" | "-mangle-names" | "-set" | "-unset" | "-diffs" | "-mangle-name" | "-dump-glob" | "-bytecode-compiler" | "-native-compiler" as x) :: a :: tl -> x :: a :: set_slave_opt tl diff --git a/stm/stm.ml b/stm/stm.ml index eff2403eca..a521f9001d 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -2154,6 +2154,7 @@ let collect_proof keep cur hd brkind id = let is_defined = function | _, { expr = e } -> is_defined_expr e.CAst.v.expr && (not (Vernacprop.has_Fail e)) in + let has_default_proof_using = Option.has_some (Proof_using.get_default_proof_using ()) in let proof_using_ast = function | VernacProof(_,Some _) -> true | _ -> false @@ -2162,7 +2163,7 @@ let collect_proof keep cur hd brkind id = | Some (_, v) when proof_using_ast v.expr.CAst.v.expr && (not (Vernacprop.has_Fail v.expr)) -> Some v | _ -> None in - let has_proof_using x = proof_using_ast x <> None in + let has_proof_using x = has_default_proof_using || (proof_using_ast x <> None) in let proof_no_using = function | VernacProof(t,None) -> t | _ -> assert false @@ -2362,7 +2363,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = let st = Summary.remove_from_summary st Util.(pi1 summary_pstate) in let st = Summary.remove_from_summary st Util.(pi2 summary_pstate) in let st = Summary.remove_from_summary st Util.(pi3 summary_pstate) in - st, Lib.freeze ~marshallable:false in + st, Lib.freeze () in let inject_non_pstate (s,l) = Summary.unfreeze_summaries ~partial:true s; Lib.unfreeze l; update_global_env () @@ -2849,7 +2850,6 @@ let process_back_meta_command ~newtip ~head oid aast = let get_allow_nested_proofs = Goptions.declare_bool_option_and_ref ~depr:false - ~name:"Nested Proofs Allowed" ~key:Vernac_classifier.stm_allow_nested_proofs_option_name ~value:false diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index c5b3e0931b..65ef2ca8c6 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -131,7 +131,7 @@ let classify_vernac e = VtSideff ([id.CAst.v], VtLater) | VernacDefinition (_,({v=id},_),DefineBody _) -> VtSideff (idents_of_name id, VtLater) | VernacInductive (_, _,_,l) -> - let ids = List.map (fun (((_,({v=id},_)),_,_,_,cl),_) -> id :: match cl with + let ids = List.map (fun (((_,({v=id},_)),_,_,cl),_) -> id :: match cl with | Constructors l -> List.map (fun (_,({v=id},_)) -> id) l | RecordDecl (oid,l) -> (match oid with Some {v=x} -> [x] | _ -> []) @ CList.map_filter (function diff --git a/tactics/auto.ml b/tactics/auto.ml index 9c1a975330..1dde820075 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -177,7 +177,6 @@ let global_info_auto = ref false let add_option ls refe = Goptions.(declare_bool_option { optdepr = false; - optname = String.concat " " ls; optkey = ls; optread = (fun () -> !refe); optwrite = (:=) refe }) diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index cd6f445503..1bbcca8827 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -238,7 +238,7 @@ let decompose_applied_relation metas env sigma c ctype left2right = in try let others,(c1,c2) = split_last_two args in - let ty1, ty2 = Typing.unsafe_type_of env eqclause.evd c1, Typing.unsafe_type_of env eqclause.evd c2 in + let ty1, ty2 = Retyping.get_type_of env eqclause.evd c1, Retyping.get_type_of env eqclause.evd c2 in (* XXX: It looks like mk_clenv_from_env should be fixed instead? *) let open EConstr in let hyp_ty = Unsafe.to_constr ty in @@ -261,7 +261,7 @@ let decompose_applied_relation metas env sigma c ctype left2right = | None -> None let find_applied_relation ?loc metas env sigma c left2right = - let ctype = Typing.unsafe_type_of env sigma (EConstr.of_constr c) in + let ctype = Retyping.get_type_of env sigma (EConstr.of_constr c) in match decompose_applied_relation metas env sigma c ctype left2right with | Some c -> c | None -> diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index f8cb8870ea..28feeecb86 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -83,8 +83,6 @@ open Goptions let () = declare_bool_option { optdepr = false; - optname = "do typeclass search avoiding eta-expansions " ^ - " in proof terms (expensive)"; optkey = ["Typeclasses";"Limit";"Intros"]; optread = get_typeclasses_limit_intros; optwrite = set_typeclasses_limit_intros; } @@ -92,7 +90,6 @@ let () = let () = declare_bool_option { optdepr = false; - optname = "during typeclass resolution, solve instances according to their dependency order"; optkey = ["Typeclasses";"Dependency";"Order"]; optread = get_typeclasses_dependency_order; optwrite = set_typeclasses_dependency_order; } @@ -100,7 +97,6 @@ let () = let () = declare_bool_option { optdepr = false; - optname = "use iterative deepening strategy"; optkey = ["Typeclasses";"Iterative";"Deepening"]; optread = get_typeclasses_iterative_deepening; optwrite = set_typeclasses_iterative_deepening; } @@ -108,7 +104,6 @@ let () = let () = declare_bool_option { optdepr = false; - optname = "compat"; optkey = ["Typeclasses";"Filtered";"Unification"]; optread = get_typeclasses_filtered_unification; optwrite = set_typeclasses_filtered_unification; } @@ -116,7 +111,6 @@ let () = let () = declare_bool_option { optdepr = false; - optname = "debug output for typeclasses proof search"; optkey = ["Typeclasses";"Debug"]; optread = get_typeclasses_debug; optwrite = set_typeclasses_debug; } @@ -124,7 +118,6 @@ let () = let _ = declare_int_option { optdepr = false; - optname = "verbosity of debug output for typeclasses proof search"; optkey = ["Typeclasses";"Debug";"Verbosity"]; optread = get_typeclasses_verbose; optwrite = set_typeclasses_verbose; } @@ -132,7 +125,6 @@ let _ = let () = declare_int_option { optdepr = false; - optname = "depth for typeclasses proof search"; optkey = ["Typeclasses";"Depth"]; optread = get_typeclasses_depth; optwrite = set_typeclasses_depth; } @@ -1202,10 +1194,9 @@ let autoapply c i = in let flags = auto_unif_flags (Hints.Hint_db.transparent_state hintdb) in - let cty = Tacmach.New.pf_unsafe_type_of gl c in + let cty = Tacmach.New.pf_get_type_of gl c in let ce = mk_clenv_from gl (c,cty) in - unify_e_resolve false flags gl - ((c,cty,Univ.ContextSet.empty),0,ce) <*> + unify_e_resolve false flags gl ((c,cty,Univ.ContextSet.empty),0,ce) <*> Proofview.tclEVARMAP >>= (fun sigma -> let sigma = Typeclasses.make_unresolvables (fun ev -> Typeclasses.all_goals ev (Lazy.from_val (snd (Evd.find sigma ev).evar_source))) sigma in diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index 1f5a6380fd..c7b6998c8c 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -110,8 +110,7 @@ let contradiction_term (c,lbind as cl) = Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in - let type_of = Tacmach.New.pf_unsafe_type_of gl in - let typ = type_of c in + let typ = Tacmach.New.pf_get_type_of gl c in let _, ccl = splay_prod env sigma typ in if is_empty_type env sigma ccl then Tacticals.New.tclTHEN diff --git a/tactics/declare.ml b/tactics/declare.ml index 9a14f4d40f..ce2f3ec2c5 100644 --- a/tactics/declare.ml +++ b/tactics/declare.ml @@ -130,8 +130,8 @@ let dummy_constant cst = { let classify_constant cst = Substitute (dummy_constant cst) -let (inConstant : constant_obj -> obj) = - declare_object { (default_object "CONSTANT") with +let (objConstant : constant_obj Libobject.Dyn.tag) = + declare_object_full { (default_object "CONSTANT") with cache_function = cache_constant; load_function = load_constant; open_function = open_constant; @@ -139,6 +139,8 @@ let (inConstant : constant_obj -> obj) = subst_function = ident_subst_function; discharge_function = discharge_constant } +let inConstant v = Libobject.Dyn.Easy.inj v objConstant + let update_tables c = Impargs.declare_constant_implicits c; Notation.declare_ref_arguments_scope Evd.empty (GlobRef.ConstRef c) @@ -158,6 +160,18 @@ let register_side_effect (c, role) = | None -> () | Some (Evd.Schema (ind, kind)) -> DeclareScheme.declare_scheme kind [|ind,c|] +let get_roles export eff = + let map c = + let role = try Some (Cmap.find c eff.Evd.seff_roles) with Not_found -> None in + (c, role) + in + List.map map export + +let export_side_effects eff = + let export = Global.export_private_constants eff.Evd.seff_private in + let export = get_roles export eff in + List.iter register_side_effect export + let record_aux env s_ty s_bo = let open Environ in let in_ty = keep_hyps env s_ty in @@ -276,13 +290,6 @@ let cast_opaque_proof_entry (type a b) (entry : (a, b) effect_entry) (e : a proo opaque_entry_universes = univs; } -let get_roles export eff = - let map c = - let role = try Some (Cmap.find c eff.Evd.seff_roles) with Not_found -> None in - (c, role) - in - List.map map export - let feedback_axiom () = Feedback.(feedback AddedAxiom) let is_unsafe_typing_flags () = @@ -291,37 +298,36 @@ let is_unsafe_typing_flags () = let define_constant ~name cd = (* Logically define the constant and its subproofs, no libobject tampering *) - let export, decl, unsafe = match cd with - | DefinitionEntry de -> - (* We deal with side effects *) - if not de.proof_entry_opaque then - (* This globally defines the side-effects in the environment. *) - let body, eff = Future.force de.proof_entry_body in - let body, export = Global.export_private_constants (body, eff.Evd.seff_private) in - let export = get_roles export eff in - let de = { de with proof_entry_body = Future.from_val (body, ()) } in - let cd = Entries.DefinitionEntry (cast_proof_entry de) in - export, ConstantEntry cd, false - else - let map (body, eff) = body, eff.Evd.seff_private in - let body = Future.chain de.proof_entry_body map in - let de = { de with proof_entry_body = body } in - let de = cast_opaque_proof_entry EffectEntry de in - [], OpaqueEntry de, false - | ParameterEntry e -> - [], ConstantEntry (Entries.ParameterEntry e), not (Lib.is_modtype_strict()) - | PrimitiveEntry e -> - [], ConstantEntry (Entries.PrimitiveEntry e), false + let decl, unsafe = match cd with + | DefinitionEntry de -> + (* We deal with side effects *) + if not de.proof_entry_opaque then + let body, eff = Future.force de.proof_entry_body in + (* This globally defines the side-effects in the environment + and registers their libobjects. *) + let () = export_side_effects eff in + let de = { de with proof_entry_body = Future.from_val (body, ()) } in + let cd = Entries.DefinitionEntry (cast_proof_entry de) in + ConstantEntry cd, false + else + let map (body, eff) = body, eff.Evd.seff_private in + let body = Future.chain de.proof_entry_body map in + let de = { de with proof_entry_body = body } in + let de = cast_opaque_proof_entry EffectEntry de in + OpaqueEntry de, false + | ParameterEntry e -> + ConstantEntry (Entries.ParameterEntry e), not (Lib.is_modtype_strict()) + | PrimitiveEntry e -> + ConstantEntry (Entries.PrimitiveEntry e), false in let kn = Global.add_constant name decl in if unsafe || is_unsafe_typing_flags() then feedback_axiom(); - kn, export + kn let declare_constant ?(local = ImportDefaultBehavior) ~name ~kind cd = let () = check_exists name in - let kn, export = define_constant ~name cd in - (* Register the libobjects attached to the constants and its subproofs *) - let () = List.iter register_side_effect export in + let kn = define_constant ~name cd in + (* Register the libobjects attached to the constants *) let () = register_constant kn kind local in kn @@ -357,10 +363,12 @@ type variable_declaration = (* This object is only for things which iterate over objects to find variables (only Prettyp.print_context AFAICT) *) -let inVariable : unit -> obj = - declare_object { (default_object "VARIABLE") with +let objVariable : unit Libobject.Dyn.tag = + declare_object_full { (default_object "VARIABLE") with classify_function = (fun () -> Dispose)} +let inVariable v = Libobject.Dyn.Easy.inj v objVariable + let declare_variable ~name ~kind d = (* Variables are distinguished by only short names *) if Decls.variable_exists name then @@ -373,10 +381,8 @@ let declare_variable ~name ~kind d = | SectionLocalDef (de) -> (* The body should already have been forced upstream because it is a section-local definition, but it's not enforced by typing *) - let (body, eff) = Future.force de.proof_entry_body in - let ((body, uctx), export) = Global.export_private_constants (body, eff.Evd.seff_private) in - let eff = get_roles export eff in - let () = List.iter register_side_effect eff in + let ((body, uctx), eff) = Future.force de.proof_entry_body in + let () = export_side_effects eff in let poly, univs = match de.proof_entry_universes with | Monomorphic_entry uctx -> false, uctx | Polymorphic_entry (_, uctx) -> true, Univ.ContextSet.of_context uctx @@ -497,4 +503,9 @@ module Internal = struct ; proof_entry_type = Some typ }, args + type nonrec constant_obj = constant_obj + + let objVariable = objVariable + let objConstant = objConstant + end diff --git a/tactics/declare.mli b/tactics/declare.mli index c646d2f85b..00c1e31717 100644 --- a/tactics/declare.mli +++ b/tactics/declare.mli @@ -131,7 +131,8 @@ val check_exists : Id.t -> unit (* Used outside this module only in indschemes *) exception AlreadyDeclared of (string option * Id.t) -(* For legacy support, do not use *) +(** {6 For legacy support, do not use} *) + module Internal : sig val map_entry_body : f:('a Entries.proof_output -> 'b Entries.proof_output) -> 'a proof_entry -> 'b proof_entry @@ -145,4 +146,9 @@ module Internal : sig val shrink_entry : EConstr.named_context -> 'a proof_entry -> 'a proof_entry * Constr.constr list + type constant_obj + + val objConstant : constant_obj Libobject.Dyn.tag + val objVariable : unit Libobject.Dyn.tag + end diff --git a/tactics/eauto.ml b/tactics/eauto.ml index 361215bf38..9a1e6a6736 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -32,11 +32,13 @@ let eauto_unif_flags = auto_flags_of_state TransparentState.full let e_give_exact ?(flags=eauto_unif_flags) c = Proofview.Goal.enter begin fun gl -> - let t1 = Tacmach.New.pf_unsafe_type_of gl c in + let sigma, t1 = Tacmach.New.pf_type_of gl c in let t2 = Tacmach.New.pf_concl gl in - let sigma = Tacmach.New.project gl in if occur_existential sigma t1 || occur_existential sigma t2 then - Tacticals.New.tclTHEN (Clenvtac.unify ~flags t1) (exact_no_check c) + Tacticals.New.tclTHENLIST + [Proofview.Unsafe.tclEVARS sigma; + Clenvtac.unify ~flags t1; + exact_no_check c] else exact_check c end @@ -329,7 +331,6 @@ let global_info_eauto = ref false let () = Goptions.(declare_bool_option { optdepr = false; - optname = "Debug Eauto"; optkey = ["Debug";"Eauto"]; optread = (fun () -> !global_debug_eauto); optwrite = (:=) global_debug_eauto }) @@ -337,7 +338,6 @@ let () = let () = Goptions.(declare_bool_option { optdepr = false; - optname = "Info Eauto"; optkey = ["Info";"Eauto"]; optread = (fun () -> !global_info_eauto); optwrite = (:=) global_info_eauto }) diff --git a/tactics/elim.ml b/tactics/elim.ml index ea61b8e4df..379a8d5401 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -80,14 +80,11 @@ let up_to_delta = ref false (* true *) let general_decompose recognizer c = Proofview.Goal.enter begin fun gl -> - let type_of = pf_unsafe_type_of gl in - let env = pf_env gl in - let sigma = project gl in - let typc = type_of c in + let typc = pf_get_type_of gl c in tclTHENS (cut typc) [ tclTHEN (intro_using tmphyp_name) (onLastHypId - (ifOnHyp (recognizer env sigma) (general_decompose_aux (recognizer env sigma)) + (ifOnHyp recognizer (general_decompose_aux recognizer) (fun id -> clear [id]))); exact_no_check c ] end @@ -136,7 +133,7 @@ let induction_trailer abs_i abs_j bargs = (onLastHypId (fun id -> Proofview.Goal.enter begin fun gl -> - let idty = pf_unsafe_type_of gl (mkVar id) in + let idty = pf_get_type_of gl (mkVar id) in let fvty = global_vars (pf_env gl) (project gl) idty in let possible_bring_hyps = (List.tl (nLastDecls gl (abs_j - abs_i))) @ bargs.Tacticals.assums diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml index d6fda00ad8..6cdb24965d 100644 --- a/tactics/elimschemes.ml +++ b/tactics/elimschemes.ml @@ -49,14 +49,14 @@ let optimize_non_type_induction_scheme kind dep sort ind = let sigma = Evd.minimize_universes sigma in (Evarutil.nf_evars_universes sigma c', Evd.evar_universe_context sigma) else - let sigma, pind = Evd.fresh_inductive_instance env sigma ind in + let sigma, pind = Evd.fresh_inductive_instance ~rigid:UState.univ_rigid env sigma ind in let sigma, c = build_induction_scheme env sigma pind dep sort in (c, Evd.evar_universe_context sigma) let build_induction_scheme_in_type dep sort ind = let env = Global.env () in let sigma = Evd.from_env env in - let sigma, pind = Evd.fresh_inductive_instance env sigma ind in + let sigma, pind = Evd.fresh_inductive_instance ~rigid:UState.univ_rigid env sigma ind in let sigma, c = build_induction_scheme env sigma pind dep sort in c, Evd.evar_universe_context sigma diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index bdfd200988..a82b26f428 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -195,13 +195,13 @@ let rec solveArg hyps eqonleft mk largs rargs = match largs, rargs with ] | a1 :: largs, a2 :: rargs -> Proofview.Goal.enter begin fun gl -> - let rectype = pf_unsafe_type_of gl a1 in + let sigma, rectype = pf_type_of gl a1 in let decide = mk rectype a1 a2 in let tac hyp = solveArg (hyp :: hyps) eqonleft mk largs rargs in let subtacs = if eqonleft then [eqCase tac;diseqCase hyps eqonleft;default_auto] else [diseqCase hyps eqonleft;eqCase tac;default_auto] in - (tclTHENS (elim_type decide) subtacs) + tclTHEN (Proofview.Unsafe.tclEVARS sigma) (tclTHENS (elim_type decide) subtacs) end | _ -> invalid_arg "List.fold_right2" @@ -274,11 +274,12 @@ let compare c1 c2 = pf_constr_of_global (lib_ref "core.eq.type") >>= fun eqc -> pf_constr_of_global (lib_ref "core.not.type") >>= fun notc -> Proofview.Goal.enter begin fun gl -> - let rectype = pf_unsafe_type_of gl c1 in + let sigma, rectype = pf_type_of gl c1 in let ops = (opc,eqc,notc) in let decide = mkDecideEqGoal true ops rectype c1 c2 in - (tclTHENS (cut decide) - [(tclTHEN intro - (tclTHEN (onLastHyp simplest_case) clear_last)); - decideEquality rectype ops]) + tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (tclTHENS (cut decide) + [(tclTHEN intro + (tclTHEN (onLastHyp simplest_case) clear_last)); + decideEquality rectype ops]) end diff --git a/tactics/equality.ml b/tactics/equality.ml index 96b61b6994..7393454ba9 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -72,7 +72,6 @@ let use_injection_in_context = function let () = declare_bool_option { optdepr = false; - optname = "injection in context"; optkey = ["Structural";"Injection"]; optread = (fun () -> !injection_in_context) ; optwrite = (fun b -> injection_in_context := b) } @@ -356,7 +355,7 @@ let find_elim hdcncl lft2rgt dep cls ot = Proofview.Goal.enter_one begin fun gl -> let sigma = project gl in let is_global_exists gr c = - Coqlib.has_ref gr && Termops.is_global sigma (Coqlib.lib_ref gr) c + Coqlib.has_ref gr && isRefX sigma (Coqlib.lib_ref gr) c in let inccl = Option.is_empty cls in let env = Proofview.Goal.env gl in @@ -734,7 +733,6 @@ let keep_proof_equalities_for_injection = ref false let () = declare_bool_option { optdepr = false; - optname = "injection on prop arguments"; optkey = ["Keep";"Proof";"Equalities"]; optread = (fun () -> !keep_proof_equalities_for_injection) ; optwrite = (fun b -> keep_proof_equalities_for_injection := b) } @@ -1062,14 +1060,14 @@ let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause = let onEquality with_evars tac (c,lbindc) = Proofview.Goal.enter begin fun gl -> - let type_of = pf_unsafe_type_of gl in let reduce_to_quantified_ind = pf_apply Tacred.reduce_to_quantified_ind gl in - let t = type_of c in + let t = pf_get_type_of gl c in let t' = try snd (reduce_to_quantified_ind t) with UserError _ -> t in let eq_clause = pf_apply make_clenv_binding gl (c,t') lbindc in let eq_clause' = Clenvtac.clenv_pose_dependent_evars ~with_evars eq_clause in let eqn = clenv_type eq_clause' in - let (eq,u,eq_args) = find_this_eq_data_decompose gl eqn in + (* FIXME evar leak *) + let (eq,u,eq_args) = pf_apply find_this_eq_data_decompose gl eqn in tclTHEN (Proofview.Unsafe.tclEVARS eq_clause'.evd) (tac (eq,eqn,eq_args) eq_clause') @@ -1165,7 +1163,7 @@ let minimal_free_rels_rec env sigma = let rec minimalrec_free_rels_rec prev_rels (c,cty) = let (cty,direct_rels) = minimal_free_rels env sigma (c,cty) in let combined_rels = Int.Set.union prev_rels direct_rels in - let folder rels i = snd (minimalrec_free_rels_rec rels (c, unsafe_type_of env sigma (mkRel i))) + let folder rels i = snd (minimalrec_free_rels_rec rels (c, get_type_of env sigma (mkRel i))) in (cty, List.fold_left folder combined_rels (Int.Set.elements (Int.Set.diff direct_rels prev_rels))) in minimalrec_free_rels_rec Int.Set.empty @@ -1210,7 +1208,7 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = let rec sigrec_clausal_form sigma siglen p_i = if Int.equal siglen 0 then (* is the default value typable with the expected type *) - let dflt_typ = unsafe_type_of env sigma dflt in + let sigma, dflt_typ = type_of env sigma dflt in try let sigma = Evarconv.unify_leq_delay env sigma dflt_typ p_i in let sigma = Evarconv.solve_unif_constraints_with_heuristics env sigma in @@ -1224,29 +1222,21 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = let sigma, ev = Evarutil.new_evar env sigma a in let rty = beta_applist sigma (p_i_minus_1,[ev]) in let sigma, tuple_tail = sigrec_clausal_form sigma (siglen-1) rty in - let evopt = match EConstr.kind sigma ev with Evar _ -> None | _ -> Some ev in - match evopt with - | Some w -> - let w_type = unsafe_type_of env sigma w in - begin match Evarconv.unify_leq_delay env sigma w_type a with - | sigma -> - let sigma, exist_term = Evd.fresh_global env sigma sigdata.intro in - sigma, applist(exist_term,[a;p_i_minus_1;w;tuple_tail]) - | exception Evarconv.UnableToUnify _ -> - user_err Pp.(str "Cannot solve a unification problem.") - end - | None -> - (* This at least happens if what has been detected as a - dependency is not one; use an evasive error message; - even if the problem is upwards: unification should be - tried in the first place in make_iterated_tuple instead - of approximatively computing the free rels; then - unsolved evars would mean not binding rel *) - user_err Pp.(str "Cannot solve a unification problem.") + if EConstr.isEvar sigma ev then + (* This at least happens if what has been detected as a + dependency is not one; use an evasive error message; + even if the problem is upwards: unification should be + tried in the first place in make_iterated_tuple instead + of approximatively computing the free rels; then + unsolved evars would mean not binding rel *) + user_err Pp.(str "Cannot solve a unification problem.") + else + let sigma, exist_term = Evd.fresh_global env sigma sigdata.intro in + sigma, applist(exist_term,[a;p_i_minus_1;ev;tuple_tail]) in let sigma = Evd.clear_metas sigma in let sigma, scf = sigrec_clausal_form sigma siglen ty in - sigma, Evarutil.nf_evar sigma scf + sigma, Evarutil.nf_evar sigma scf (* The problem is to build a destructor (a generalization of the predecessor) which, when applied to a term made of constructors @@ -1319,7 +1309,7 @@ let make_iterated_tuple env sigma dflt (z,zty) = sigma, (tuple,tuplety,dfltval) let rec build_injrec env sigma dflt c = function - | [] -> make_iterated_tuple env sigma dflt (c,unsafe_type_of env sigma c) + | [] -> make_iterated_tuple env sigma dflt (c,get_type_of env sigma c) | ((sp,cnum),argnum)::l -> try let (cnum_nlams,cnum_env,kont) = descend_then env sigma c cnum in @@ -1341,17 +1331,17 @@ let inject_if_homogenous_dependent_pair ty = Proofview.Goal.enter begin fun gl -> try let sigma = Tacmach.New.project gl in - let eq,u,(t,t1,t2) = find_this_eq_data_decompose gl ty in + let eq,u,(t,t1,t2) = pf_apply find_this_eq_data_decompose gl ty in (* fetch the informations of the pair *) let sigTconstr = Coqlib.(lib_ref "core.sigT.type") in let existTconstr = Coqlib.lib_ref "core.sigT.intro" in (* check whether the equality deals with dep pairs or not *) let eqTypeDest = fst (decompose_app sigma t) in - if not (Termops.is_global sigma sigTconstr eqTypeDest) then raise Exit; + if not (isRefX sigma sigTconstr eqTypeDest) then raise Exit; let hd1,ar1 = decompose_app_vect sigma t1 and hd2,ar2 = decompose_app_vect sigma t2 in - if not (Termops.is_global sigma existTconstr hd1) then raise Exit; - if not (Termops.is_global sigma existTconstr hd2) then raise Exit; + if not (isRefX sigma existTconstr hd1) then raise Exit; + if not (isRefX sigma existTconstr hd2) then raise Exit; let (ind, _), _ = try pf_apply find_mrectype gl ar1.(0) with Not_found -> raise Exit in (* check if the user has declared the dec principle *) (* and compare the fst arguments of the dep pair *) @@ -1360,7 +1350,7 @@ let inject_if_homogenous_dependent_pair ty = if not (Ind_tables.check_scheme (!eq_dec_scheme_kind_name()) ind && pf_apply is_conv gl ar1.(2) ar2.(2)) then raise Exit; check_required_library ["Coq";"Logic";"Eqdep_dec"]; - let new_eq_args = [|pf_unsafe_type_of gl ar1.(3);ar1.(3);ar2.(3)|] in + let new_eq_args = [|pf_get_type_of gl ar1.(3);ar1.(3);ar2.(3)|] in let inj2 = lib_ref "core.eqdep_dec.inj_pair2" in let c, eff = find_scheme (!eq_dec_scheme_kind_name()) ind in (* cut with the good equality and prove the requested goal *) @@ -1603,7 +1593,7 @@ let cutSubstInConcl l2r eqn = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in - let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl eqn in + let (lbeq,u,(t,e1,e2)) = pf_apply find_eq_data_decompose gl eqn in let typ = pf_concl gl in let (e1,e2) = if l2r then (e1,e2) else (e2,e1) in let (sigma, (typ, expected)) = subst_tuple_term env sigma e1 e2 typ in @@ -1620,7 +1610,7 @@ let cutSubstInHyp l2r eqn id = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in - let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl eqn in + let (lbeq,u,(t,e1,e2)) = pf_apply find_eq_data_decompose gl eqn in let typ = pf_get_hyp_typ id gl in let (e1,e2) = if l2r then (e1,e2) else (e2,e1) in let (sigma, (typ, expected)) = subst_tuple_term env sigma e1 e2 typ in @@ -1694,14 +1684,13 @@ let regular_subst_tactic = ref true let () = declare_bool_option { optdepr = false; - optname = "more regular behavior of tactic subst"; optkey = ["Regular";"Subst";"Tactic"]; optread = (fun () -> !regular_subst_tactic); optwrite = (:=) regular_subst_tactic } let restrict_to_eq_and_identity eq = (* compatibility *) - if not (is_global (lib_ref "core.eq.type") eq) && - not (is_global (lib_ref "core.identity.type") eq) + if not (Constr.isRefX (lib_ref "core.eq.type") eq) && + not (Constr.isRefX (lib_ref "core.identity.type") eq) then raise Constr_matching.PatternMatchingFailure exception FoundHyp of (Id.t * constr * bool) @@ -1715,7 +1704,7 @@ let is_eq_x gl x d = | _ -> false in let c = pf_nf_evar gl (NamedDecl.get_type d) in - let (_,lhs,rhs) = pi3 (find_eq_data_decompose gl c) in + let (_,lhs,rhs) = pi3 (pf_apply find_eq_data_decompose gl c) in if (is_var x lhs) && not (local_occur_var (project gl) x rhs) then raise (FoundHyp (id,rhs,true)); if (is_var x rhs) && not (local_occur_var (project gl) x lhs) then raise (FoundHyp (id,lhs,false)) with Constr_matching.PatternMatchingFailure -> @@ -1812,7 +1801,7 @@ let subst_all ?(flags=default_subst_tactic_flags) () = let find_equations gl = let env = Proofview.Goal.env gl in let sigma = project gl in - let find_eq_data_decompose = find_eq_data_decompose gl in + let find_eq_data_decompose = pf_apply find_eq_data_decompose gl in let select_equation_name decl = try let lbeq,u,(_,x,y) = find_eq_data_decompose (NamedDecl.get_type decl) in @@ -1837,7 +1826,7 @@ let subst_all ?(flags=default_subst_tactic_flags) () = Proofview.Goal.enter begin fun gl -> let sigma = project gl in let env = Proofview.Goal.env gl in - let find_eq_data_decompose = find_eq_data_decompose gl in + let find_eq_data_decompose = pf_apply find_eq_data_decompose gl in let c = pf_get_hyp hyp gl |> NamedDecl.get_type in let _,_,(_,x,y) = find_eq_data_decompose c in (* J.F.: added to prevent failure on goal containing x=x as an hyp *) @@ -1863,7 +1852,7 @@ let subst_all ?(flags=default_subst_tactic_flags) () = let-ins *) Proofview.Goal.enter begin fun gl -> let sigma = project gl in - let find_eq_data_decompose = find_eq_data_decompose gl in + let find_eq_data_decompose = pf_apply find_eq_data_decompose gl in let test (_,c) = try let lbeq,u,(_,x,y) = find_eq_data_decompose c in @@ -1887,19 +1876,19 @@ let subst_all ?(flags=default_subst_tactic_flags) () = let cond_eq_term_left c t gl = try - let (_,x,_) = pi3 (find_eq_data_decompose gl t) in + let (_,x,_) = pi3 (pf_apply find_eq_data_decompose gl t) in if pf_conv_x gl c x then true else failwith "not convertible" with Constr_matching.PatternMatchingFailure -> failwith "not an equality" let cond_eq_term_right c t gl = try - let (_,_,x) = pi3 (find_eq_data_decompose gl t) in + let (_,_,x) = pi3 (pf_apply find_eq_data_decompose gl t) in if pf_conv_x gl c x then false else failwith "not convertible" with Constr_matching.PatternMatchingFailure -> failwith "not an equality" let cond_eq_term c t gl = try - let (_,x,y) = pi3 (find_eq_data_decompose gl t) in + let (_,x,y) = pi3 (pf_apply find_eq_data_decompose gl t) in if pf_conv_x gl c x then true else if pf_conv_x gl c y then false else failwith "not convertible" diff --git a/tactics/hints.ml b/tactics/hints.ml index 7b3797119a..86aa046586 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -26,7 +26,6 @@ open Libnames open Smartlocate open Termops open Inductiveops -open Typing open Typeclasses open Pattern open Patternops @@ -206,7 +205,6 @@ let write_warn_hint = function let () = Goptions.(declare_string_option { optdepr = false; - optname = "behavior of non-imported hints"; optkey = ["Loose"; "Hint"; "Behavior"]; optread = read_warn_hint; optwrite = write_warn_hint; @@ -966,16 +964,17 @@ let make_mode ref m = let make_trivial env sigma poly ?(name=PathAny) r = let c,ctx = fresh_global_or_constr env sigma poly r in let sigma = Evd.merge_context_set univ_flexible sigma ctx in - let t = hnf_constr env sigma (unsafe_type_of env sigma c) in + let t = hnf_constr env sigma (Retyping.get_type_of env sigma c) in let hd = head_constr sigma t in let ce = mk_clenv_from_env env sigma None (c,t) in - (Some hd, { pri=1; - poly = poly; - pat = Some (Patternops.pattern_of_constr env ce.evd (EConstr.to_constr sigma (clenv_type ce))); - name = name; - db = None; - secvars = secvars_of_constr env sigma c; - code= with_uid (Res_pf_THEN_trivial_fail(c,t,ctx)) }) + (Some hd, + { pri=1; + poly = poly; + pat = Some (Patternops.pattern_of_constr env ce.evd (EConstr.to_constr sigma (clenv_type ce))); + name = name; + db = None; + secvars = secvars_of_constr env sigma c; + code= with_uid (Res_pf_THEN_trivial_fail(c,t,ctx)) }) diff --git a/tactics/hints.mli b/tactics/hints.mli index 2a9b71387e..9c9f0b7708 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -160,6 +160,8 @@ module Hint_db : val iter : (GlobRef.t option -> hint_mode array list -> full_hint list -> unit) -> t -> unit + val fold : (GlobRef.t option -> hint_mode array list -> full_hint list -> 'a -> 'a) -> t -> 'a -> 'a + val use_dn : t -> bool val transparent_state : t -> TransparentState.t val set_transparent_state : t -> TransparentState.t -> t diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index 90a9a7acd9..5404404af5 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -19,7 +19,6 @@ open Inductiveops open Constr_matching open Coqlib open Declarations -open Tacmach.New open Context.Rel.Declaration module RelDecl = Context.Rel.Declaration @@ -432,10 +431,10 @@ let match_eq sigma eqn (ref, hetero) = in match EConstr.kind sigma eqn with | App (c, [|t; x; y|]) -> - if not hetero && Termops.is_global sigma ref c then PolymorphicLeibnizEq (t, x, y) + if not hetero && isRefX sigma ref c then PolymorphicLeibnizEq (t, x, y) else raise PatternMatchingFailure | App (c, [|t; x; t'; x'|]) -> - if hetero && Termops.is_global sigma ref c then HeterogenousEq (t, x, t', x') + if hetero && isRefX sigma ref c then HeterogenousEq (t, x, t', x') else raise PatternMatchingFailure | _ -> raise PatternMatchingFailure @@ -452,26 +451,26 @@ let find_eq_data sigma eqn = (* fails with PatternMatchingFailure *) let hd,u = destInd sigma (fst (destApp sigma eqn)) in d,u,k -let extract_eq_args gl = function +let extract_eq_args env sigma = function | MonomorphicLeibnizEq (e1,e2) -> - let t = pf_unsafe_type_of gl e1 in (t,e1,e2) + let t = Retyping.get_type_of env sigma e1 in (t,e1,e2) | PolymorphicLeibnizEq (t,e1,e2) -> (t,e1,e2) | HeterogenousEq (t1,e1,t2,e2) -> - if pf_conv_x gl t1 t2 then (t1,e1,e2) + if Reductionops.is_conv env sigma t1 t2 then (t1,e1,e2) else raise PatternMatchingFailure -let find_eq_data_decompose gl eqn = - let (lbeq,u,eq_args) = find_eq_data (project gl) eqn in - (lbeq,u,extract_eq_args gl eq_args) +let find_eq_data_decompose env sigma eqn = + let (lbeq,u,eq_args) = find_eq_data sigma eqn in + (lbeq,u,extract_eq_args env sigma eq_args) -let find_this_eq_data_decompose gl eqn = +let find_this_eq_data_decompose env sigma eqn = let (lbeq,u,eq_args) = try (*first_match (match_eq eqn) inversible_equalities*) - find_eq_data (project gl) eqn + find_eq_data sigma eqn with PatternMatchingFailure -> user_err (str "No primitive equality found.") in let eq_args = - try extract_eq_args gl eq_args + try extract_eq_args env sigma eq_args with PatternMatchingFailure -> user_err Pp.(str "Don't know what to do with JMeq on arguments not of same type.") in (lbeq,u,eq_args) @@ -480,9 +479,9 @@ let find_this_eq_data_decompose gl eqn = let match_sigma env sigma ex = match EConstr.kind sigma ex with - | App (f, [| a; p; car; cdr |]) when Termops.is_global sigma (lib_ref "core.sig.intro") f -> + | App (f, [| a; p; car; cdr |]) when isRefX sigma (lib_ref "core.sig.intro") f -> build_sigma (), (snd (destConstruct sigma f), a, p, car, cdr) - | App (f, [| a; p; car; cdr |]) when Termops.is_global sigma (lib_ref "core.sigT.intro") f -> + | App (f, [| a; p; car; cdr |]) when isRefX sigma (lib_ref "core.sigT.intro") f -> build_sigma_type (), (snd (destConstruct sigma f), a, p, car, cdr) | _ -> raise PatternMatchingFailure diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli index 803305a1ca..0000f81d3f 100644 --- a/tactics/hipattern.mli +++ b/tactics/hipattern.mli @@ -122,11 +122,11 @@ val match_with_equation: (** Match terms [eq A t u], [identity A t u] or [JMeq A t A u] Returns associated lemmas and [A,t,u] or fails PatternMatchingFailure *) -val find_eq_data_decompose : Proofview.Goal.t -> constr -> +val find_eq_data_decompose : Environ.env -> evar_map -> constr -> coq_eq_data * EInstance.t * (types * constr * constr) (** Idem but fails with an error message instead of PatternMatchingFailure *) -val find_this_eq_data_decompose : Proofview.Goal.t -> constr -> +val find_this_eq_data_decompose : Environ.env -> evar_map -> constr -> coq_eq_data * EInstance.t * (types * constr * constr) (** A variant that returns more informative structure on the equality found *) diff --git a/tactics/inv.ml b/tactics/inv.ml index be0421d42d..4239fc8bc0 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -352,7 +352,7 @@ let dest_nf_eq env sigma t = match EConstr.kind sigma t with | App (r, [| t; x; y |]) -> let open Reductionops in let eq = Coqlib.lib_ref "core.eq.type" in - if EConstr.is_global sigma eq r then + if isRefX sigma eq r then (t, whd_all env sigma x, whd_all env sigma y) else user_err Pp.(str "Not an equality.") | _ -> @@ -464,7 +464,7 @@ let raw_inversion inv_kind id status names = let concl = Proofview.Goal.concl gl in let c = mkVar id in let (ind, t) = - try pf_apply Tacred.reduce_to_atomic_ind gl (pf_unsafe_type_of gl c) + try pf_apply Tacred.reduce_to_atomic_ind gl (pf_get_type_of gl c) with UserError _ -> let msg = str "The type of " ++ Id.print id ++ str " is not inductive." in CErrors.user_err msg diff --git a/tactics/leminv.ml b/tactics/leminv.ml index cf58c9306c..def4af1ae8 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -259,7 +259,7 @@ let add_inversion_lemma_exn ~poly na com comsort bool tac = let lemInv id c = Proofview.Goal.enter begin fun gls -> try - let clause = mk_clenv_from_env (pf_env gls) (project gls) None (c, pf_unsafe_type_of gls c) in + let clause = mk_clenv_from_env (pf_env gls) (project gls) None (c, pf_get_type_of gls c) in let clause = clenv_constrain_last_binding (EConstr.mkVar id) clause in Clenvtac.res_pf clause ~flags:(Unification.elim_flags ()) ~with_evars:false with diff --git a/tactics/pfedit.ml b/tactics/pfedit.ml index 3c9803432a..72204e1d24 100644 --- a/tactics/pfedit.ml +++ b/tactics/pfedit.ml @@ -17,7 +17,6 @@ open Evd let use_unification_heuristics_ref = ref true let () = Goptions.(declare_bool_option { optdepr = false; - optname = "Solve unification constraints at every \".\""; optkey = ["Solve";"Unification";"Constraints"]; optread = (fun () -> !use_unification_heuristics_ref); optwrite = (fun a -> use_unification_heuristics_ref:=a); @@ -27,7 +26,7 @@ let use_unification_heuristics () = !use_unification_heuristics_ref exception NoSuchGoal let () = CErrors.register_handler begin function - | NoSuchGoal -> CErrors.user_err Pp.(str "No such goal.") + | NoSuchGoal -> Pp.(str "No such goal.") | _ -> raise CErrors.Unhandled end diff --git a/tactics/proof_global.ml b/tactics/proof_global.ml index b1fd34e43c..4c470519d6 100644 --- a/tactics/proof_global.ml +++ b/tactics/proof_global.ml @@ -143,7 +143,6 @@ let private_poly_univs = let b = ref true in let _ = Goptions.(declare_bool_option { optdepr = false; - optname = "use private polymorphic universes for Qed constants"; optkey = ["Private";"Polymorphic";"Universes"]; optread = (fun () -> !b); optwrite = ((:=) b); diff --git a/tactics/redexpr.ml b/tactics/redexpr.ml index fc7b126ee5..a30c877435 100644 --- a/tactics/redexpr.ml +++ b/tactics/redexpr.ml @@ -56,8 +56,6 @@ let strong_cbn flags = let simplIsCbn = ref (false) let () = Goptions.(declare_bool_option { optdepr = false; - optname = - "Plug the simpl tactic to the new cbn mechanism"; optkey = ["SimplIsCbn"]; optread = (fun () -> !simplIsCbn); optwrite = (fun a -> simplIsCbn:=a); diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index ed7ab9164a..58d2097dea 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -587,7 +587,7 @@ module New = struct let ifOnHyp pred tac1 tac2 id = Proofview.Goal.enter begin fun gl -> let typ = Tacmach.New.pf_get_hyp_typ id gl in - if pred (id,typ) then + if pf_apply pred gl (id,typ) then tac1 id else tac2 id @@ -633,7 +633,7 @@ module New = struct (Proofview.Goal.enter begin fun gl -> let indclause = mk_clenv_from gl (c, t) in (* applying elimination_scheme just a little modified *) - let elimclause = mk_clenv_from gl (elim,Tacmach.New.pf_unsafe_type_of gl elim) in + let elimclause = mk_clenv_from gl (elim,Tacmach.New.pf_get_type_of gl elim) in let indmv = match EConstr.kind elimclause.evd (last_arg elimclause.evd elimclause.templval.Evd.rebus) with | Meta mv -> mv @@ -741,7 +741,7 @@ module New = struct let elimination_then tac c = Proofview.Goal.enter begin fun gl -> - let (ind,t) = pf_reduce_to_quantified_ind gl (pf_unsafe_type_of gl c) in + let (ind,t) = pf_reduce_to_quantified_ind gl (pf_get_type_of gl c) in let isrec,mkelim = match (Global.lookup_mind (fst (fst ind))).mind_record with | NotRecord -> true,gl_make_elim diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 31d26834d6..4b93b81d1c 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -222,7 +222,7 @@ module New : sig val nLastDecls : Proofview.Goal.t -> int -> named_context - val ifOnHyp : (Id.t * types -> bool) -> + val ifOnHyp : (Environ.env -> evar_map -> Id.t * types -> bool) -> (Id.t -> unit Proofview.tactic) -> (Id.t -> unit Proofview.tactic) -> Id.t -> unit Proofview.tactic diff --git a/tactics/tactics.ml b/tactics/tactics.ml index f6f7c71dfd..8371da76b2 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -47,6 +47,9 @@ open Context.Named.Declaration module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration +let tclEVARS = Proofview.Unsafe.tclEVARS +let tclEVARSTHEN sigma t = Proofview.tclTHEN (tclEVARS sigma) t + let inj_with_occurrences e = (AllOccurrences,e) let typ_of env sigma c = @@ -64,7 +67,6 @@ let use_clear_hyp_by_default () = !clear_hyp_by_default let () = declare_bool_option { optdepr = false; - optname = "default clearing of hypotheses after use"; optkey = ["Default";"Clearing";"Used";"Hypotheses"]; optread = (fun () -> !clear_hyp_by_default) ; optwrite = (fun b -> clear_hyp_by_default := b) } @@ -80,7 +82,6 @@ let accept_universal_lemma_under_conjunctions () = let () = declare_bool_option { optdepr = false; - optname = "trivial unification in tactics applying under conjunctions"; optkey = ["Universal";"Lemma";"Under";"Conjunction"]; optread = (fun () -> !universal_lemma_under_conjunctions) ; optwrite = (fun b -> universal_lemma_under_conjunctions := b) } @@ -99,7 +100,6 @@ let use_bracketing_last_or_and_intro_pattern () = let () = declare_bool_option { optdepr = true; - optname = "bracketing last or-and introduction pattern"; optkey = ["Bracketing";"Last";"Introduction";"Pattern"]; optread = (fun () -> !bracketing_last_or_and_intro_pattern); optwrite = (fun b -> bracketing_last_or_and_intro_pattern := b) } @@ -151,11 +151,12 @@ let convert_concl ~check ty k = Refine.refine ~typecheck:false begin fun sigma -> let sigma = if check then begin - ignore (Typing.unsafe_type_of env sigma ty); + let sigma, _ = Typing.type_of env sigma ty in match Reductionops.infer_conv env sigma ty conclty with | None -> error "Not convertible." | Some sigma -> sigma - end else sigma in + end else sigma + in let (sigma, x) = Evarutil.new_evar env sigma ~principal:true ty in let ans = if k == DEFAULTcast then x else mkCast(x,k,conclty) in (sigma, ans) @@ -849,12 +850,13 @@ let change_on_subterm ~check cv_pb deep t where env sigma c = change_and_check Reduction.CONV mayneedglobalcheck true (t subst) else fun env sigma _c -> t subst env sigma) env sigma c in - if !mayneedglobalcheck then + let sigma = if !mayneedglobalcheck then begin - try ignore (Typing.unsafe_type_of env sigma c) + try fst (Typing.type_of env sigma c) with e when catchable_exception e -> error "Replacement would lead to an ill-typed term." - end; + end else sigma + in (sigma, c) let change_in_concl ~check occl t = @@ -1308,30 +1310,23 @@ let cut c = let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in - let relevance = - try - (* Backward compat: ensure that [c] is well-typed. Plus we - need to know the relevance *) - let typ = Typing.unsafe_type_of env sigma c in - let typ = whd_all env sigma typ in - match EConstr.kind sigma typ with - | Sort s -> Some (Sorts.relevance_of_sort (ESorts.kind sigma s)) - | _ -> None - with e when Pretype_errors.precatchable_exception e -> None - in - match relevance with - | Some r -> + (* Backward compat: ensure that [c] is well-typed. Plus we need to + know the relevance *) + match Typing.sort_of env sigma c with + | exception e when Pretype_errors.precatchable_exception e -> + Tacticals.New.tclZEROMSG (str "Not a proposition or a type.") + | sigma, s -> + let r = Sorts.relevance_of_sort s in let id = next_name_away_with_default "H" Anonymous (Tacmach.New.pf_ids_set_of_hyps gl) in (* Backward compat: normalize [c]. *) let c = if normalize_cut then local_strong whd_betaiota sigma c else c in - Refine.refine ~typecheck:false begin fun h -> - let (h, f) = Evarutil.new_evar ~principal:true env h (mkArrow c r (Vars.lift 1 concl)) in - let (h, x) = Evarutil.new_evar env h c in - let f = mkLetIn (make_annot (Name id) r, x, c, mkApp (Vars.lift 1 f, [|mkRel 1|])) in - (h, f) - end - | None -> - Tacticals.New.tclZEROMSG (str "Not a proposition or a type.") + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (Refine.refine ~typecheck:false begin fun h -> + let (h, f) = Evarutil.new_evar ~principal:true env h (mkArrow c r (Vars.lift 1 concl)) in + let (h, x) = Evarutil.new_evar env h c in + let f = mkLetIn (make_annot (Name id) r, x, c, mkApp (Vars.lift 1 f, [|mkRel 1|])) in + (h, f) + end) end let error_uninstantiated_metas t clenv = @@ -1533,16 +1528,19 @@ exception IsNonrec let is_nonrec mind = (Global.lookup_mind (fst mind)).mind_finite == Declarations.BiFinite -let find_ind_eliminator ind s gl = - let env = Proofview.Goal.env gl in +let find_ind_eliminator env sigma ind s = let gr = lookup_eliminator env ind s in - Tacmach.New.pf_apply Evd.fresh_global gl gr + Evd.fresh_global env sigma gr let find_eliminator c gl = - let ((ind,u),t) = Tacmach.New.pf_reduce_to_quantified_ind gl (Tacmach.New.pf_unsafe_type_of gl c) in + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let concl = Proofview.Goal.concl gl in + let sigma, t = Typing.type_of env sigma c in + let ((ind,u),t) = reduce_to_quantified_ind env sigma t in if is_nonrec ind then raise IsNonrec; - let evd, c = find_ind_eliminator ind (Tacticals.New.elimination_sort_of_goal gl) gl in - evd, { elimindex = None; elimbody = (c,NoBindings) } + let sigma, c = find_ind_eliminator env sigma ind (Retyping.get_sort_family_of env sigma concl) in + sigma, { elimindex = None; elimbody = (c,NoBindings) } let default_elim with_evars clear_flag (c,_ as cx) = Proofview.tclORELSE @@ -1928,18 +1926,20 @@ let apply_in_delayed_once ?(respect_opaque = false) with_delta let cut_and_apply c = Proofview.Goal.enter begin fun gl -> - let sigma = Tacmach.New.project gl in - match EConstr.kind sigma (Tacmach.New.pf_hnf_constr gl (Tacmach.New.pf_unsafe_type_of gl c)) with - | Prod (_,c1,c2) when Vars.noccurn sigma 1 c2 -> - let concl = Proofview.Goal.concl gl in - let env = Tacmach.New.pf_env gl in - Refine.refine ~typecheck:false begin fun sigma -> - let typ = mkProd (make_annot Anonymous Sorts.Relevant, c2, concl) in - let (sigma, f) = Evarutil.new_evar env sigma typ in - let (sigma, x) = Evarutil.new_evar env sigma c1 in - (sigma, mkApp (f, [|mkApp (c, [|x|])|])) - end - | _ -> error "lapply needs a non-dependent product." + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let concl = Proofview.Goal.concl gl in + let sigma, t = Typing.type_of env sigma c in + match EConstr.kind sigma (hnf_constr env sigma t) with + | Prod (_,c1,c2) when Vars.noccurn sigma 1 c2 -> + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (Refine.refine ~typecheck:false begin fun sigma -> + let typ = mkProd (make_annot Anonymous Sorts.Relevant, c2, concl) in + let (sigma, f) = Evarutil.new_evar env sigma typ in + let (sigma, x) = Evarutil.new_evar env sigma c1 in + (sigma, mkApp (f, [|mkApp (c, [|x|])|])) + end) + | _ -> error "lapply needs a non-dependent product." end (********************************************************************) @@ -2285,8 +2285,8 @@ let intro_decomp_eq_function = ref (fun _ -> failwith "Not implemented") let declare_intro_decomp_eq f = intro_decomp_eq_function := f -let my_find_eq_data_decompose gl t = - try Some (find_eq_data_decompose gl t) +let my_find_eq_data_decompose env sigma t = + try Some (find_eq_data_decompose env sigma t) with e when is_anomaly e (* Hack in case equality is not yet defined... one day, maybe, known equalities will be dynamically registered *) @@ -2296,13 +2296,15 @@ let my_find_eq_data_decompose gl t = let intro_decomp_eq ?loc l thin tac id = Proofview.Goal.enter begin fun gl -> let c = mkVar id in - let t = Tacmach.New.pf_unsafe_type_of gl c in - let _,t = Tacmach.New.pf_reduce_to_quantified_ind gl t in - match my_find_eq_data_decompose gl t with + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let sigma, t = Typing.type_of env sigma c in + let _,t = reduce_to_quantified_ind env sigma t in + match my_find_eq_data_decompose env sigma t with | Some (eq,u,eq_args) -> !intro_decomp_eq_function - (fun n -> tac ((CAst.make id)::thin) (Some (true,n)) l) - (eq,t,eq_args) (c, t) + (fun n -> tac ((CAst.make id)::thin) (Some (true,n)) l) + (eq,t,eq_args) (c, t) | None -> Tacticals.New.tclZEROMSG (str "Not a primitive equality here.") end @@ -2310,16 +2312,19 @@ let intro_decomp_eq ?loc l thin tac id = let intro_or_and_pattern ?loc with_evars bracketed ll thin tac id = Proofview.Goal.enter begin fun gl -> let c = mkVar id in - let t = Tacmach.New.pf_unsafe_type_of gl c in - let (ind,t) = Tacmach.New.pf_reduce_to_quantified_ind gl t in + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let sigma, t = Typing.type_of env sigma c in + let (ind,t) = reduce_to_quantified_ind env sigma t in let branchsigns = compute_constructor_signatures ~rec_flag:false ind in let nv_with_let = Array.map List.length branchsigns in let ll = fix_empty_or_and_pattern (Array.length branchsigns) ll in let ll = get_and_check_or_and_pattern ?loc ll branchsigns in - Tacticals.New.tclTHENLASTn - (Tacticals.New.tclTHEN (simplest_ecase c) (clear [id])) - (Array.map2 (fun n l -> tac thin (Some (bracketed,n)) l) - nv_with_let ll) + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (Tacticals.New.tclTHENLASTn + (Tacticals.New.tclTHEN (simplest_ecase c) (clear [id])) + (Array.map2 (fun n l -> tac thin (Some (bracketed,n)) l) + nv_with_let ll)) end let rewrite_hyp_then assert_style with_evars thin l2r id tac = @@ -2333,9 +2338,8 @@ let rewrite_hyp_then assert_style with_evars thin l2r id tac = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in - let type_of = Tacmach.New.pf_unsafe_type_of gl in - let whd_all = Tacmach.New.pf_apply whd_all gl in - let t = whd_all (type_of (mkVar id)) in + let sigma, t = Typing.type_of env sigma (mkVar id) in + let t = whd_all env sigma t in let eqtac, thin = match match_with_equality_type env sigma t with | Some (hdcncl,[_;lhs;rhs]) -> if l2r && isVar sigma lhs && not (occur_var env sigma (destVar sigma lhs) rhs) then @@ -2361,7 +2365,7 @@ let rewrite_hyp_then assert_style with_evars thin l2r id tac = Tacticals.New.tclTHEN (rew_on l2r onConcl) (clear [id]), thin in (* Skip the side conditions of the rewriting step *) - Tacticals.New.tclTHENFIRST eqtac (tac thin) + tclEVARSTHEN sigma (Tacticals.New.tclTHENFIRST eqtac (tac thin)) end let prepare_naming ?loc = function @@ -3392,8 +3396,9 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = let id = match EConstr.kind sigma c with | Var id -> id | _ -> - let type_of = Tacmach.New.pf_unsafe_type_of gl in - id_of_name_using_hdchar env sigma (type_of c) Anonymous in + let type_of = Tacmach.New.pf_get_type_of gl in + id_of_name_using_hdchar env sigma (type_of c) Anonymous + in let x = fresh_id_in_env avoid id env in Tacticals.New.tclTHEN (letin_tac None (Name x) c None allHypsAndConcl) @@ -3794,15 +3799,15 @@ let is_defined_variable env id = env |> lookup_named id |> is_local_def let abstract_args gl generalize_vars dep id defined f args = - let open Tacmach.New in let open Context.Rel.Declaration in let sigma = ref (Tacmach.New.project gl) in let env = Tacmach.New.pf_env gl in let concl = Tacmach.New.pf_concl gl in + let hyps = Proofview.Goal.hyps gl in let dep = dep || local_occur_var !sigma id concl in let avoid = ref Id.Set.empty in let get_id name = - let id = new_fresh_id !avoid (match name with Name n -> n | Anonymous -> Id.of_string "gen_x") gl in + let id = fresh_id_in_env !avoid (match name with Name n -> n | Anonymous -> Id.of_string "gen_x") env in avoid := Id.Set.add id !avoid; id in (* Build application generalized w.r.t. the argument plus the necessary eqs. @@ -3811,14 +3816,14 @@ let abstract_args gl generalize_vars dep id defined f args = eqs are not lifted w.r.t. each other yet. (* will be needed when going to dependent indexes *) *) - let aux (prod, ctx, ctxenv, c, args, eqs, refls, nongenvars, vars, env) arg = + let aux (prod, ctx, ctxenv, c, args, eqs, refls, nongenvars, vars) arg = let name, ty_relevance, ty, arity = let rel, c = Reductionops.splay_prod_n env !sigma 1 prod in let decl = List.hd rel in RelDecl.get_name decl, RelDecl.get_relevance decl, RelDecl.get_type decl, c in - let argty = Tacmach.New.pf_unsafe_type_of gl arg in - let sigma', ty = Evarsolve.refresh_universes (Some true) env !sigma ty in + let sigma', argty = Typing.type_of env !sigma arg in + let sigma', ty = Evarsolve.refresh_universes (Some true) env sigma' ty in let () = sigma := sigma' in let lenctx = List.length ctx in let liftargty = lift lenctx argty in @@ -3826,7 +3831,7 @@ let abstract_args gl generalize_vars dep id defined f args = match EConstr.kind !sigma arg with | Var id when not (is_defined_variable env id) && leq && not (Id.Set.mem id nongenvars) -> (subst1 arg arity, ctx, ctxenv, mkApp (c, [|arg|]), args, eqs, refls, - Id.Set.add id nongenvars, Id.Set.remove id vars, env) + Id.Set.add id nongenvars, Id.Set.remove id vars) | _ -> let name = get_id name in let decl = LocalAssum (make_annot (Name name) ty_relevance, ty) in @@ -3848,7 +3853,7 @@ let abstract_args gl generalize_vars dep id defined f args = let refls = refl :: refls in let argvars = ids_of_constr !sigma vars arg in (arity, ctx, push_rel decl ctxenv, c', args, eqs, refls, - nongenvars, Id.Set.union argvars vars, env) + nongenvars, Id.Set.union argvars vars) in let f', args' = decompose_indapp !sigma f args in let dogen, f', args' = @@ -3862,15 +3867,16 @@ let abstract_args gl generalize_vars dep id defined f args = true, mkApp (f', before), after in if dogen then - let tyf' = Tacmach.New.pf_unsafe_type_of gl f' in - let arity, ctx, ctxenv, c', args, eqs, refls, nogen, vars, env = - Array.fold_left aux (tyf',[],env,f',[],[],[],Id.Set.empty,Id.Set.empty,env) args' + let sigma', tyf' = Typing.type_of env !sigma f' in + sigma := sigma'; + let arity, ctx, ctxenv, c', args, eqs, refls, nogen, vars = + Array.fold_left aux (tyf',[],env,f',[],[],[],Id.Set.empty,Id.Set.empty) args' in let args, refls = List.rev args, List.rev refls in let vars = if generalize_vars then let nogen = Id.Set.add id nogen in - hyps_of_vars (pf_env gl) (project gl) (Proofview.Goal.hyps gl) nogen vars + hyps_of_vars env !sigma hyps nogen vars else [] in let body, c' = @@ -3878,7 +3884,7 @@ let abstract_args gl generalize_vars dep id defined f args = else None, c' in let typ = Tacmach.New.pf_get_hyp_typ id gl in - let tac = make_abstract_generalize (pf_env gl) id typ concl dep ctx body c' eqs args refls in + let tac = make_abstract_generalize env id typ concl dep ctx body c' eqs args refls in let tac = Proofview.Unsafe.tclEVARS !sigma <*> tac in Some (tac, dep, succ (List.length ctx), vars) else None @@ -3946,7 +3952,7 @@ let specialize_eqs id = match EConstr.kind !evars ty with | Prod (na, t, b) -> (match EConstr.kind !evars t with - | App (eq, [| eqty; x; y |]) when EConstr.is_global !evars Coqlib.(lib_ref "core.eq.type") eq -> + | App (eq, [| eqty; x; y |]) when isRefX !evars Coqlib.(lib_ref "core.eq.type") eq -> let c = if noccur_between !evars 1 (List.length ctx) x then y else x in let pt = mkApp (eq, [| eqty; c; c |]) in let ind = destInd !evars eq in @@ -3954,7 +3960,7 @@ let specialize_eqs id = if unif (push_rel_context ctx env) evars pt t then aux true ctx (mkApp (acc, [| p |])) (subst1 p b) else acc, in_eqs, ctx, ty - | App (heq, [| eqty; x; eqty'; y |]) when EConstr.is_global !evars (Lazy.force coq_heq_ref) heq -> + | App (heq, [| eqty; x; eqty'; y |]) when isRefX !evars (Lazy.force coq_heq_ref) heq -> let eqt, c = if noccur_between !evars 1 (List.length ctx) x then eqty', y else eqty, x in let pt = mkApp (heq, [| eqt; c; eqt; c |]) in let ind = destInd !evars heq in @@ -4125,8 +4131,8 @@ let compute_elim_sig sigma ?elimc elimt = | Some (LocalDef _) -> error_ind_scheme "" | Some (LocalAssum (_,ind)) -> let indhd,indargs = decompose_app sigma ind in - try {!res with indref = Some (fst (Termops.global_of_constr sigma indhd)) } - with e when CErrors.noncritical e -> + try {!res with indref = Some (fst (destRef sigma indhd)) } + with DestKO -> error "Cannot find the inductive type of the inductive scheme." let compute_scheme_signature evd scheme names_info ind_type_guess = @@ -4222,15 +4228,15 @@ let guess_elim isrec dep s hyp0 gl = let ind = EConstr.of_constr ind in (sigma, ind) in - let elimt = Typing.unsafe_type_of env sigma elimc in - sigma, ((elimc, NoBindings), elimt), mkIndU (mind, u) + let sigma, elimt = Typing.type_of env sigma elimc in + sigma, ((elimc, NoBindings), elimt), mkIndU (mind, u) let given_elim hyp0 (elimc,lbind as e) gl = let sigma = Tacmach.New.project gl in let tmptyp0 = Tacmach.New.pf_get_hyp_typ hyp0 gl in let ind_type_guess,_ = decompose_app sigma (snd (decompose_prod sigma tmptyp0)) in - let elimt = Tacmach.New.pf_unsafe_type_of gl elimc in - Tacmach.New.project gl, (e, elimt), ind_type_guess + let sigma, elimt = Tacmach.New.pf_type_of gl elimc in + sigma, (e, elimt), ind_type_guess type scheme_signature = (Id.Set.t * (elim_arg_kind * bool * bool * Id.t) list) array @@ -4240,33 +4246,32 @@ type eliminator_source = | ElimOver of bool * Id.t let find_induction_type isrec elim hyp0 gl = - let sigma = Tacmach.New.project gl in - let scheme,elim = + let sigma, scheme,elim = match elim with | None -> let sort = Tacticals.New.elimination_sort_of_goal gl in - let _, (elimc,elimt),_ = guess_elim isrec false sort hyp0 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 *) - scheme, ElimOver (isrec,hyp0) + sigma, scheme, ElimOver (isrec,hyp0) | Some e -> - let evd, (elimc,elimt),ind_guess = given_elim hyp0 e gl in + 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 evd scheme hyp0 ind_guess in + let indsign = compute_scheme_signature sigma scheme hyp0 ind_guess in let elim = ({ elimindex = Some(-1); elimbody = elimc },elimt) in - scheme, ElimUsing (elim,indsign) + sigma, scheme, ElimUsing (elim,indsign) in match scheme.indref with | None -> error_ind_scheme "" - | Some ref -> ref, scheme.nparams, elim + | Some ref -> sigma, (ref, scheme.nparams, elim) let get_elim_signature elim hyp0 gl = compute_elim_signature (given_elim hyp0 elim gl) hyp0 let is_functional_induction elimc gl = let sigma = Tacmach.New.project gl in - let scheme = compute_elim_sig sigma ~elimc (Tacmach.New.pf_unsafe_type_of gl (fst elimc)) in + let scheme = compute_elim_sig sigma ~elimc (Tacmach.New.pf_get_type_of gl (fst elimc)) in (* The test is not safe: with non-functional induction on non-standard induction scheme, this may fail *) Option.is_empty scheme.indarg @@ -4380,10 +4385,11 @@ let apply_induction_in_context with_evars hyp0 inhyps elim indvars names induct_ let induction_with_atomization_of_ind_arg isrec with_evars elim names hyp0 inhyps = Proofview.Goal.enter begin fun gl -> - let elim_info = find_induction_type isrec elim hyp0 gl in - atomize_param_of_ind_then elim_info hyp0 (fun indvars -> - apply_induction_in_context with_evars (Some hyp0) inhyps (pi3 elim_info) indvars names - (fun elim -> induction_tac with_evars [] [hyp0] elim)) + let sigma, elim_info = find_induction_type isrec elim hyp0 gl in + tclEVARSTHEN sigma + (atomize_param_of_ind_then elim_info hyp0 (fun indvars -> + apply_induction_in_context with_evars (Some hyp0) inhyps (pi3 elim_info) indvars names + (fun elim -> induction_tac with_evars [] [hyp0] elim))) end let msg_not_right_number_induction_arguments scheme = @@ -4658,18 +4664,16 @@ let induction_gen_l isrec with_evars elim names lc = | _ -> Proofview.Goal.enter begin fun gl -> - let type_of = Tacmach.New.pf_unsafe_type_of gl in - let sigma = Tacmach.New.project gl in - Proofview.tclENV >>= fun env -> - let x = - id_of_name_using_hdchar env sigma (type_of c) Anonymous in - + let sigma, t = pf_apply Typing.type_of gl c in + let x = id_of_name_using_hdchar (Proofview.Goal.env gl) sigma t Anonymous in let id = new_fresh_id Id.Set.empty x gl in let newl' = List.map (fun r -> replace_term sigma c (mkVar id) r) l' in let () = newlc:=id::!newlc in - Tacticals.New.tclTHEN - (letin_tac None (Name id) c None allHypsAndConcl) - (atomize_list newl') + Tacticals.New.tclTHENLIST [ + tclEVARS sigma; + letin_tac None (Name id) c None allHypsAndConcl; + atomize_list newl'; + ] end in Tacticals.New.tclTHENLIST [ @@ -4765,7 +4769,10 @@ let destruct ev clr c l e = let elim_scheme_type elim t = Proofview.Goal.enter begin fun gl -> - let clause = mk_clenv_type_of gl elim in + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let sigma, elimt = Typing.type_of env sigma elim in + let clause = mk_clenv_from_env env sigma None (elim,elimt) in match EConstr.kind clause.evd (last_arg clause.evd clause.templval.rebus) with | Meta mv -> let clause' = @@ -4779,7 +4786,9 @@ let elim_scheme_type elim t = let elim_type t = Proofview.Goal.enter begin fun gl -> let (ind,t) = Tacmach.New.pf_apply reduce_to_atomic_ind gl t in - let evd, elimc = find_ind_eliminator (fst ind) (Tacticals.New.elimination_sort_of_goal gl) gl in + let evd, elimc = Tacmach.New.pf_apply find_ind_eliminator gl (fst ind) + (Tacticals.New.elimination_sort_of_goal gl) + in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evd) (elim_scheme_type elimc t) end @@ -4857,7 +4866,8 @@ let prove_symmetry hdcncl eq_kind = Tacticals.New.onLastHyp simplest_case; one_constructor 1 NoBindings ]) -let match_with_equation sigma c = +let match_with_equation c = + Proofview.tclEVARMAP >>= fun sigma -> Proofview.tclENV >>= fun env -> try let res = match_with_equation env sigma c in @@ -4870,9 +4880,8 @@ let symmetry_red allowred = (* PL: usual symmetry don't perform any reduction when searching for an equality, but we may need to do some when called back from inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) - let sigma = Tacmach.New.project gl in let concl = maybe_betadeltaiota_concl allowred gl in - match_with_equation sigma concl >>= fun with_eqn -> + match_with_equation concl >>= fun with_eqn -> match with_eqn with | Some eq_data,_,_ -> Tacticals.New.tclTHEN @@ -4894,25 +4903,25 @@ let (forward_setoid_symmetry_in, setoid_symmetry_in) = Hook.make () let symmetry_in id = Proofview.Goal.enter begin fun gl -> - let sigma = Tacmach.New.project gl in - let ctype = Tacmach.New.pf_unsafe_type_of gl (mkVar id) in - let sign,t = decompose_prod_assum sigma ctype in - Proofview.tclORELSE - begin - match_with_equation sigma t >>= fun (_,hdcncl,eq) -> - let symccl = - match eq with - | MonomorphicLeibnizEq (c1,c2) -> mkApp (hdcncl, [| c2; c1 |]) - | PolymorphicLeibnizEq (typ,c1,c2) -> mkApp (hdcncl, [| typ; c2; c1 |]) - | HeterogenousEq (t1,c1,t2,c2) -> mkApp (hdcncl, [| t2; c2; t1; c1 |]) in - Tacticals.New.tclTHENS (cut (EConstr.it_mkProd_or_LetIn symccl sign)) - [ intro_replacing id; - Tacticals.New.tclTHENLIST [ intros; symmetry; apply (mkVar id); assumption ] ] - end - begin function (e, info) -> match e with - | NoEquationFound -> Hook.get forward_setoid_symmetry_in id - | e -> Proofview.tclZERO ~info e - end + let sigma, ctype = Tacmach.New.pf_type_of gl (mkVar id) in + let sign,t = decompose_prod_assum sigma ctype in + tclEVARSTHEN sigma + (Proofview.tclORELSE + begin + match_with_equation t >>= fun (_,hdcncl,eq) -> + let symccl = + match eq with + | MonomorphicLeibnizEq (c1,c2) -> mkApp (hdcncl, [| c2; c1 |]) + | PolymorphicLeibnizEq (typ,c1,c2) -> mkApp (hdcncl, [| typ; c2; c1 |]) + | HeterogenousEq (t1,c1,t2,c2) -> mkApp (hdcncl, [| t2; c2; t1; c1 |]) in + Tacticals.New.tclTHENS (cut (EConstr.it_mkProd_or_LetIn symccl sign)) + [ intro_replacing id; + Tacticals.New.tclTHENLIST [ intros; symmetry; apply (mkVar id); assumption ] ] + end + begin function (e, info) -> match e with + | NoEquationFound -> Hook.get forward_setoid_symmetry_in id + | e -> Proofview.tclZERO ~info e + end) end let intros_symmetry = @@ -4939,25 +4948,26 @@ let (forward_setoid_transitivity, setoid_transitivity) = Hook.make () (* This is probably not very useful any longer *) let prove_transitivity hdcncl eq_kind t = Proofview.Goal.enter begin fun gl -> - let (eq1,eq2) = match eq_kind with - | MonomorphicLeibnizEq (c1,c2) -> - mkApp (hdcncl, [| c1; t|]), mkApp (hdcncl, [| t; c2 |]) - | PolymorphicLeibnizEq (typ,c1,c2) -> - mkApp (hdcncl, [| typ; c1; t |]), mkApp (hdcncl, [| typ; t; c2 |]) - | HeterogenousEq (typ1,c1,typ2,c2) -> - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in - let type_of = Typing.unsafe_type_of env sigma in - let typt = type_of t in - (mkApp(hdcncl, [| typ1; c1; typt ;t |]), - mkApp(hdcncl, [| typt; t; typ2; c2 |])) - in - Tacticals.New.tclTHENFIRST (cut eq2) - (Tacticals.New.tclTHENFIRST (cut eq1) - (Tacticals.New.tclTHENLIST - [ Tacticals.New.tclDO 2 intro; - Tacticals.New.onLastHyp simplest_case; - assumption ])) + let sigma = Tacmach.New.project gl in + let sigma, eq1, eq2 = match eq_kind with + | MonomorphicLeibnizEq (c1,c2) -> + sigma, mkApp (hdcncl, [| c1; t|]), mkApp (hdcncl, [| t; c2 |]) + | PolymorphicLeibnizEq (typ,c1,c2) -> + sigma, mkApp (hdcncl, [| typ; c1; t |]), mkApp (hdcncl, [| typ; t; c2 |]) + | HeterogenousEq (typ1,c1,typ2,c2) -> + let env = Proofview.Goal.env gl in + let sigma, typt = Typing.type_of env sigma t in + sigma, + mkApp(hdcncl, [| typ1; c1; typt ;t |]), + mkApp(hdcncl, [| typt; t; typ2; c2 |]) + in + tclEVARSTHEN sigma + (Tacticals.New.tclTHENFIRST (cut eq2) + (Tacticals.New.tclTHENFIRST (cut eq1) + (Tacticals.New.tclTHENLIST + [ Tacticals.New.tclDO 2 intro; + Tacticals.New.onLastHyp simplest_case; + assumption ]))) end let transitivity_red allowred t = @@ -4965,9 +4975,8 @@ let transitivity_red allowred t = (* PL: usual transitivity don't perform any reduction when searching for an equality, but we may need to do some when called back from inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) - let sigma = Tacmach.New.project gl in let concl = maybe_betadeltaiota_concl allowred gl in - match_with_equation sigma concl >>= fun with_eqn -> + match_with_equation concl >>= fun with_eqn -> match with_eqn with | Some eq_data,_,_ -> Tacticals.New.tclTHEN diff --git a/test-suite/bugs/closed/bug_11515.v b/test-suite/bugs/closed/bug_11515.v new file mode 100644 index 0000000000..fe4ba87447 --- /dev/null +++ b/test-suite/bugs/closed/bug_11515.v @@ -0,0 +1,7 @@ +Require Import Ltac2.Ltac2. + +Lemma foo : + True. +Proof. + Fail rewrite _. +Abort. diff --git a/test-suite/bugs/closed/bug_11553.v b/test-suite/bugs/closed/bug_11553.v new file mode 100644 index 0000000000..a4a4353cd6 --- /dev/null +++ b/test-suite/bugs/closed/bug_11553.v @@ -0,0 +1,34 @@ +Definition var := nat. +Module Import A. +Class Rename (term : Type) := rename : (var -> var) -> term -> term. +End A. + +Inductive tm : Type := + (* | tv : vl_ -> tm *) + with vl_ : Type := + | var_vl : var -> vl_. + +Definition vl := vl_. + +Fixpoint tm_rename (sb : var -> var) (t : tm) : tm := + let b := vl_rename : Rename vl in + match t with + end +with +vl_rename (sb : var -> var) v : vl := + let a := tm_rename : Rename tm in + let b := vl_rename : Rename vl in + match v with + | var_vl x => var_vl (sb x) + end. + +Instance rename_vl : Rename vl := vl_rename. + +Lemma foo ξ x: rename_vl ξ (var_vl x) = var_vl x. +(* Succeeds *) +cbn. Abort. + +Lemma foo ξ x: rename ξ (var_vl x) = var_vl x. +(* Fails *) +cbn. +Abort. diff --git a/test-suite/bugs/closed/bug_5617.v b/test-suite/bugs/closed/bug_5617.v new file mode 100644 index 0000000000..c18e79295c --- /dev/null +++ b/test-suite/bugs/closed/bug_5617.v @@ -0,0 +1,8 @@ +Set Primitive Projections. +Record T X := { F : X }. + +Fixpoint f (n : nat) : nat := +match n with +| 0 => 0 +| S m => F _ {| F := f |} m +end. diff --git a/test-suite/failure/Template.v b/test-suite/failure/Template.v deleted file mode 100644 index 75b2a56169..0000000000 --- a/test-suite/failure/Template.v +++ /dev/null @@ -1,32 +0,0 @@ -(* -Module TestUnsetTemplateCheck. - Unset Template Check. - - Section Foo. - - Context (A : Type). - - Definition cstr := nat : ltac:(let ty := type of A in exact ty). - - Inductive myind := - | cons : A -> myind. - End Foo. - - (* Can only succeed if no template check is performed *) - Check myind True : Prop. - - Print Assumptions myind. - (* - Axioms: - myind is template polymorphic on all its universe parameters. - *) - About myind. -(* -myind : Type@{Top.60} -> Type@{Top.60} - -myind is assumed template universe polymorphic on Top.60 -Argument scope is [type_scope] -Expands to: Inductive Top.TestUnsetTemplateCheck.myind -*) -End TestUnsetTemplateCheck. -*) diff --git a/test-suite/ltac2/array_lib.v b/test-suite/ltac2/array_lib.v new file mode 100644 index 0000000000..31227eaddb --- /dev/null +++ b/test-suite/ltac2/array_lib.v @@ -0,0 +1,181 @@ +Require Import Ltac2.Ltac2. +Import Ltac2.Message. +Import Ltac2.Array. +Require Ltac2.List. +Require Ltac2.Int. + +(* Array/List comparison functions which throw an exception on unequal *) + +Ltac2 Type exn ::= [ Regression_Test_Failure ]. + +Ltac2 check_eq_int a l := + List.iter2 + (fun a b => match Int.equal a b with true => () | false => Control.throw Regression_Test_Failure end) + (to_list a) l. + +Ltac2 check_eq_bool a l := + List.iter2 + (fun a b => match Bool.eq a b with true => () | false => Control.throw Regression_Test_Failure end) + (to_list a) l. + +Ltac2 check_eq_int_matrix m ll := + List.iter2 (fun a b => check_eq_int a b) (to_list m) ll. + +Ltac2 check_eq_bool_matrix m ll := + List.iter2 (fun a b => check_eq_bool a b) (to_list m) ll. + +(* The below printing functions are mostly for debugging below test cases *) + +Ltac2 print2 m1 m2 := print (Message.concat m1 m2). +Ltac2 print3 m1 m2 m3 := print2 m1 (Message.concat m2 m3). + +Ltac2 print_int_array a := + iteri (fun i x => print3 (of_int i) (of_string "=") (of_int x)) a. + +Ltac2 of_bool b := match b with true=>of_string "true" | false=>of_string "false" end. + +Ltac2 print_bool_array a := + iteri (fun i x => print3 (of_int i) (of_string "=") (of_bool x)) a. + +Ltac2 print_int_list a := + List.iteri (fun i x => print3 (of_int i) (of_string "=") (of_int x)) a. + +Goal True. + (* Test failure *) + Fail check_eq_int ((init 3 (fun i => (Int.add i 10)))) [10;11;13]. + + (* test empty with int *) + check_eq_int (empty ()) []. + check_eq_int (append (empty ()) (init 3 (fun i => (Int.add i 10)))) [10;11;12]. + check_eq_int (append (init 3 (fun i => (Int.add i 10))) (empty ())) [10;11;12]. + + (* test empty with bool *) + check_eq_bool (empty ()) []. + check_eq_bool (append (empty ()) (init 3 (fun i => (Int.ge i 2)))) [false;false;true]. + check_eq_bool (append (init 3 (fun i => (Int.ge i 2))) (empty ())) [false;false;true]. + + (* test init with int *) + check_eq_int (init 0 (fun i => (Int.add i 10))) []. + check_eq_int (init 4 (fun i => (Int.add i 10))) [10;11;12;13]. + + (* test init with bool *) + check_eq_bool (init 0 (fun i => (Int.ge i 2))) []. + check_eq_bool (init 4 (fun i => (Int.ge i 2))) [false;false;true;true]. + + (* test make_matrix, set, get *) + let a := make_matrix 4 3 1 in + Array.set (Array.get a 1) 2 0; + check_eq_int_matrix a [[1;1;1];[1;1;0];[1;1;1];[1;1;1]]. + + let a := make_matrix 3 4 false in + Array.set (Array.get a 2) 1 true; + check_eq_bool_matrix a [[false;false;false;false];[false;false;false;false];[false;true;false;false]]. + + (* test copy *) + let a := init 4 (fun i => (Int.add i 10)) in + let b := copy a in + check_eq_int b [10;11;12;13]. + + (* test append *) + let a := init 3 (fun i => (Int.add i 10)) in + let b := init 4 (fun i => (Int.add i 20)) in + check_eq_int (append a b) [10;11;12;20;21;22;23]. + + (* test concat *) + let a := init 3 (fun i => (Int.add i 10)) in + let b := init 4 (fun i => (Int.add i 20)) in + let c := init 5 (fun i => (Int.add i 30)) in + check_eq_int (concat (a::b::c::[])) [10;11;12;20;21;22;23;30;31;32;33;34]. + + (* test sub *) + let a := init 10 (fun i => (Int.add i 10)) in + let b := (sub a 3 0) in + let c := (append b (init 3 (fun i => (Int.add i 10)))) in + check_eq_int b []; + check_eq_int c [10;11;12]. + + let a := init 10 (fun i => (Int.add i 10)) in + let b := (sub a 3 4) in + check_eq_int b [13;14;15;16]. + + (* test fill *) + let a := init 10 (fun i => (Int.add i 10)) in + fill a 3 4 0; + check_eq_int a [10;11;12;0;0;0;0;17;18;19]. + + (* test blit *) + let a := init 10 (fun i => (Int.add i 10)) in + let b := init 10 (fun i => (Int.add i 20)) in + blit a 5 b 3 4; + check_eq_int b [20;21;22;15;16;17;18;27;28;29]. + + (* test iter *) + let a := init 4 (fun i => (Int.add i 3)) in + let b := init 10 (fun i => 10) in + iter (fun x => Array.set b x x) a; + check_eq_int b [10;10;10;3;4;5;6;10;10;10]. + + (* test iter2 *) + let a := init 4 (fun i => (Int.add i 2)) in + let b := init 4 (fun i => (Int.add i 4)) in + let c := init 8 (fun i => 10) in + iter2 (fun x y => Array.set c x y) a b; + check_eq_int c [10;10;4;5;6;7;10;10]. + + (* test map *) + let a := init 4 (fun i => (Int.add i 10)) in + check_eq_bool (map (fun i => (Int.ge i 12)) a) [false;false;true;true]. + + (* test map2 *) + let a := init 4 (fun i => (Int.add 10 i)) in + let b := init 4 (fun i => (Int.sub 13 i)) in + check_eq_bool (map2 (fun x y => (Int.ge x y)) a b) [false;false;true;true]. + + (* test iteri *) + let a := init 4 (fun i => (Int.add i 10)) in + let m := make_matrix 4 2 100 in + iteri (fun i x => Array.set (Array.get m i) 0 i; Array.set (Array.get m i) 1 x) a; + check_eq_int_matrix m [[0;10];[1;11];[2;12];[3;13]]. + + (* test mapi *) + let a := init 4 (fun i => (Int.sub 3 i)) in + check_eq_bool (mapi (fun i x => (Int.ge i x)) a) [false;false;true;true]. + + (* to_list is already tested in check_eq_... *) + + (* test of_list *) + check_eq_int (of_list ([0;1;2;3])) [0;1;2;3]. + + (* test fold_left *) + let a := init 4 (fun i => (Int.add 10 i)) in + check_eq_int (of_list (fold_left (fun a b => b::a) [] a)) [13;12;11;10]. + + (* test fold_right *) + let a := init 4 (fun i => (Int.add 10 i)) in + check_eq_int (of_list (fold_right (fun a b => b::a) [] a)) [10;11;12;13]. + + (* test exist *) + let a := init 4 (fun i => (Int.add 10 i)) in + let l := [ + exist (fun x => Int.equal x 10) a; + exist (fun x => Int.equal x 13) a; + exist (fun x => Int.equal x 14) a] in + check_eq_bool (of_list l) [true;true;false]. + + (* test for_all *) + let a := init 4 (fun i => (Int.add 10 i)) in + let l := [ + for_all (fun x => Int.lt x 14) a; + for_all (fun x => Int.lt x 13) a] in + check_eq_bool (of_list l) [true;false]. + + (* test mem *) + let a := init 4 (fun i => (Int.add 10 i)) in + let l := [ + mem Int.equal 10 a; + mem Int.equal 13 a; + mem Int.equal 14 a] in + check_eq_bool (of_list l) [true;true;false]. + +exact I. +Qed. diff --git a/test-suite/micromega/bug_11436.v b/test-suite/micromega/bug_11436.v new file mode 100644 index 0000000000..fc6ccbb233 --- /dev/null +++ b/test-suite/micromega/bug_11436.v @@ -0,0 +1,19 @@ +Require Import ZArith Lia. +Local Open Scope Z_scope. + +Unset Lia Cache. + +Goal forall a q q0 q1 r r0 r1: Z, + 0 <= a < 2 ^ 64 -> + r1 = 4 * q + r -> + 0 <= r < 4 -> + a = 4 * q0 + r0 -> + 0 <= r0 < 4 -> + a + 4 = 2 ^ 64 * q1 + r1 -> + 0 <= r1 < 2 ^ 64 -> + r = r0. +Proof. + intros. + (* subst. *) + Time lia. +Qed. diff --git a/test-suite/micromega/evars_loops_in_8_10_fixed_8_11.v b/test-suite/micromega/evars_loops_in_8_10_fixed_8_11.v new file mode 100644 index 0000000000..a53c160e45 --- /dev/null +++ b/test-suite/micromega/evars_loops_in_8_10_fixed_8_11.v @@ -0,0 +1,4 @@ +Require Import Lia. +Goal forall n (B: n >= 0), exists Goal1 Goal2 Goal3, + (0 * (Goal1 * Goal2 + Goal1) <> Goal3 * 0 * (Goal1 * S Goal2)). +Proof. eexists _, _, _. Fail lia. Abort. diff --git a/test-suite/micromega/square.v b/test-suite/micromega/square.v index 9efb81a901..36b4243ef8 100644 --- a/test-suite/micromega/square.v +++ b/test-suite/micromega/square.v @@ -11,15 +11,14 @@ Open Scope Z_scope. Lemma Zabs_square : forall x, (Z.abs x)^2 = x^2. Proof. - intros ; case (Zabs_dec x) ; intros ; nia. + intros ; nia. Qed. -Hint Resolve Z.abs_nonneg Zabs_square. Lemma integer_statement : ~exists n, exists p, n^2 = 2*p^2 /\ n <> 0. Proof. intros [n [p [Heq Hnz]]]; pose (n' := Z.abs n); pose (p':=Z.abs p). assert (facts : 0 <= Z.abs n /\ 0 <= Z.abs p /\ Z.abs n^2=n^2 - /\ Z.abs p^2 = p^2) by auto. + /\ Z.abs p^2 = p^2) by auto using Z.abs_nonneg, Zabs_square. assert (H : (0 < n' /\ 0 <= p' /\ n' ^2 = 2* p' ^2)) by (destruct facts as [Hf1 [Hf2 [Hf3 Hf4]]]; unfold n', p' ; nia). generalize p' H; elim n' using (well_founded_ind (Zwf_well_founded 0)); clear. @@ -45,10 +44,7 @@ Proof. intros. destruct x. simpl. - unfold Z.pow_pos. - simpl. - rewrite Pos.mul_1_r. - reflexivity. + lia. Qed. Theorem sqrt2_not_rational : ~exists x:Q, x^2==2#1. diff --git a/test-suite/output/Arguments_renaming.out b/test-suite/output/Arguments_renaming.out index 5093e785de..26ebd8efc3 100644 --- a/test-suite/output/Arguments_renaming.out +++ b/test-suite/output/Arguments_renaming.out @@ -86,8 +86,8 @@ Sequences of implicit arguments must be of different lengths. The command has indeed failed with message: Some argument names are duplicated: F The command has indeed failed with message: -Argument number 2 (anonymous in original definition) cannot be declared -implicit. +Argument number 3 is a trailing implicit, so it can't be declared non +maximal. Please use { } instead of [ ]. The command has indeed failed with message: Extra arguments: y. The command has indeed failed with message: diff --git a/test-suite/output/Arguments_renaming.v b/test-suite/output/Arguments_renaming.v index 9713a9dbbe..6ac09cf771 100644 --- a/test-suite/output/Arguments_renaming.v +++ b/test-suite/output/Arguments_renaming.v @@ -49,7 +49,6 @@ Check @myplus. Fail Arguments eq_refl {F g}, [H] k. Fail Arguments eq_refl {F}, [F] : rename. Fail Arguments eq_refl {F F}, [F] F : rename. -Fail Arguments eq {F} x [z] : rename. +Fail Arguments eq {A} x [z] : rename. Fail Arguments eq {F} x z y. Fail Arguments eq {R} s t. - diff --git a/test-suite/output/Fixpoint.out b/test-suite/output/Fixpoint.out index 6879cbc3c2..60bc9cbf55 100644 --- a/test-suite/output/Fixpoint.out +++ b/test-suite/output/Fixpoint.out @@ -1,8 +1,8 @@ -fix F (A B : Set) (f : A -> B) (l : list A) {struct l} : -list B := match l with - | nil => nil - | a :: l0 => f a :: F A B f l0 - end +fix F (A B : Set) (f : A -> B) (l : list A) {struct l} : list B := + match l with + | nil => nil + | a :: l0 => f a :: F A B f l0 + end : forall A B : Set, (A -> B) -> list A -> list B let fix f (m : nat) : nat := match m with | 0 => 0 diff --git a/test-suite/output/Naming.out b/test-suite/output/Naming.out index c142d28ebe..0a989646cf 100644 --- a/test-suite/output/Naming.out +++ b/test-suite/output/Naming.out @@ -61,3 +61,18 @@ H : a = 0 -> forall a : nat, a = 0 ============================ a = 0 +File "stdin", line 101, characters 47-48: +Warning: Ignoring implicit binder declaration in unexpected position. +[unexpected-implicit-declaration,syntax] +File "stdin", line 105, characters 36-37: +Warning: Ignoring implicit binder declaration in unexpected position. +[unexpected-implicit-declaration,syntax] +File "stdin", line 106, characters 34-35: +Warning: Ignoring implicit binder declaration in unexpected position. +[unexpected-implicit-declaration,syntax] +File "stdin", line 112, characters 22-23: +Warning: Ignoring implicit binder declaration in unexpected position. +[unexpected-implicit-declaration,syntax] +File "stdin", line 112, characters 30-31: +Warning: Ignoring implicit binder declaration in unexpected position. +[unexpected-implicit-declaration,syntax] diff --git a/test-suite/output/Naming.v b/test-suite/output/Naming.v index 7f3b332d7d..610fa48c0c 100644 --- a/test-suite/output/Naming.v +++ b/test-suite/output/Naming.v @@ -90,3 +90,25 @@ apply H with (a:=a). (* test compliance with printing *) Abort. End A. + +Module B. + +(* Check valid/invalid implicit arguments *) +Definition f1 {x} (y:forall {x}, x=0) := x+0. +Definition f2 := (((fun x => 0):forall {x:nat}, nat), 0). +Definition f3 := fun {x} (y:forall {x}, x=0) => x+0. + +Definition g1 {x} := match x with true => fun {x:bool} => x | false => fun x:bool => x end. +(* TODO: do not ignore the implicit here *) +Definition g2 '(x,y) {z} := x+y+z. + +Definition h1 := fun x:nat => (fun {x} => x) 0. +Definition h2 := let g := forall {y}, y=0 in g. + +Notation "∀ x .. y , P" := (forall x, .. (forall y, P) ..) + (at level 200, x binder, y binder, right associativity, + format "'[ ' '[ ' ∀ x .. y ']' , '/' P ']'") : type_scope. + +Definition l1 := ∀ {x:nat} {y:nat}, x=0. + +End B. diff --git a/test-suite/output/Notations.out b/test-suite/output/Notations.out index 94b86fc222..b870fa6f6f 100644 --- a/test-suite/output/Notations.out +++ b/test-suite/output/Notations.out @@ -137,3 +137,71 @@ end = p : forall x : nat, x = x -> Prop bar 0 : nat +let k := rew [P] p in v in k + : P y +let k := rew [P] p in v in k + : P y +let k := rew <- [P] p in v' in k + : P x +let k := rew [P] p in v in k + : P y +let k := rew [P] p in v in k + : P y +let k := rew <- [P] p in v' in k + : P x +let k := rew [fun y : A => P y] p in v in k + : P y +let k := rew [fun y : A => P y] p in v in k + : P y +let k := rew <- [fun y : A => P y] p in v' in k + : P x +let k := rew [fun y : A => P y] p in v in k + : P y +let k := rew [fun y : A => P y] p in v in k + : P y +let k := rew <- [fun y : A => P y] p in v' in k + : P x +let k := rew dependent [P] p in v in k + : P y p +let k := rew dependent [P] p in v in k + : P y p +let k := rew dependent <- [P'] p in v' in k + : P' x (eq_sym p) +let k := rew dependent [P] p in v in k + : P y p +let k := rew dependent [P] p in v in k + : P y p +let k := rew dependent <- [P'] p in v' in k + : P' x (eq_sym p) +let k := rew dependent [P] p in v in k + : P y p +let k := rew dependent [P] p in v in k + : P y p +let k := rew dependent <- [P'] p in v' in k + : P' x (eq_sym p) +let k := rew dependent [fun y p => id (P y p)] p in v in k + : P y p +let k := rew dependent [fun y p => id (P y p)] p in v in k + : P y p +let k := rew dependent <- [fun y0 p => id (P' y0 p)] p in v' in k + : P' x (eq_sym p) +let k := rew dependent [P] p in v in k + : P y p +let k := rew dependent [P] p in v in k + : P y p +let k := rew dependent <- [P'] p in v' in k + : P' x (eq_sym p) +let k := rew dependent [fun y p0 => id (P y p0)] p in v in k + : P y p +let k := rew dependent [fun y p0 => id (P y p0)] p in v in k + : P y p +let k := rew dependent <- [fun y0 p0 => id (P' y0 p0)] p in v' in k + : P' x (eq_sym p) +rew dependent [P] p in v + : P y p +rew dependent <- [P'] p in v' + : P' x (eq_sym p) +rew dependent [fun a x => id (P a x)] p in v + : id (P y p) +rew dependent <- [fun a p' => id (P' a p')] p in v' + : id (P' x (eq_sym p)) diff --git a/test-suite/output/Notations.v b/test-suite/output/Notations.v index adab324cf0..7d2f1e9ba8 100644 --- a/test-suite/output/Notations.v +++ b/test-suite/output/Notations.v @@ -251,11 +251,11 @@ Notation NONE := None. Check (fun x => match x with SOME x => x | NONE => 0 end). Notation NONE2 := (@None _). -Notation SOME2 := (@Some _). +Notation SOME2 := (@Some _). Check (fun x => match x with SOME2 x => x | NONE2 => 0 end). Notation NONE3 := @None. -Notation SOME3 := @Some. +Notation SOME3 := @Some. Check (fun x => match x with SOME3 _ x => x | NONE3 _ => 0 end). Notation "a :'" := (cons a) (at level 12). @@ -300,3 +300,61 @@ Definition bar (a b : nat) := plus a b. Notation "" := A (format "", only printing). Check (bar A 0). End M. + +(* Check eq notations *) +Module EqNotationsCheck. + Import EqNotations. + Section nd. + Context (A : Type) (x : A) (P : A -> Type) + (y : A) (p : x = y) (v : P x) (v' : P y). + + Check let k : P y := rew p in v in k. + Check let k : P y := rew -> p in v in k. + Check let k : P x := rew <- p in v' in k. + Check let k : P y := rew [P] p in v in k. + Check let k : P y := rew -> [P] p in v in k. + Check let k : P x := rew <- [P] p in v' in k. + Check let k : P y := rew [fun y => P y] p in v in k. + Check let k : P y := rew -> [fun y => P y] p in v in k. + Check let k : P x := rew <- [fun y => P y] p in v' in k. + Check let k : P y := rew [fun (y : A) => P y] p in v in k. + Check let k : P y := rew -> [fun (y : A) => P y] p in v in k. + Check let k : P x := rew <- [fun (y : A) => P y] p in v' in k. + End nd. + Section dep. + Context (A : Type) (x : A) (P : forall y, x = y -> Type) + (y : A) (p : x = y) (P' : forall x, y = x -> Type) + (v : P x eq_refl) (v' : P' y eq_refl). + + Check let k : P y p := rew dependent p in v in k. + Check let k : P y p := rew dependent -> p in v in k. + Check let k : P' x (eq_sym p) := rew dependent <- p in v' in k. + Check let k : P y p := rew dependent [P] p in v in k. + Check let k : P y p := rew dependent -> [P] p in v in k. + Check let k : P' x (eq_sym p) := rew dependent <- [P'] p in v' in k. + Check let k : P y p := rew dependent [fun y p => P y p] p in v in k. + Check let k : P y p := rew dependent -> [fun y p => P y p] p in v in k. + Check let k : P' x (eq_sym p) := rew dependent <- [fun y p => P' y p] p in v' in k. + Check let k : P y p := rew dependent [fun y p => id (P y p)] p in v in k. + Check let k : P y p := rew dependent -> [fun y p => id (P y p)] p in v in k. + Check let k : P' x (eq_sym p) := rew dependent <- [fun y p => id (P' y p)] p in v' in k. + Check let k : P y p := rew dependent [(fun (y : A) (p : x = y) => P y p)] p in v in k. + Check let k : P y p := rew dependent -> [(fun (y : A) (p : x = y) => P y p)] p in v in k. + Check let k : P' x (eq_sym p) := rew dependent <- [(fun (x : A) (p : y = x) => P' x p)] p in v' in k. + Check let k : P y p := rew dependent [(fun (y : A) (p : x = y) => id (P y p))] p in v in k. + Check let k : P y p := rew dependent -> [(fun (y : A) (p : x = y) => id (P y p))] p in v in k. + Check let k : P' x (eq_sym p) := rew dependent <- [(fun (x : A) (p : y = x) => id (P' x p))] p in v' in k. + Check match p as x in _ = a return P a x with + | eq_refl => v + end. + Check match eq_sym p as p' in _ = a return P' a p' with + | eq_refl => v' + end. + Check match p as x in _ = a return id (P a x) with + | eq_refl => v + end. + Check match eq_sym p as p' in _ = a return id (P' a p') with + | eq_refl => v' + end. + End dep. +End EqNotationsCheck. diff --git a/test-suite/output/Notations3.v b/test-suite/output/Notations3.v index aeebc0f98b..839df99ea7 100644 --- a/test-suite/output/Notations3.v +++ b/test-suite/output/Notations3.v @@ -219,8 +219,8 @@ Check exists_true '(x,y) (u:=0) '(z,t), x+y=0/\z+t=0. Module G. Generalizable Variables A R. Class Reflexive {A:Type} (R : A->A->Prop) := reflexivity : forall x : A, R x x. -Check exists_true `{Reflexive A R}, forall x, R x x. -Check exists_true x `{Reflexive A R} y, x+y=0 -> forall z, R z z. +Check exists_true `(Reflexive A R), forall x, R x x. +Check exists_true x `(Reflexive A R) y, x+y=0 -> forall z, R z z. End G. (* Allows recursive patterns for binders to be associative on the left *) diff --git a/test-suite/output/Notations4.out b/test-suite/output/Notations4.out index 799d310fa7..f65696e464 100644 --- a/test-suite/output/Notations4.out +++ b/test-suite/output/Notations4.out @@ -4,11 +4,11 @@ Entry constr:myconstr is [ "6" RIGHTA [ ] | "5" RIGHTA - [ SELF; "+"; NEXT ] + [ SELF; "+"; NEXT ] | "4" RIGHTA - [ SELF; "*"; NEXT ] + [ SELF; "*"; NEXT ] | "3" RIGHTA - [ "<"; constr:operconstr LEVEL "10"; ">" ] ] + [ "<"; constr:operconstr LEVEL "10"; ">" ] ] [< b > + < b > * < 2 >] : nat @@ -63,3 +63,11 @@ fun '{| |} => true : R -> bool b = a : Prop +The command has indeed failed with message: +The format is not the same on the right- and left-hand sides of the special token "..". +The command has indeed failed with message: +The format is not the same on the right- and left-hand sides of the special token "..". +The command has indeed failed with message: +The format is not the same on the right- and left-hand sides of the special token "..". +The command has indeed failed with message: +The format is not the same on the right- and left-hand sides of the special token "..". diff --git a/test-suite/output/Notations4.v b/test-suite/output/Notations4.v index 26c7840a16..4de6ce19b4 100644 --- a/test-suite/output/Notations4.v +++ b/test-suite/output/Notations4.v @@ -158,3 +158,29 @@ Check b = a. End Test. End L. + +Module M. + +(* Accept boxes around the end variables of a recursive notation (if equal boxes) *) + +Notation " {@ T1 ; T2 ; .. ; Tn } " := + (and T1 (and T2 .. (and Tn True)..)) + (format "'[v' {@ '[' T1 ']' ; '//' '[' T2 ']' ; '//' .. ; '//' '[' Tn ']' } ']'"). + +Fail Notation " {@ T1 ; T2 ; .. ; Tn } " := + (and T1 (and T2 .. (and Tn True)..)) + (format "'[v' {@ '[' T1 ']' ; '//' '[' T2 ']' ; '//' .. ; '//' '[' Tn ']' } ']'"). + +Fail Notation " {@ T1 ; T2 ; .. ; Tn } " := + (and T1 (and T2 .. (and Tn True)..)) + (format "'[v' {@ '[' T1 ']' ; '//' '[' T2 ']' ; '//' .. ; '//' '[v' Tn ']' } ']'"). + +Fail Notation " {@ T1 ; T2 ; .. ; Tn } " := + (and T1 (and T2 .. (and Tn True)..)) + (format "'[v' {@ '[' T1 ']' ; '//' '[' T2 ']' ; '//' .. ; '//' '[' Tn ']' } ']'"). + +Fail Notation " {@ T1 ; T2 ; .. ; Tn } " := + (and T1 (and T2 .. (and Tn True)..)) + (format "'[v' {@ '[' T1 ']' ; '//' '[' T2 ']' ; '//' .. ; '//' '[' Tn ']' } ']'"). + +End M. diff --git a/test-suite/output/Notations5.out b/test-suite/output/Notations5.out new file mode 100644 index 0000000000..83dd2f40fb --- /dev/null +++ b/test-suite/output/Notations5.out @@ -0,0 +1,248 @@ +p 0 0 true + : 0 = 0 /\ true = true +p 0 0 + : forall b : ?B, 0 = 0 /\ b = b +where +?B : [ |- Type] +p 0 + : forall (a2 : nat) (B : Type) (b : B), 0 = a2 /\ b = b +p 0 0 (B:=bool) + : forall b : bool, 0 = 0 /\ b = b +p 0 0 (B:=bool) + : forall b : bool, 0 = 0 /\ b = b +p (A:=nat) + : forall (a1 a2 : nat) (B : Type) (b : B), a1 = a2 /\ b = b +p (A:=nat) + : forall (a1 a2 : nat) (B : Type) (b : B), a1 = a2 /\ b = b +@p nat 0 0 + : forall (B : Type) (b : B), 0 = 0 /\ b = b +@p + : forall (A : Type) (a1 a2 : A) (B : Type) (b : B), a1 = a2 /\ b = b +p 0 0 + : forall b : bool, 0 = 0 /\ b = b +p + : forall (a1 a2 : nat) (B : Type) (b : B), a1 = a2 /\ b = b +p 0 0 true + : 0 = 0 /\ true = true +p 0 0 + : forall b : ?B, 0 = 0 /\ b = b +where +?B : [ |- Type] +p 0 + : forall (a2 : nat) (B : Type) (b : B), 0 = a2 /\ b = b +p 0 0 + : forall b : bool, 0 = 0 /\ b = b +p 0 0 + : forall b : bool, 0 = 0 /\ b = b +p + : forall (a1 a2 : nat) (B : Type) (b : B), a1 = a2 /\ b = b +p + : forall (a1 a2 : nat) (B : Type) (b : B), a1 = a2 /\ b = b +@p nat 0 0 + : forall (B : Type) (b : B), 0 = 0 /\ b = b +@p + : forall (A : Type) (a1 a2 : A) (B : Type) (b : B), a1 = a2 /\ b = b +f x true + : 0 = 0 /\ true = true +f x (B:=bool) + : forall b : bool, 0 = 0 /\ b = b +f x (B:=bool) + : forall b : bool, 0 = 0 /\ b = b +@f nat + : forall a1 a2 : nat, + T a1 a2 -> forall (B : Type) (b : B), a1 = a2 /\ b = b +f (a1:=0) (a2:=0) + : T 0 0 -> forall (B : Type) (b : B), 0 = 0 /\ b = b +f (a1:=0) (a2:=0) + : T 0 0 -> forall (B : Type) (b : B), 0 = 0 /\ b = b +@f + : forall (A : Type) (a1 a2 : A), + T a1 a2 -> forall (B : Type) (b : B), a1 = a2 /\ b = b +f + : T 0 0 -> forall (B : Type) (b : B), 0 = 0 /\ b = b +x.(f) true + : 0 = 0 /\ true = true +x.(f) (B:=bool) + : forall b : bool, 0 = 0 /\ b = b +x.(f) (B:=bool) + : forall b : bool, 0 = 0 /\ b = b +@f nat + : forall a1 a2 : nat, + T a1 a2 -> forall (B : Type) (b : B), a1 = a2 /\ b = b +f (a1:=0) (a2:=0) + : T 0 0 -> forall (B : Type) (b : B), 0 = 0 /\ b = b +f (a1:=0) (a2:=0) + : T 0 0 -> forall (B : Type) (b : B), 0 = 0 /\ b = b +@f + : forall (A : Type) (a1 a2 : A), + T a1 a2 -> forall (B : Type) (b : B), a1 = a2 /\ b = b +f + : T 0 0 -> forall (B : Type) (b : B), 0 = 0 /\ b = b +p + : forall (a1 a2 : ?A) (B : Type) (b : B), a1 = a2 /\ b = b +where +?A : [ |- Type] +p + : forall (a1 a2 : ?A) (B : Type) (b : B), a1 = a2 /\ b = b +where +?A : [ |- Type] +u + : forall (A : Type) (a1 a2 : A) (B : Type) (b : B), a1 = a2 /\ b = b +u + : forall (A : Type) (a1 a2 : A) (B : Type) (b : B), a1 = a2 /\ b = b +p 0 0 + : forall b : ?B, 0 = 0 /\ b = b +where +?B : [ |- Type] +p 0 0 + : forall b : bool, 0 = 0 /\ b = b +@p nat 0 0 + : forall (B : Type) (b : B), 0 = 0 /\ b = b +@p nat 0 0 + : forall (B : Type) (b : B), 0 = 0 /\ b = b +u + : forall (a1 a2 : ?A) (B : Type) (b : B), a1 = a2 /\ b = b +where +?A : [ |- Type] +u + : forall (A : Type) (a1 a2 : A) (B : Type) (b : B), a1 = a2 /\ b = b +u + : forall (A : Type) (a1 a2 : A) (B : Type) (b : B), a1 = a2 /\ b = b +u + : forall (a1 a2 : ?A) (B : Type) (b : B), a1 = a2 /\ b = b +where +?A : [ |- Type] +u 0 0 + : forall b : ?B, 0 = 0 /\ b = b +where +?B : [ |- Type] +u 0 0 + : forall b : ?B, 0 = 0 /\ b = b +where +?B : [ |- Type] +@u nat 0 0 + : forall (B : Type) (b : B), 0 = 0 /\ b = b +@u nat 0 0 + : forall (B : Type) (b : B), 0 = 0 /\ b = b +u 0 0 true + : 0 = 0 /\ true = true +u 0 0 true + : 0 = 0 /\ true = true +v + : forall (a2 : nat) (B : Type) (b : B), 0 = a2 /\ b = b +v 0 + : forall b : ?B, 0 = 0 /\ b = b +where +?B : [ |- Type] +v 0 + : forall b : ?B, 0 = 0 /\ b = b +where +?B : [ |- Type] +v 0 (B:=bool) true + : 0 = 0 /\ true = true +v + : forall (a2 : nat) (B : Type) (b : B), 0 = a2 /\ b = b +@v 0 + : forall (B : Type) (b : B), 0 = 0 /\ b = b +@v 0 + : forall (B : Type) (b : B), 0 = 0 /\ b = b +v 0 (B:=bool) + : forall b : bool, 0 = 0 /\ b = b +v + : forall (a2 : nat) (B : Type) (b : B), 0 = a2 /\ b = b +v 0 + : forall b : ?B, 0 = 0 /\ b = b +where +?B : [ |- Type] +v 0 + : forall b : ?B, 0 = 0 /\ b = b +where +?B : [ |- Type] +v 0 (B:=bool) true + : 0 = 0 /\ true = true +v + : forall (a2 : nat) (B : Type) (b : B), 0 = a2 /\ b = b +@v 0 + : forall (B : Type) (b : B), 0 = 0 /\ b = b +@v 0 + : forall (B : Type) (b : B), 0 = 0 /\ b = b +v 0 (B:=bool) + : forall b : bool, 0 = 0 /\ b = b +## + : forall (a1 a2 : ?A) (B : Type) (b : B), a1 = a2 /\ b = b +where +?A : [ |- Type] +## + : forall (a1 a2 : ?A) (B : Type) (b : B), a1 = a2 /\ b = b +where +?A : [ |- Type] +## 0 + : forall (a2 : nat) (B : Type) (b : B), 0 = a2 /\ b = b +## 0 + : forall (a2 : nat) (B : Type) (b : B), 0 = a2 /\ b = b +## 0 0 + : forall b : ?B, 0 = 0 /\ b = b +where +?B : [ |- Type] +## 0 0 + : forall b : ?B, 0 = 0 /\ b = b +where +?B : [ |- Type] +## 0 0 (B:=bool) true + : 0 = 0 /\ true = true +## 0 0 (B:=bool) true + : 0 = 0 /\ true = true +## 0 0 (B:=bool) + : forall b : bool, 0 = 0 /\ b = b +## 0 0 (B:=bool) + : forall b : bool, 0 = 0 /\ b = b +p + : forall (a1 a2 : ?A) (B : Type) (b : B), a1 = a2 /\ b = b +where +?A : [ |- Type] +## + : forall (A : Type) (a1 a2 : A) (B : Type) (b : B), a1 = a2 /\ b = b +## + : forall (A : Type) (a1 a2 : A) (B : Type) (b : B), a1 = a2 /\ b = b +p 0 + : forall (a2 : nat) (B : Type) (b : B), 0 = a2 /\ b = b +p 0 + : forall (a2 : nat) (B : Type) (b : B), 0 = a2 /\ b = b +@p nat 0 0 + : forall (B : Type) (b : B), 0 = 0 /\ b = b +p 0 0 + : forall b : ?B, 0 = 0 /\ b = b +where +?B : [ |- Type] +p 0 0 + : forall b : ?B, 0 = 0 /\ b = b +where +?B : [ |- Type] +p 0 0 (B:=bool) + : forall b : bool, 0 = 0 /\ b = b +p 0 0 true + : 0 = 0 /\ true = true +## 0 + : forall (a2 : nat) (B : Type) (b : B), 0 = a2 /\ b = b +## 0 + : forall (a2 : nat) (B : Type) (b : B), 0 = a2 /\ b = b +## 0 0 (B:=bool) + : forall b : bool, 0 = 0 /\ b = b +## 0 0 (B:=bool) + : forall b : bool, 0 = 0 /\ b = b +## 0 0 (B:=bool) true + : 0 = 0 /\ true = true +## 0 0 (B:=bool) true + : 0 = 0 /\ true = true +## 0 + : forall (a2 : nat) (B : Type) (b : B), 0 = a2 /\ b = b +## 0 + : forall (a2 : nat) (B : Type) (b : B), 0 = a2 /\ b = b +## 0 0 (B:=bool) + : forall b : bool, 0 = 0 /\ b = b +## 0 0 (B:=bool) + : forall b : bool, 0 = 0 /\ b = b +## 0 0 (B:=bool) true + : 0 = 0 /\ true = true +## 0 0 (B:=bool) true + : 0 = 0 /\ true = true diff --git a/test-suite/output/Notations5.v b/test-suite/output/Notations5.v new file mode 100644 index 0000000000..b3bea929ba --- /dev/null +++ b/test-suite/output/Notations5.v @@ -0,0 +1,340 @@ +Module AppliedTermsPrinting. + +(* Test different printing paths for applied terms *) + + Module InferredGivenImplicit. + Set Implicit Arguments. + Set Maximal Implicit Insertion. + + Axiom p : forall A (a1 a2:A) B (b:B), a1 = a2 /\ b = b. + + Check p 0 0 true. + (* p 0 0 true *) + Check p 0 0. + (* p 0 0 *) + Check p 0. + (* p 0 *) + Check @p _ 0 0 bool. + (* p 0 0 (B:=bool) *) + Check p 0 0 (B:=bool). + (* p 0 0 (B:=bool) *) + Check @p nat. + (* p (A:=nat) *) + Check p (A:=nat). + (* p (A:=nat) *) + Check @p _ 0 0. + (* @p nat 0 0 *) + Check @p. + (* @p *) + + Unset Printing Implicit Defensive. + Check @p _ 0 0 bool. + (* p 0 0 *) + Check @p nat. + (* p *) + Set Printing Implicit Defensive. + End InferredGivenImplicit. + + Module ManuallyGivenImplicit. + Axiom p : forall {A} (a1 a2:A) {B} (b:B), a1 = a2 /\ b = b. + + Check p 0 0 true. + (* p 0 0 true *) + Check p 0 0. + (* p 0 0 *) + Check p 0. + (* p 0 *) + Check @p _ 0 0 bool. + (* p 0 0 *) + Check p 0 0 (B:=bool). + (* p 0 0 *) + Check @p nat. + (* p *) + Check p (A:=nat). + (* p *) + Check @p _ 0 0. + (* @p nat 0 0 *) + Check @p. + (* @p *) + + End ManuallyGivenImplicit. + + Module ProjectionWithImplicits. + Set Implicit Arguments. + Set Maximal Implicit Insertion. + + Record T {A} (a1 a2:A) := { f : forall B (b:B), a1 = a2 /\ b = b }. + Parameter x : T 0 0. + Check f x true. + (* f x true *) + Check @f _ _ _ x bool. + (* f x (B:=bool) *) + Check f x (B:=bool). + (* f x (B:=bool) *) + Check @f nat. + (* @f nat *) + Check @f _ 0 0. + (* f (a1:=0) (a2:=0) *) + Check f (a1:=0) (a2:=0). + (* f (a1:=0) (a2:=0) *) + Check @f. + (* @f *) + + Unset Printing Implicit Defensive. + Check f (a1:=0) (a2:=0). + (* f *) + Set Printing Implicit Defensive. + + Set Printing Projections. + + Check x.(f) true. + (* x.(f) true *) + Check x.(@f _ _ _) bool. + (* x.(f) (B:=bool) *) + Check x.(f) (B:=bool). + (* x.(f) (B:=bool) *) + Check @f nat. + (* @f nat *) + Check @f _ 0 0. + (* f (a1:=0) (a2:=0) *) + Check f (a1:=0) (a2:=0). + (* f (a1:=0) (a2:=0) *) + Check @f. + (* @f *) + + Unset Printing Implicit Defensive. + Check f (a1:=0) (a2:=0). + (* f *) + + End ProjectionWithImplicits. + + Module AtAbbreviationForApplicationHead. + + Axiom p : forall {A} (a1 a2:A) {B} (b:B), a1 = a2 /\ b = b. + + Notation u := @p. + + Check u _. + (* p *) + Check p. + (* p *) + Check @p. + (* u *) + Check u. + (* u *) + Check p 0 0. + (* p 0 0 *) + Check u nat 0 0 bool. + (* p 0 0 -- WEAKNESS should ideally be (B:=bool) *) + Check u nat 0 0. + (* @p nat 0 0 *) + Check @p nat 0 0. + (* @p nat 0 0 *) + + End AtAbbreviationForApplicationHead. + + Module AbbreviationForApplicationHead. + + Set Implicit Arguments. + Set Maximal Implicit Insertion. + + Axiom p : forall A (a1 a2:A) B (b:B), a1 = a2 /\ b = b. + + Notation u := p. + + Check p. + (* u *) + Check @p. + (* u -- BUG *) + Check @u. + (* u -- BUG *) + Check u. + (* u *) + Check p 0 0. + (* u 0 0 *) + Check u 0 0. + (* u 0 0 *) + Check @p nat 0 0. + (* @u nat 0 0 *) + Check @u nat 0 0. + (* @u nat 0 0 *) + Check p 0 0 true. + (* u 0 0 true *) + Check u 0 0 true. + (* u 0 0 true *) + + End AbbreviationForApplicationHead. + + Module AtAbbreviationForPartialApplication. + + Set Implicit Arguments. + Set Maximal Implicit Insertion. + + Axiom p : forall A (a1 a2:A) B (b:B), a1 = a2 /\ b = b. + + Notation v := (@p _ 0). + + Check v. + (* v *) + Check p 0 0. + (* v 0 *) + Check v 0. + (* v 0 *) + Check v 0 true. + (* v 0 (B:=bool) true -- BUG *) + Check @p nat 0. + (* v *) + Check @p nat 0 0. + (* @v 0 *) + Check @v 0. + (* @v 0 *) + Check @p nat 0 0 bool. + (* v 0 (B:=bool) *) + + End AtAbbreviationForPartialApplication. + + Module AbbreviationForPartialApplication. + + Set Implicit Arguments. + Set Maximal Implicit Insertion. + + Axiom p : forall A (a1 a2:A) B (b:B), a1 = a2 /\ b = b. + + Notation v := (p 0). + + Check v. + (* v *) + Check p 0 0. + (* v 0 *) + Check v 0. + (* v 0 *) + Check v 0 true. + (* v 0 (B:=bool) true -- BUG *) + Check @p nat 0. + (* v *) + Check @p nat 0 0. + (* @v 0 *) + Check @v 0. + (* @v 0 *) + Check @p nat 0 0 bool. + (* v 0 (B:=bool) *) + + End AbbreviationForPartialApplication. + + Module NotationForHeadApplication. + + Set Implicit Arguments. + Set Maximal Implicit Insertion. + + Axiom p : forall A (a1 a2:A) B (b:B), a1 = a2 /\ b = b. + + Notation "##" := p (at level 0). + + Check p. + (* ## *) + Check ##. + (* ## *) + Check p 0. + (* ## 0 *) + Check ## 0. + (* ## 0 *) + Check p 0 0. + (* ## 0 0 *) + Check ## 0 0. + (* ## 0 0 *) + Check p 0 0 true. + (* ## 0 0 (B:=bool) true -- BUG B should not be displayed *) + Check ## 0 0 true. + (* ## 0 0 (B:=bool) true -- BUG B should not be displayed *) + Check p 0 0 (B:=bool). + (* ## 0 0 (B:=bool) *) + Check ## 0 0 (B:=bool). + (* ## 0 0 (B:=bool) *) + + End NotationForHeadApplication. + + Module AtNotationForHeadApplication. + + Set Implicit Arguments. + Set Maximal Implicit Insertion. + + Axiom p : forall A (a1 a2:A) B (b:B), a1 = a2 /\ b = b. + + Notation "##" := @p (at level 0). + + Check p. + (* p *) + Check @p. + (* ## *) + Check ##. + (* ## *) + Check p 0. + (* p 0 -- why not "## nat 0" *) + Check ## nat 0. + (* p 0 *) + Check ## nat 0 0. + (* @p nat 0 0 *) + Check p 0 0. + (* p 0 0 *) + Check ## nat 0 0 _. + (* p 0 0 *) + Check ## nat 0 0 bool. + (* p 0 0 (B:=bool) *) + Check ## nat 0 0 bool true. + (* p 0 0 true *) + + End AtNotationForHeadApplication. + + Module NotationForPartialApplication. + + Set Implicit Arguments. + Set Maximal Implicit Insertion. + + Axiom p : forall A (a1 a2:A) B (b:B), a1 = a2 /\ b = b. + + Notation "## q" := (p q) (at level 0, q at level 0). + + Check p 0. + (* ## 0 *) + Check ## 0. + (* ## 0 *) + (* Check ## 0 0. *) + (* Anomaly *) + Check p 0 0 (B:=bool). + (* ## 0 0 (B:=bool) *) + Check ## 0 0 bool. + (* ## 0 0 (B:=bool) -- INCONSISTENT parsing/printing *) + Check p 0 0 true. + (* ## 0 0 (B:=bool) true -- BUG B should not be displayed *) + Check ## 0 0 bool true. + (* ## 0 0 (B:=bool) true -- INCONSISTENT parsing/printing + BUG B should not be displayed *) + + End NotationForPartialApplication. + + Module AtNotationForPartialApplication. + + Set Implicit Arguments. + Set Maximal Implicit Insertion. + + Axiom p : forall A (a1 a2:A) B (b:B), a1 = a2 /\ b = b. + + Notation "## q" := (@p _ q) (at level 0, q at level 0). + + Check p 0. + (* ## 0 *) + Check ## 0. + (* ## 0 *) + (* Check ## 0 0. *) + (* Anomaly *) + Check p 0 0 (B:=bool). + (* ## 0 0 (B:=bool) *) + Check ## 0 0 bool. + (* ## 0 0 (B:=bool) -- INCONSISTENT parsing/printing *) + Check p 0 0 true. + (* ## 0 0 (B:=bool) true -- BUG B should not be displayed *) + Check ## 0 0 bool true. + (* ## 0 0 (B:=bool) true -- INCONSISTENCY parsing/printing + BUG B should not be displayed *) + + End AtNotationForPartialApplication. + +End AppliedTermsPrinting. diff --git a/test-suite/output/PrintAssumptions.out b/test-suite/output/PrintAssumptions.out index 3f4d5ef58c..190c34262f 100644 --- a/test-suite/output/PrintAssumptions.out +++ b/test-suite/output/PrintAssumptions.out @@ -3,6 +3,10 @@ foo : nat Axioms: foo : nat Axioms: +bli : Type +Axioms: +bli : Type +Axioms: extensionality : forall (P Q : Type) (f g : P -> Q), (forall x : P, f x = g x) -> f = g Axioms: diff --git a/test-suite/output/PrintAssumptions.v b/test-suite/output/PrintAssumptions.v index 3d4dfe603d..4c980fddba 100644 --- a/test-suite/output/PrintAssumptions.v +++ b/test-suite/output/PrintAssumptions.v @@ -30,6 +30,21 @@ Module P := N M. Print Assumptions M.bar. (* Should answer: foo *) Print Assumptions P.bar. (* Should answer: foo *) +(* Print Assumptions used empty instances on polymorphic inductives *) +Module Poly. + + Set Universe Polymorphism. + Axiom bli : Type. + + Definition bla := bli -> bli. + + Inductive blo : bli -> Type := . + + Print Assumptions bla. + Print Assumptions blo. + +End Poly. + (* The original test-case of the bug-report *) diff --git a/test-suite/output/QArithSyntax.out b/test-suite/output/QArithSyntax.out new file mode 100644 index 0000000000..6bc04f1cef --- /dev/null +++ b/test-suite/output/QArithSyntax.out @@ -0,0 +1,14 @@ +eq_refl : 102e-2 = 102e-2 + : 102e-2 = 102e-2 +eq_refl : 102e-1 = 102e-1 + : 102e-1 = 102e-1 +eq_refl : 1020 = 1020 + : 1020 = 1020 +eq_refl : 102 = 102 + : 102 = 102 +eq_refl : 102e-2 = 102e-2 + : 102e-2 = 102e-2 +eq_refl : -1e-4 = -1e-4 + : -1e-4 = -1e-4 +eq_refl : -50e-2 = -50e-2 + : -50e-2 = -50e-2 diff --git a/test-suite/success/QArithSyntax.v b/test-suite/output/QArithSyntax.v index 2f2ee0134a..2f2ee0134a 100644 --- a/test-suite/success/QArithSyntax.v +++ b/test-suite/output/QArithSyntax.v diff --git a/test-suite/output/RealSyntax.out b/test-suite/output/RealSyntax.out index e6f7556d96..2d877bd813 100644 --- a/test-suite/output/RealSyntax.out +++ b/test-suite/output/RealSyntax.out @@ -2,3 +2,17 @@ : R (-31)%R : R +eq_refl : 102e-2 = 102e-2 + : 102e-2 = 102e-2 +eq_refl : 102e-1 = 102e-1 + : 102e-1 = 102e-1 +eq_refl : 102e1 = 102e1 + : 102e1 = 102e1 +eq_refl : 102 = 102 + : 102 = 102 +eq_refl : 102e-2 = 102e-2 + : 102e-2 = 102e-2 +eq_refl : -1e-4 = -1e-4 + : -1e-4 = -1e-4 +eq_refl : -50e-2 = -50e-2 + : -50e-2 = -50e-2 diff --git a/test-suite/output/RealSyntax.v b/test-suite/output/RealSyntax.v index 44e8c7a50c..cb3bce70d4 100644 --- a/test-suite/output/RealSyntax.v +++ b/test-suite/output/RealSyntax.v @@ -1,3 +1,25 @@ Require Import Reals.Rdefinitions. Check 32%R. Check (-31)%R. + +Open Scope R_scope. + +Check (eq_refl : 1.02 = IZR 102 / IZR (Z.pow_pos 10 2)). +Check (eq_refl : 1.02e1 = IZR 102 / IZR (Z.pow_pos 10 1)). +Check (eq_refl : 1.02e+03 = IZR 102 * IZR (Z.pow_pos 10 1)). +Check (eq_refl : 1.02e+02 = IZR 102). +Check (eq_refl : 10.2e-1 = 1.02). +Check (eq_refl : -0.0001 = IZR (-1) / IZR (Z.pow_pos 10 4)). +Check (eq_refl : -0.50 = IZR (-50) / IZR (Z.pow_pos 10 2)). + +Require Import Reals. + +Goal 254e3 = 2540 * 10 ^ 2. +ring. +Qed. + +Require Import Psatz. + +Goal 254e3 = 2540 * 10 ^ 2. +lra. +Qed. diff --git a/test-suite/success/CompatOldOldFlag.v b/test-suite/success/CompatOldOldFlag.v deleted file mode 100644 index dd259988ac..0000000000 --- a/test-suite/success/CompatOldOldFlag.v +++ /dev/null @@ -1,6 +0,0 @@ -(* -*- coq-prog-args: ("-compat" "8.9") -*- *) -(** Check that the current-minus-three compatibility flag actually requires the relevant modules. *) -Import Coq.Compat.Coq812. -Import Coq.Compat.Coq811. -Import Coq.Compat.Coq810. -Import Coq.Compat.Coq89. diff --git a/test-suite/success/Generalization.v b/test-suite/success/Generalization.v index de34e007d2..df729588f4 100644 --- a/test-suite/success/Generalization.v +++ b/test-suite/success/Generalization.v @@ -11,4 +11,10 @@ Admitted. Print a_eq_b. +Require Import Morphisms. +Class Equiv A := equiv : A -> A -> Prop. +Class Setoid A `{Equiv A} := setoid_equiv:> Equivalence (equiv). + +Lemma vcons_proper A `[Equiv A] `[!Setoid A] (x : True) : True. +Admitted. diff --git a/test-suite/success/ImplicitArguments.v b/test-suite/success/ImplicitArguments.v index b16e4a1186..e68040e4d4 100644 --- a/test-suite/success/ImplicitArguments.v +++ b/test-suite/success/ImplicitArguments.v @@ -1,3 +1,15 @@ + +Axiom foo : forall (x y z t : nat), nat. + +Arguments foo {_} _ [z] t. +Check (foo 1). +Arguments foo {_} _ {z} {t}. +Fail Arguments foo {_} _ [z] {t}. +Check (foo 1). + +Definition foo1 [m] n := n + m. +Check (foo1 1). + Inductive vector {A : Type} : nat -> Type := | vnil : vector 0 | vcons : A -> forall {n'}, vector n' -> vector (S n'). @@ -33,3 +45,11 @@ Abort. Inductive A {P:forall m {n}, n=m -> Prop} := C : P 0 eq_refl -> A. Inductive B (P:forall m {n}, n=m -> Prop) := D : P 0 eq_refl -> B P. + +Inductive A' {P:forall m [n], n=m -> Prop} := C' : P 0 eq_refl -> A'. +Inductive A'' [P:forall m {n}, n=m -> Prop] (b : bool):= C'' : P 0 eq_refl -> A'' b. +Inductive A''' (P:forall m [n], n=m -> Prop) (b : bool):= C''' : P 0 eq_refl -> A''' P b. + +Definition F (id: forall [A] [x : A], A) := id. +Definition G := let id := (fun [A] (x : A) => x) in id. +Fail Definition G' := let id := (fun {A} (x : A) => x) in id. diff --git a/test-suite/success/RealSyntax.v b/test-suite/success/RealSyntax.v deleted file mode 100644 index 2765200991..0000000000 --- a/test-suite/success/RealSyntax.v +++ /dev/null @@ -1,19 +0,0 @@ -Require Import Reals. -Open Scope R_scope. -Check (eq_refl : 1.02 = IZR 102 / IZR (Z.pow_pos 10 2)). -Check (eq_refl : 1.02e1 = IZR 102 / IZR (Z.pow_pos 10 1)). -Check (eq_refl : 1.02e+03 = IZR 102 * IZR (Z.pow_pos 10 1)). -Check (eq_refl : 1.02e+02 = IZR 102). -Check (eq_refl : 10.2e-1 = 1.02). -Check (eq_refl : -0.0001 = IZR (-1) / IZR (Z.pow_pos 10 4)). -Check (eq_refl : -0.5 = IZR (-5) / IZR (Z.pow_pos 10 1)). - -Goal 254e3 = 2540 * 10 ^ 2. -ring. -Qed. - -Require Import Psatz. - -Goal 254e3 = 2540 * 10 ^ 2. -lra. -Qed. diff --git a/test-suite/success/Scheme.v b/test-suite/success/Scheme.v index 855f26698c..4b928007cf 100644 --- a/test-suite/success/Scheme.v +++ b/test-suite/success/Scheme.v @@ -25,3 +25,8 @@ Check myeq_rew_fwd_r_dep. Set Rewriting Schemes. Inductive myeq_true : bool -> Prop := myrefl_true : myeq_true true. Unset Rewriting Schemes. + +(* check that the scheme doesn't minimize itself into something non general *) +Polymorphic Inductive foo@{u v|u<=v} : Type@{u}:= . +Lemma bla@{u v|u < v} : foo@{u v} -> False. +Proof. induction 1. Qed. diff --git a/test-suite/success/implicit.v b/test-suite/success/implicit.v index ecaaedca53..59650d6822 100644 --- a/test-suite/success/implicit.v +++ b/test-suite/success/implicit.v @@ -114,9 +114,13 @@ Check h 0. Inductive I {A} (a:A) : forall {n:nat}, Prop := | C : I a (n:=0). +Inductive I' [A] (a:A) : forall [n:nat], n =0 -> Prop := + | C' : I' a eq_refl. + Inductive I2 (x:=0) : Prop := - | C2 {p:nat} : p = 0 -> I2. -Check C2 eq_refl. + | C2 {p:nat} : p = 0 -> I2 + | C2' [p:nat] : p = 0 -> I2. +Check C2' eq_refl. Inductive I3 {A} (x:=0) (a:A) : forall {n:nat}, Prop := | C3 : I3 a (n:=0). @@ -147,6 +151,7 @@ Set Warnings "syntax". (* Miscellaneous tests *) Check let f := fun {x:nat} y => y=true in f false. +Check let f := fun [x:nat] y => y=true in f false. (* Isn't the name "arg_1" a bit fragile, here? *) @@ -157,3 +162,23 @@ Check fun f : forall {_:nat}, nat => f (arg_1:=0). Set Warnings "+syntax". Check id (fun x => let f c {a} (b:a=a) := b in f true (eq_refl 0)). Set Warnings "syntax". + + +Axiom eq0le0 : forall (n : nat) (x : n = 0), n <= 0. +Variable eq0le0' : forall (n : nat) {x : n = 0}, n <= 0. +Axiom eq0le0'' : forall (n : nat) {x : n = 0}, n <= 0. +Definition eq0le0''' : forall (n : nat) {x : n = 0}, n <= 0. Admitted. +Fail Axiom eq0le0'''' : forall [n : nat] {x : n = 0}, n <= 0. + +Module TestUnnamedImplicit. + +Axiom foo : forall A, A -> A. + +Arguments foo {A} {_}. +Check foo (arg_2:=true) : bool. +Check foo : bool. + +Arguments foo {A} {x}. +Check foo (x:=true) : bool. + +End TestUnnamedImplicit. diff --git a/test-suite/success/uniform_inductive_parameters.v b/test-suite/success/uniform_inductive_parameters.v index 42236a5313..651247937d 100644 --- a/test-suite/success/uniform_inductive_parameters.v +++ b/test-suite/success/uniform_inductive_parameters.v @@ -1,13 +1,23 @@ +Module Att. + #[uniform] Inductive list (A : Type) := + | nil : list + | cons : A -> list -> list. + Check (list : Type -> Type). + Check (cons : forall A, A -> list A -> list A). +End Att. + Set Uniform Inductive Parameters. Inductive list (A : Type) := - | nil : list - | cons : A -> list -> list. +| nil : list +| cons : A -> list -> list. Check (list : Type -> Type). Check (cons : forall A, A -> list A -> list A). Inductive list2 (A : Type) (A' := prod A A) := - | nil2 : list2 - | cons2 : A' -> list2 -> list2. +| nil2 : list2 +| cons2 : A' -> list2 -> list2. Check (list2 : Type -> Type). Check (cons2 : forall A (A' := prod A A), A' -> list2 A -> list2 A). + +#[nonuniform] Inductive bla (n:nat) := c (_ : bla (S n)). diff --git a/test-suite/tools/update-compat/run.sh b/test-suite/tools/update-compat/run.sh index 61273c4f37..7ff5571ffb 100755 --- a/test-suite/tools/update-compat/run.sh +++ b/test-suite/tools/update-compat/run.sh @@ -6,4 +6,4 @@ SCRIPT_DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null && pwd )" # we assume that the script lives in test-suite/tools/update-compat/, # and that update-compat.py lives in dev/tools/ cd "${SCRIPT_DIR}/../../.." -dev/tools/update-compat.py --assert-unchanged --master || exit $? +dev/tools/update-compat.py --assert-unchanged --release || exit $? diff --git a/theories/Compat/Coq89.v b/theories/Compat/Coq89.v deleted file mode 100644 index 274cb4afd3..0000000000 --- a/theories/Compat/Coq89.v +++ /dev/null @@ -1,19 +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) *) -(************************************************************************) - -(** Compatibility file for making Coq act similar to Coq v8.9 *) -Local Set Warnings "-deprecated". - -Require Export Coq.Compat.Coq810. - -Unset Private Polymorphic Universes. - -(** Unsafe flag, can hide inconsistencies. *) -Global Unset Template Check. diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index 4d84d61f9f..8ba17e38c8 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -460,6 +460,58 @@ Module EqNotations. Notation "'rew' -> [ P ] H 'in' H'" := (eq_rect _ P H' _ H) (at level 10, H' at level 10, only parsing). + Notation "'rew' 'dependent' H 'in' H'" + := (match H with + | eq_refl => H' + end) + (at level 10, H' at level 10, + format "'[' 'rew' 'dependent' H in '/' H' ']'"). + Notation "'rew' 'dependent' -> H 'in' H'" + := (match H with + | eq_refl => H' + end) + (at level 10, H' at level 10, only parsing). + Notation "'rew' 'dependent' <- H 'in' H'" + := (match eq_sym H with + | eq_refl => H' + end) + (at level 10, H' at level 10, + format "'[' 'rew' 'dependent' <- H in '/' H' ']'"). + Notation "'rew' 'dependent' [ 'fun' y p => P ] H 'in' H'" + := (match H as p in (_ = y) return P with + | eq_refl => H' + end) + (at level 10, H' at level 10, y ident, p ident, + format "'[' 'rew' 'dependent' [ 'fun' y p => P ] '/ ' H in '/' H' ']'"). + Notation "'rew' 'dependent' -> [ 'fun' y p => P ] H 'in' H'" + := (match H as p in (_ = y) return P with + | eq_refl => H' + end) + (at level 10, H' at level 10, y ident, p ident, only parsing). + Notation "'rew' 'dependent' <- [ 'fun' y p => P ] H 'in' H'" + := (match eq_sym H as p in (_ = y) return P with + | eq_refl => H' + end) + (at level 10, H' at level 10, y ident, p ident, + format "'[' 'rew' 'dependent' <- [ 'fun' y p => P ] '/ ' H in '/' H' ']'"). + Notation "'rew' 'dependent' [ P ] H 'in' H'" + := (match H as p in (_ = y) return P y p with + | eq_refl => H' + end) + (at level 10, H' at level 10, + format "'[' 'rew' 'dependent' [ P ] '/ ' H in '/' H' ']'"). + Notation "'rew' 'dependent' -> [ P ] H 'in' H'" + := (match H as p in (_ = y) return P y p with + | eq_refl => H' + end) + (at level 10, H' at level 10, + only parsing). + Notation "'rew' 'dependent' <- [ P ] H 'in' H'" + := (match eq_sym H as p in (_ = y) return P y p with + | eq_refl => H' + end) + (at level 10, H' at level 10, + format "'[' 'rew' 'dependent' <- [ P ] '/ ' H in '/' H' ']'"). End EqNotations. Import EqNotations. @@ -793,13 +845,6 @@ Qed. Declare Left Step iff_stepl. Declare Right Step iff_trans. -Local Notation "'rew' 'dependent' H 'in' H'" - := (match H with - | eq_refl => H' - end) - (at level 10, H' at level 10, - format "'[' 'rew' 'dependent' '/ ' H in '/' H' ']'"). - (** Equality for [ex] *) Section ex. Local Unset Implicit Arguments. diff --git a/theories/Reals/RList.v b/theories/Reals/RList.v index 128543d8ab..18cc3aa034 100644 --- a/theories/Reals/RList.v +++ b/theories/Reals/RList.v @@ -8,98 +8,90 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +Require Import List. Require Import Rbase. Require Import Rfunctions. Local Open Scope R_scope. -Inductive Rlist : Type := -| nil : Rlist -| cons : R -> Rlist -> Rlist. -Fixpoint In (x:R) (l:Rlist) : Prop := - match l with - | nil => False - | cons a l' => x = a \/ In x l' - end. +#[deprecated(since="8.12",note="use (list R) instead")] +Notation Rlist := (list R). -Fixpoint Rlength (l:Rlist) : nat := - match l with - | nil => 0%nat - | cons a l' => S (Rlength l') - end. +#[deprecated(since="8.12",note="use List.length instead")] +Notation Rlength := List.length. -Fixpoint MaxRlist (l:Rlist) : R := +Fixpoint MaxRlist (l:list R) : R := match l with | nil => 0 - | cons a l1 => + | a :: l1 => match l1 with | nil => a - | cons a' l2 => Rmax a (MaxRlist l1) + | a' :: l2 => Rmax a (MaxRlist l1) end end. -Fixpoint MinRlist (l:Rlist) : R := +Fixpoint MinRlist (l:list R) : R := match l with | nil => 1 - | cons a l1 => + | a :: l1 => match l1 with | nil => a - | cons a' l2 => Rmin a (MinRlist l1) + | a' :: l2 => Rmin a (MinRlist l1) end end. -Lemma MaxRlist_P1 : forall (l:Rlist) (x:R), In x l -> x <= MaxRlist l. +Lemma MaxRlist_P1 : forall (l:list R) (x:R), In x l -> x <= MaxRlist l. Proof. intros; induction l as [| r l Hrecl]. simpl in H; elim H. induction l as [| r0 l Hrecl0]. simpl in H; elim H; intro. - simpl; right; assumption. + simpl; right; symmetry; assumption. elim H0. - replace (MaxRlist (cons r (cons r0 l))) with (Rmax r (MaxRlist (cons r0 l))). + replace (MaxRlist (r :: r0 :: l)) with (Rmax r (MaxRlist (r0 :: l))). simpl in H; decompose [or] H. rewrite H0; apply RmaxLess1. - unfold Rmax; case (Rle_dec r (MaxRlist (cons r0 l))); intro. + unfold Rmax; case (Rle_dec r (MaxRlist (r0 :: l))); intro. apply Hrecl; simpl; tauto. - apply Rle_trans with (MaxRlist (cons r0 l)); + apply Rle_trans with (MaxRlist (r0 :: l)); [ apply Hrecl; simpl; tauto | left; auto with real ]. - unfold Rmax; case (Rle_dec r (MaxRlist (cons r0 l))); intro. + unfold Rmax; case (Rle_dec r (MaxRlist (r0 :: l))); intro. apply Hrecl; simpl; tauto. - apply Rle_trans with (MaxRlist (cons r0 l)); + apply Rle_trans with (MaxRlist (r0 :: l)); [ apply Hrecl; simpl; tauto | left; auto with real ]. reflexivity. Qed. -Fixpoint AbsList (l:Rlist) (x:R) : Rlist := +Fixpoint AbsList (l:list R) (x:R) : list R := match l with | nil => nil - | cons a l' => cons (Rabs (a - x) / 2) (AbsList l' x) + | a :: l' => (Rabs (a - x) / 2) :: (AbsList l' x) end. -Lemma MinRlist_P1 : forall (l:Rlist) (x:R), In x l -> MinRlist l <= x. +Lemma MinRlist_P1 : forall (l:list R) (x:R), In x l -> MinRlist l <= x. Proof. intros; induction l as [| r l Hrecl]. simpl in H; elim H. induction l as [| r0 l Hrecl0]. simpl in H; elim H; intro. - simpl; right; symmetry ; assumption. + simpl; right; assumption. elim H0. - replace (MinRlist (cons r (cons r0 l))) with (Rmin r (MinRlist (cons r0 l))). + replace (MinRlist (r :: r0 :: l)) with (Rmin r (MinRlist (r0 :: l))). simpl in H; decompose [or] H. rewrite H0; apply Rmin_l. - unfold Rmin; case (Rle_dec r (MinRlist (cons r0 l))); intro. - apply Rle_trans with (MinRlist (cons r0 l)). + unfold Rmin; case (Rle_dec r (MinRlist (r0 :: l))); intro. + apply Rle_trans with (MinRlist (r0 :: l)). assumption. apply Hrecl; simpl; tauto. apply Hrecl; simpl; tauto. - apply Rle_trans with (MinRlist (cons r0 l)). + apply Rle_trans with (MinRlist (r0 :: l)). apply Rmin_r. apply Hrecl; simpl; tauto. reflexivity. Qed. Lemma AbsList_P1 : - forall (l:Rlist) (x y:R), In y l -> In (Rabs (y - x) / 2) (AbsList l x). + forall (l:list R) (x y:R), In y l -> In (Rabs (y - x) / 2) (AbsList l x). Proof. intros; induction l as [| r l Hrecl]. elim H. @@ -109,21 +101,21 @@ Proof. Qed. Lemma MinRlist_P2 : - forall l:Rlist, (forall y:R, In y l -> 0 < y) -> 0 < MinRlist l. + forall l:list R, (forall y:R, In y l -> 0 < y) -> 0 < MinRlist l. Proof. intros; induction l as [| r l Hrecl]. apply Rlt_0_1. induction l as [| r0 l Hrecl0]. simpl; apply H; simpl; tauto. - replace (MinRlist (cons r (cons r0 l))) with (Rmin r (MinRlist (cons r0 l))). - unfold Rmin; case (Rle_dec r (MinRlist (cons r0 l))); intro. + replace (MinRlist (r :: r0 :: l)) with (Rmin r (MinRlist (r0 :: l))). + unfold Rmin; case (Rle_dec r (MinRlist (r0 :: l))); intro. apply H; simpl; tauto. apply Hrecl; intros; apply H; simpl; simpl in H0; tauto. reflexivity. Qed. Lemma AbsList_P2 : - forall (l:Rlist) (x y:R), + forall (l:list R) (x y:R), In y (AbsList l x) -> exists z : R, In z l /\ y = Rabs (z - x) / 2. Proof. intros; induction l as [| r l Hrecl]. @@ -131,47 +123,48 @@ Proof. elim H; intro. exists r; split. simpl; tauto. + symmetry. assumption. assert (H1 := Hrecl H0); elim H1; intros; elim H2; clear H2; intros; exists x0; simpl; simpl in H2; tauto. Qed. Lemma MaxRlist_P2 : - forall l:Rlist, (exists y : R, In y l) -> In (MaxRlist l) l. + forall l:list R, (exists y : R, In y l) -> In (MaxRlist l) l. Proof. intros; induction l as [| r l Hrecl]. simpl in H; elim H; trivial. induction l as [| r0 l Hrecl0]. simpl; left; reflexivity. - change (In (Rmax r (MaxRlist (cons r0 l))) (cons r (cons r0 l))); - unfold Rmax; case (Rle_dec r (MaxRlist (cons r0 l))); + change (In (Rmax r (MaxRlist (r0 :: l))) (r :: r0 :: l)); + unfold Rmax; case (Rle_dec r (MaxRlist (r0 :: l))); intro. right; apply Hrecl; exists r0; left; reflexivity. left; reflexivity. Qed. -Fixpoint pos_Rl (l:Rlist) (i:nat) : R := +Fixpoint pos_Rl (l:list R) (i:nat) : R := match l with | nil => 0 - | cons a l' => match i with + | a :: l' => match i with | O => a | S i' => pos_Rl l' i' end end. Lemma pos_Rl_P1 : - forall (l:Rlist) (a:R), - (0 < Rlength l)%nat -> - pos_Rl (cons a l) (Rlength l) = pos_Rl l (pred (Rlength l)). + forall (l:list R) (a:R), + (0 < length l)%nat -> + pos_Rl (a :: l) (length l) = pos_Rl l (pred (length l)). Proof. intros; induction l as [| r l Hrecl]; [ elim (lt_n_O _ H) - | simpl; case (Rlength l); [ reflexivity | intro; reflexivity ] ]. + | simpl; case (length l); [ reflexivity | intro; reflexivity ] ]. Qed. Lemma pos_Rl_P2 : - forall (l:Rlist) (x:R), - In x l <-> (exists i : nat, (i < Rlength l)%nat /\ x = pos_Rl l i). + forall (l:list R) (x:R), + In x l <-> (exists i : nat, (i < length l)%nat /\ x = pos_Rl l i). Proof. intros; induction l as [| r l Hrecl]. split; intro; @@ -179,12 +172,12 @@ Proof. split; intro. elim H; intro. exists 0%nat; split; - [ simpl; apply lt_O_Sn | simpl; apply H0 ]. + [ simpl; apply lt_O_Sn | simpl; symmetry; apply H0 ]. elim Hrecl; intros; assert (H3 := H1 H0); elim H3; intros; elim H4; intros; exists (S x0); split; [ simpl; apply lt_n_S; assumption | simpl; assumption ]. elim H; intros; elim H0; intros; destruct (zerop x0) as [->|]. - simpl in H2; left; assumption. + simpl in H2; left; symmetry; assumption. right; elim Hrecl; intros H4 H5; apply H5; assert (H6 : S (pred x0) = x0). symmetry ; apply S_pred with 0%nat; assumption. exists (pred x0); split; @@ -193,21 +186,21 @@ Proof. Qed. Lemma Rlist_P1 : - forall (l:Rlist) (P:R -> R -> Prop), + forall (l:list R) (P:R -> R -> Prop), (forall x:R, In x l -> exists y : R, P x y) -> - exists l' : Rlist, - Rlength l = Rlength l' /\ - (forall i:nat, (i < Rlength l)%nat -> P (pos_Rl l i) (pos_Rl l' i)). + exists l' : list R, + length l = length l' /\ + (forall i:nat, (i < length l)%nat -> P (pos_Rl l i) (pos_Rl l' i)). Proof. intros; induction l as [| r l Hrecl]. exists nil; intros; split; [ reflexivity | intros; simpl in H0; elim (lt_n_O _ H0) ]. - assert (H0 : In r (cons r l)). + assert (H0 : In r (r :: l)). simpl; left; reflexivity. assert (H1 := H _ H0); assert (H2 : forall x:R, In x l -> exists y : R, P x y). intros; apply H; simpl; right; assumption. - assert (H3 := Hrecl H2); elim H1; intros; elim H3; intros; exists (cons x x0); + assert (H3 := Hrecl H2); elim H1; intros; elim H3; intros; exists (x :: x0); intros; elim H5; clear H5; intros; split. simpl; rewrite H5; reflexivity. intros; destruct (zerop i) as [->|]. @@ -218,57 +211,45 @@ Proof. assumption. Qed. -Definition ordered_Rlist (l:Rlist) : Prop := - forall i:nat, (i < pred (Rlength l))%nat -> pos_Rl l i <= pos_Rl l (S i). +Definition ordered_Rlist (l:list R) : Prop := + forall i:nat, (i < pred (length l))%nat -> pos_Rl l i <= pos_Rl l (S i). -Fixpoint insert (l:Rlist) (x:R) : Rlist := +Fixpoint insert (l:list R) (x:R) : list R := match l with - | nil => cons x nil - | cons a l' => + | nil => x :: nil + | a :: l' => match Rle_dec a x with - | left _ => cons a (insert l' x) - | right _ => cons x l + | left _ => a :: (insert l' x) + | right _ => x :: l end end. -Fixpoint cons_Rlist (l k:Rlist) : Rlist := - match l with - | nil => k - | cons a l' => cons a (cons_Rlist l' k) - end. - -Fixpoint cons_ORlist (k l:Rlist) : Rlist := +Fixpoint cons_ORlist (k l:list R) : list R := match k with | nil => l - | cons a k' => cons_ORlist k' (insert l a) + | a :: k' => cons_ORlist k' (insert l a) end. -Fixpoint app_Rlist (l:Rlist) (f:R -> R) : Rlist := +Fixpoint mid_Rlist (l:list R) (x:R) : list R := match l with | nil => nil - | cons a l' => cons (f a) (app_Rlist l' f) + | a :: l' => ((x + a) / 2) :: (mid_Rlist l' a) end. -Fixpoint mid_Rlist (l:Rlist) (x:R) : Rlist := +Definition Rtail (l:list R) : list R := match l with | nil => nil - | cons a l' => cons ((x + a) / 2) (mid_Rlist l' a) + | a :: l' => l' end. -Definition Rtail (l:Rlist) : Rlist := +Definition FF (l:list R) (f:R -> R) : list R := match l with | nil => nil - | cons a l' => l' - end. - -Definition FF (l:Rlist) (f:R -> R) : Rlist := - match l with - | nil => nil - | cons a l' => app_Rlist (mid_Rlist l' a) f + | a :: l' => map f (mid_Rlist l' a) end. Lemma RList_P0 : - forall (l:Rlist) (a:R), + forall (l:list R) (a:R), pos_Rl (insert l a) 0 = a \/ pos_Rl (insert l a) 0 = pos_Rl l 0. Proof. intros; induction l as [| r l Hrecl]; @@ -278,7 +259,7 @@ Proof. Qed. Lemma RList_P1 : - forall (l:Rlist) (a:R), ordered_Rlist l -> ordered_Rlist (insert l a). + forall (l:list R) (a:R), ordered_Rlist l -> ordered_Rlist (insert l a). Proof. intros; induction l as [| r l Hrecl]. simpl; unfold ordered_Rlist; intros; simpl in H0; @@ -286,8 +267,8 @@ Proof. simpl; case (Rle_dec r a); intro. assert (H1 : ordered_Rlist l). unfold ordered_Rlist; unfold ordered_Rlist in H; intros; - assert (H1 : (S i < pred (Rlength (cons r l)))%nat); - [ simpl; replace (Rlength l) with (S (pred (Rlength l))); + assert (H1 : (S i < pred (length (r :: l)))%nat); + [ simpl; replace (length l) with (S (pred (length l))); [ apply lt_n_S; assumption | symmetry ; apply S_pred with 0%nat; apply neq_O_lt; red; intro; rewrite <- H1 in H0; simpl in H0; elim (lt_n_O _ H0) ] @@ -300,18 +281,18 @@ Proof. [ simpl; assumption | rewrite H4; apply (H 0%nat); simpl; apply lt_O_Sn ]. simpl; apply H2; simpl in H0; apply lt_S_n; - replace (S (pred (Rlength (insert l a)))) with (Rlength (insert l a)); + replace (S (pred (length (insert l a)))) with (length (insert l a)); [ assumption | apply S_pred with 0%nat; apply neq_O_lt; red; intro; rewrite <- H3 in H0; elim (lt_n_O _ H0) ]. unfold ordered_Rlist; intros; induction i as [| i Hreci]; [ simpl; auto with real - | change (pos_Rl (cons r l) i <= pos_Rl (cons r l) (S i)); apply H; + | change (pos_Rl (r :: l) i <= pos_Rl (r :: l) (S i)); apply H; simpl in H0; simpl; apply (lt_S_n _ _ H0) ]. Qed. Lemma RList_P2 : - forall l1 l2:Rlist, ordered_Rlist l2 -> ordered_Rlist (cons_ORlist l1 l2). + forall l1 l2:list R, ordered_Rlist l2 -> ordered_Rlist (cons_ORlist l1 l2). Proof. simple induction l1; [ intros; simpl; apply H @@ -319,36 +300,36 @@ Proof. Qed. Lemma RList_P3 : - forall (l:Rlist) (x:R), - In x l <-> (exists i : nat, x = pos_Rl l i /\ (i < Rlength l)%nat). + forall (l:list R) (x:R), + In x l <-> (exists i : nat, x = pos_Rl l i /\ (i < length l)%nat). Proof. intros; split; intro; [ induction l as [| r l Hrecl] | induction l as [| r l Hrecl] ]. elim H. elim H; intro; - [ exists 0%nat; split; [ apply H0 | simpl; apply lt_O_Sn ] + [ exists 0%nat; split; [ symmetry; apply H0 | simpl; apply lt_O_Sn ] | elim (Hrecl H0); intros; elim H1; clear H1; intros; exists (S x0); split; [ apply H1 | simpl; apply lt_n_S; assumption ] ]. elim H; intros; elim H0; intros; elim (lt_n_O _ H2). simpl; elim H; intros; elim H0; clear H0; intros; induction x0 as [| x0 Hrecx0]; - [ left; apply H0 + [ left; symmetry; apply H0 | right; apply Hrecl; exists x0; split; [ apply H0 | simpl in H1; apply lt_S_n; assumption ] ]. Qed. Lemma RList_P4 : - forall (l1:Rlist) (a:R), ordered_Rlist (cons a l1) -> ordered_Rlist l1. + forall (l1:list R) (a:R), ordered_Rlist (a :: l1) -> ordered_Rlist l1. Proof. intros; unfold ordered_Rlist; intros; apply (H (S i)); simpl; - replace (Rlength l1) with (S (pred (Rlength l1))); + replace (length l1) with (S (pred (length l1))); [ apply lt_n_S; assumption | symmetry ; apply S_pred with 0%nat; apply neq_O_lt; red; intro; rewrite <- H1 in H0; elim (lt_n_O _ H0) ]. Qed. Lemma RList_P5 : - forall (l:Rlist) (x:R), ordered_Rlist l -> In x l -> pos_Rl l 0 <= x. + forall (l:list R) (x:R), ordered_Rlist l -> In x l -> pos_Rl l 0 <= x. Proof. intros; induction l as [| r l Hrecl]; [ elim H0 @@ -361,14 +342,14 @@ Proof. Qed. Lemma RList_P6 : - forall l:Rlist, + forall l:list R, ordered_Rlist l <-> (forall i j:nat, - (i <= j)%nat -> (j < Rlength l)%nat -> pos_Rl l i <= pos_Rl l j). + (i <= j)%nat -> (j < length l)%nat -> pos_Rl l i <= pos_Rl l j). Proof. - simple induction l; split; intro. + induction l as [ | r r0 H]; split; intro. intros; right; reflexivity. - unfold ordered_Rlist; intros; simpl in H0; elim (lt_n_O _ H0). + unfold ordered_Rlist;intros; simpl in H0; elim (lt_n_O _ H0). intros; induction i as [| i Hreci]; [ induction j as [| j Hrecj]; [ right; reflexivity @@ -391,14 +372,14 @@ Proof. Qed. Lemma RList_P7 : - forall (l:Rlist) (x:R), - ordered_Rlist l -> In x l -> x <= pos_Rl l (pred (Rlength l)). + forall (l:list R) (x:R), + ordered_Rlist l -> In x l -> x <= pos_Rl l (pred (length l)). Proof. intros; assert (H1 := RList_P6 l); elim H1; intros H2 _; assert (H3 := H2 H); clear H1 H2; assert (H1 := RList_P3 l x); elim H1; clear H1; intros; assert (H4 := H1 H0); elim H4; clear H4; intros; elim H4; clear H4; intros; rewrite H4; - assert (H6 : Rlength l = S (pred (Rlength l))). + assert (H6 : length l = S (pred (length l))). apply S_pred with 0%nat; apply neq_O_lt; red; intro; rewrite <- H6 in H5; elim (lt_n_O _ H5). apply H3; @@ -408,52 +389,55 @@ Proof. Qed. Lemma RList_P8 : - forall (l:Rlist) (a x:R), In x (insert l a) <-> x = a \/ In x l. -Proof. - simple induction l. - intros; split; intro; simpl in H; apply H. - intros; split; intro; - [ simpl in H0; generalize H0; case (Rle_dec r a); intros; - [ simpl in H1; elim H1; intro; - [ right; left; assumption - | elim (H a x); intros; elim (H3 H2); intro; - [ left; assumption | right; right; assumption ] ] - | simpl in H1; decompose [or] H1; - [ left; assumption - | right; left; assumption - | right; right; assumption ] ] - | simpl; case (Rle_dec r a); intro; - [ simpl in H0; decompose [or] H0; - [ right; elim (H a x); intros; apply H3; left - | left - | right; elim (H a x); intros; apply H3; right ] - | simpl in H0; decompose [or] H0; [ left | right; left | right; right ] ]; - assumption ]. + forall (l:list R) (a x:R), In x (insert l a) <-> x = a \/ In x l. +Proof. + induction l as [ | r r0 H]. + intros; split; intro; destruct H as [ax | []]; left; symmetry; exact ax. + intros; split; intro. + simpl in H0; generalize H0; case (Rle_dec r a); intros. + simpl in H1; elim H1; intro. + right; left; assumption. + elim (H a x); intros; elim (H3 H2); intro. + left; assumption. + right; right; assumption. + simpl in H1; decompose [or] H1. + left; symmetry; assumption. + right; left; assumption. + right; right; assumption. + simpl; case (Rle_dec r a); intro. + simpl in H0; decompose [or] H0. + right; elim (H a x); intros; apply H3; left. assumption. + left. assumption. + right; elim (H a x); intros; apply H3; right; assumption. + simpl in H0; decompose [or] H0; [ left | right; left | right; right]; + trivial; symmetry; assumption. Qed. Lemma RList_P9 : - forall (l1 l2:Rlist) (x:R), In x (cons_ORlist l1 l2) <-> In x l1 \/ In x l2. + forall (l1 l2:list R) (x:R), In x (cons_ORlist l1 l2) <-> In x l1 \/ In x l2. Proof. - simple induction l1. + induction l1 as [ | r r0 H]. intros; split; intro; [ simpl in H; right; assumption | simpl; elim H; intro; [ elim H0 | assumption ] ]. intros; split. simpl; intros; elim (H (insert l2 r) x); intros; assert (H3 := H1 H0); - elim H3; intro; - [ left; right; assumption - | elim (RList_P8 l2 r x); intros H5 _; assert (H6 := H5 H4); elim H6; intro; - [ left; left; assumption | right; assumption ] ]. + elim H3; intro. + left; right; assumption. + elim (RList_P8 l2 r x); intros H5 _; assert (H6 := H5 H4); elim H6; intro. + left; left; symmetry; assumption. + right; assumption. intro; simpl; elim (H (insert l2 r) x); intros _ H1; apply H1; - elim H0; intro; - [ elim H2; intro; - [ right; elim (RList_P8 l2 r x); intros _ H4; apply H4; left; assumption - | left; assumption ] - | right; elim (RList_P8 l2 r x); intros _ H3; apply H3; right; assumption ]. + elim H0; intro. + elim H2; intro. + right; elim (RList_P8 l2 r x); intros _ H4; apply H4; left. + symmetry; assumption. + left; assumption. + right; elim (RList_P8 l2 r x); intros _ H3; apply H3; right; assumption. Qed. Lemma RList_P10 : - forall (l:Rlist) (a:R), Rlength (insert l a) = S (Rlength l). + forall (l:list R) (a:R), length (insert l a) = S (length l). Proof. intros; induction l as [| r l Hrecl]; [ reflexivity @@ -462,10 +446,10 @@ Proof. Qed. Lemma RList_P11 : - forall l1 l2:Rlist, - Rlength (cons_ORlist l1 l2) = (Rlength l1 + Rlength l2)%nat. + forall l1 l2:list R, + length (cons_ORlist l1 l2) = (length l1 + length l2)%nat. Proof. - simple induction l1; + induction l1 as [ | r r0 H]; [ intro; reflexivity | intros; simpl; rewrite (H (insert l2 r)); rewrite RList_P10; apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; @@ -473,8 +457,8 @@ Proof. Qed. Lemma RList_P12 : - forall (l:Rlist) (i:nat) (f:R -> R), - (i < Rlength l)%nat -> pos_Rl (app_Rlist l f) i = f (pos_Rl l i). + forall (l:list R) (i:nat) (f:R -> R), + (i < length l)%nat -> pos_Rl (map f l) i = f (pos_Rl l i). Proof. simple induction l; [ intros; elim (lt_n_O _ H) @@ -483,30 +467,30 @@ Proof. Qed. Lemma RList_P13 : - forall (l:Rlist) (i:nat) (a:R), - (i < pred (Rlength l))%nat -> + forall (l:list R) (i:nat) (a:R), + (i < pred (length l))%nat -> pos_Rl (mid_Rlist l a) (S i) = (pos_Rl l i + pos_Rl l (S i)) / 2. Proof. - simple induction l. + induction l as [ | r r0 H]. intros; simpl in H; elim (lt_n_O _ H). - simple induction r0. + induction r0 as [ | r1 r2 H0]. intros; simpl in H0; elim (lt_n_O _ H0). intros; simpl in H1; induction i as [| i Hreci]. reflexivity. change - (pos_Rl (mid_Rlist (cons r1 r2) r) (S i) = - (pos_Rl (cons r1 r2) i + pos_Rl (cons r1 r2) (S i)) / 2) - ; apply H0; simpl; apply lt_S_n; assumption. + (pos_Rl (mid_Rlist (r1 :: r2) r) (S i) = + (pos_Rl (r1 :: r2) i + pos_Rl (r1 :: r2) (S i)) / 2). + apply H; simpl; apply lt_S_n; assumption. Qed. -Lemma RList_P14 : forall (l:Rlist) (a:R), Rlength (mid_Rlist l a) = Rlength l. +Lemma RList_P14 : forall (l:list R) (a:R), length (mid_Rlist l a) = length l. Proof. - simple induction l; intros; + induction l as [ | r r0 H]; intros; [ reflexivity | simpl; rewrite (H r); reflexivity ]. Qed. Lemma RList_P15 : - forall l1 l2:Rlist, + forall l1 l2:list R, ordered_Rlist l1 -> ordered_Rlist l2 -> pos_Rl l1 0 = pos_Rl l2 0 -> pos_Rl (cons_ORlist l1 l2) 0 = pos_Rl l1 0. @@ -514,10 +498,10 @@ Proof. intros; apply Rle_antisym. induction l1 as [| r l1 Hrecl1]; [ simpl; simpl in H1; right; symmetry ; assumption - | elim (RList_P9 (cons r l1) l2 (pos_Rl (cons r l1) 0)); intros; + | elim (RList_P9 (r :: l1) l2 (pos_Rl (r :: l1) 0)); intros; assert (H4 : - In (pos_Rl (cons r l1) 0) (cons r l1) \/ In (pos_Rl (cons r l1) 0) l2); + In (pos_Rl (r :: l1) 0) (r :: l1) \/ In (pos_Rl (r :: l1) 0) l2); [ left; left; reflexivity | assert (H5 := H3 H4); apply RList_P5; [ apply RList_P2; assumption | assumption ] ] ]. @@ -525,25 +509,25 @@ Proof. [ simpl; simpl in H1; right; assumption | assert (H2 : - In (pos_Rl (cons_ORlist (cons r l1) l2) 0) (cons_ORlist (cons r l1) l2)); + In (pos_Rl (cons_ORlist (r :: l1) l2) 0) (cons_ORlist (r :: l1) l2)); [ elim - (RList_P3 (cons_ORlist (cons r l1) l2) - (pos_Rl (cons_ORlist (cons r l1) l2) 0)); + (RList_P3 (cons_ORlist (r :: l1) l2) + (pos_Rl (cons_ORlist (r :: l1) l2) 0)); intros; apply H3; exists 0%nat; split; [ reflexivity | rewrite RList_P11; simpl; apply lt_O_Sn ] - | elim (RList_P9 (cons r l1) l2 (pos_Rl (cons_ORlist (cons r l1) l2) 0)); + | elim (RList_P9 (r :: l1) l2 (pos_Rl (cons_ORlist (r :: l1) l2) 0)); intros; assert (H5 := H3 H2); elim H5; intro; [ apply RList_P5; assumption | rewrite H1; apply RList_P5; assumption ] ] ]. Qed. Lemma RList_P16 : - forall l1 l2:Rlist, + forall l1 l2:list R, ordered_Rlist l1 -> ordered_Rlist l2 -> - pos_Rl l1 (pred (Rlength l1)) = pos_Rl l2 (pred (Rlength l2)) -> - pos_Rl (cons_ORlist l1 l2) (pred (Rlength (cons_ORlist l1 l2))) = - pos_Rl l1 (pred (Rlength l1)). + pos_Rl l1 (pred (length l1)) = pos_Rl l2 (pred (length l2)) -> + pos_Rl (cons_ORlist l1 l2) (pred (length (cons_ORlist l1 l2))) = + pos_Rl l1 (pred (length l1)). Proof. intros; apply Rle_antisym. induction l1 as [| r l1 Hrecl1]. @@ -551,99 +535,99 @@ Proof. assert (H2 : In - (pos_Rl (cons_ORlist (cons r l1) l2) - (pred (Rlength (cons_ORlist (cons r l1) l2)))) - (cons_ORlist (cons r l1) l2)); + (pos_Rl (cons_ORlist (r :: l1) l2) + (pred (length (cons_ORlist (r :: l1) l2)))) + (cons_ORlist (r :: l1) l2)); [ elim - (RList_P3 (cons_ORlist (cons r l1) l2) - (pos_Rl (cons_ORlist (cons r l1) l2) - (pred (Rlength (cons_ORlist (cons r l1) l2))))); - intros; apply H3; exists (pred (Rlength (cons_ORlist (cons r l1) l2))); + (RList_P3 (cons_ORlist (r :: l1) l2) + (pos_Rl (cons_ORlist (r :: l1) l2) + (pred (length (cons_ORlist (r :: l1) l2))))); + intros; apply H3; exists (pred (length (cons_ORlist (r :: l1) l2))); split; [ reflexivity | rewrite RList_P11; simpl; apply lt_n_Sn ] | elim - (RList_P9 (cons r l1) l2 - (pos_Rl (cons_ORlist (cons r l1) l2) - (pred (Rlength (cons_ORlist (cons r l1) l2))))); + (RList_P9 (r :: l1) l2 + (pos_Rl (cons_ORlist (r :: l1) l2) + (pred (length (cons_ORlist (r :: l1) l2))))); intros; assert (H5 := H3 H2); elim H5; intro; [ apply RList_P7; assumption | rewrite H1; apply RList_P7; assumption ] ]. induction l1 as [| r l1 Hrecl1]. simpl; simpl in H1; right; assumption. elim - (RList_P9 (cons r l1) l2 (pos_Rl (cons r l1) (pred (Rlength (cons r l1))))); + (RList_P9 (r :: l1) l2 (pos_Rl (r :: l1) (pred (length (r :: l1))))). intros; assert (H4 : - In (pos_Rl (cons r l1) (pred (Rlength (cons r l1)))) (cons r l1) \/ - In (pos_Rl (cons r l1) (pred (Rlength (cons r l1)))) l2); - [ left; change (In (pos_Rl (cons r l1) (Rlength l1)) (cons r l1)); - elim (RList_P3 (cons r l1) (pos_Rl (cons r l1) (Rlength l1))); - intros; apply H5; exists (Rlength l1); split; + In (pos_Rl (r :: l1) (pred (length (r :: l1)))) (r :: l1) \/ + In (pos_Rl (r :: l1) (pred (length (r :: l1)))) l2); + [ left; change (In (pos_Rl (r :: l1) (length l1)) (r :: l1)); + elim (RList_P3 (r :: l1) (pos_Rl (r :: l1) (length l1))); + intros; apply H5; exists (length l1); split; [ reflexivity | simpl; apply lt_n_Sn ] | assert (H5 := H3 H4); apply RList_P7; [ apply RList_P2; assumption | elim - (RList_P9 (cons r l1) l2 - (pos_Rl (cons r l1) (pred (Rlength (cons r l1))))); + (RList_P9 (r :: l1) l2 + (pos_Rl (r :: l1) (pred (length (r :: l1))))); intros; apply H7; left; elim - (RList_P3 (cons r l1) - (pos_Rl (cons r l1) (pred (Rlength (cons r l1))))); - intros; apply H9; exists (pred (Rlength (cons r l1))); + (RList_P3 (r :: l1) + (pos_Rl (r :: l1) (pred (length (r :: l1))))); + intros; apply H9; exists (pred (length (r :: l1))); split; [ reflexivity | simpl; apply lt_n_Sn ] ] ]. Qed. Lemma RList_P17 : - forall (l1:Rlist) (x:R) (i:nat), + forall (l1:list R) (x:R) (i:nat), ordered_Rlist l1 -> In x l1 -> - pos_Rl l1 i < x -> (i < pred (Rlength l1))%nat -> pos_Rl l1 (S i) <= x. + pos_Rl l1 i < x -> (i < pred (length l1))%nat -> pos_Rl l1 (S i) <= x. Proof. - simple induction l1. + induction l1 as [ | r r0 H]. intros; elim H0. intros; induction i as [| i Hreci]. simpl; elim H1; intro; [ simpl in H2; rewrite H4 in H2; elim (Rlt_irrefl _ H2) | apply RList_P5; [ apply RList_P4 with r; assumption | assumption ] ]. simpl; simpl in H2; elim H1; intro. - rewrite H4 in H2; assert (H5 : r <= pos_Rl r0 i); + rewrite <- H4 in H2; assert (H5 : r <= pos_Rl r0 i); [ apply Rle_trans with (pos_Rl r0 0); [ apply (H0 0%nat); simpl; simpl in H3; apply neq_O_lt; red; intro; rewrite <- H5 in H3; elim (lt_n_O _ H3) | elim (RList_P6 r0); intros; apply H5; [ apply RList_P4 with r; assumption | apply le_O_n - | simpl in H3; apply lt_S_n; apply lt_trans with (Rlength r0); + | simpl in H3; apply lt_S_n; apply lt_trans with (length r0); [ apply H3 | apply lt_n_Sn ] ] ] | elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H5 H2)) ]. apply H; try assumption; [ apply RList_P4 with r; assumption | simpl in H3; apply lt_S_n; - replace (S (pred (Rlength r0))) with (Rlength r0); + replace (S (pred (length r0))) with (length r0); [ apply H3 | apply S_pred with 0%nat; apply neq_O_lt; red; intro; rewrite <- H5 in H3; elim (lt_n_O _ H3) ] ]. Qed. Lemma RList_P18 : - forall (l:Rlist) (f:R -> R), Rlength (app_Rlist l f) = Rlength l. + forall (l:list R) (f:R -> R), length (map f l) = length l. Proof. simple induction l; intros; [ reflexivity | simpl; rewrite H; reflexivity ]. Qed. Lemma RList_P19 : - forall l:Rlist, - l <> nil -> exists r : R, (exists r0 : Rlist, l = cons r r0). + forall l:list R, + l <> nil -> exists r : R, (exists r0 : list R, l = r :: r0). Proof. intros; induction l as [| r l Hrecl]; [ elim H; reflexivity | exists r; exists l; reflexivity ]. Qed. Lemma RList_P20 : - forall l:Rlist, - (2 <= Rlength l)%nat -> + forall l:list R, + (2 <= length l)%nat -> exists r : R, - (exists r1 : R, (exists l' : Rlist, l = cons r (cons r1 l'))). + (exists r1 : R, (exists l' : list R, l = r :: r1 :: l')). Proof. intros; induction l as [| r l Hrecl]; [ simpl in H; elim (le_Sn_O _ H) @@ -652,40 +636,32 @@ Proof. | exists r; exists r0; exists l; reflexivity ] ]. Qed. -Lemma RList_P21 : forall l l':Rlist, l = l' -> Rtail l = Rtail l'. +Lemma RList_P21 : forall l l':list R, l = l' -> Rtail l = Rtail l'. Proof. intros; rewrite H; reflexivity. Qed. Lemma RList_P22 : - forall l1 l2:Rlist, l1 <> nil -> pos_Rl (cons_Rlist l1 l2) 0 = pos_Rl l1 0. + forall l1 l2:list R, l1 <> nil -> pos_Rl (app l1 l2) 0 = pos_Rl l1 0. Proof. simple induction l1; [ intros; elim H; reflexivity | intros; reflexivity ]. Qed. -Lemma RList_P23 : - forall l1 l2:Rlist, - Rlength (cons_Rlist l1 l2) = (Rlength l1 + Rlength l2)%nat. -Proof. - simple induction l1; - [ intro; reflexivity | intros; simpl; rewrite H; reflexivity ]. -Qed. - Lemma RList_P24 : - forall l1 l2:Rlist, + forall l1 l2:list R, l2 <> nil -> - pos_Rl (cons_Rlist l1 l2) (pred (Rlength (cons_Rlist l1 l2))) = - pos_Rl l2 (pred (Rlength l2)). + pos_Rl (app l1 l2) (pred (length (app l1 l2))) = + pos_Rl l2 (pred (length l2)). Proof. - simple induction l1. + induction l1 as [ | r r0 H]. intros; reflexivity. intros; rewrite <- (H l2 H0); induction l2 as [| r1 l2 Hrecl2]. elim H0; reflexivity. - do 2 rewrite RList_P23; - replace (Rlength (cons r r0) + Rlength (cons r1 l2))%nat with - (S (S (Rlength r0 + Rlength l2))); - [ replace (Rlength r0 + Rlength (cons r1 l2))%nat with - (S (Rlength r0 + Rlength l2)); + do 2 rewrite app_length; + replace (length (r :: r0) + length (r1 :: l2))%nat with + (S (S (length r0 + length l2))); + [ replace (length r0 + length (r1 :: l2))%nat with + (S (length r0 + length l2)); [ reflexivity | simpl; apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; rewrite S_INR; ring ] @@ -694,39 +670,39 @@ Proof. Qed. Lemma RList_P25 : - forall l1 l2:Rlist, + forall l1 l2:list R, ordered_Rlist l1 -> ordered_Rlist l2 -> - pos_Rl l1 (pred (Rlength l1)) <= pos_Rl l2 0 -> - ordered_Rlist (cons_Rlist l1 l2). + pos_Rl l1 (pred (length l1)) <= pos_Rl l2 0 -> + ordered_Rlist (app l1 l2). Proof. - simple induction l1. + induction l1 as [ | r r0 H]. intros; simpl; assumption. - simple induction r0. + induction r0 as [ | r1 r2 H0]. intros; simpl; simpl in H2; unfold ordered_Rlist; intros; simpl in H3. induction i as [| i Hreci]. simpl; assumption. change (pos_Rl l2 i <= pos_Rl l2 (S i)); apply (H1 i); apply lt_S_n; - replace (S (pred (Rlength l2))) with (Rlength l2); + replace (S (pred (length l2))) with (length l2); [ assumption | apply S_pred with 0%nat; apply neq_O_lt; red; intro; rewrite <- H4 in H3; elim (lt_n_O _ H3) ]. - intros; clear H; assert (H : ordered_Rlist (cons_Rlist (cons r1 r2) l2)). - apply H0; try assumption. + intros; assert (H4 : ordered_Rlist (app (r1 :: r2) l2)). + apply H; try assumption. apply RList_P4 with r; assumption. - unfold ordered_Rlist; intros; simpl in H4; + unfold ordered_Rlist; intros i H5; simpl in H5. induction i as [| i Hreci]. simpl; apply (H1 0%nat); simpl; apply lt_O_Sn. change - (pos_Rl (cons_Rlist (cons r1 r2) l2) i <= - pos_Rl (cons_Rlist (cons r1 r2) l2) (S i)); - apply (H i); simpl; apply lt_S_n; assumption. + (pos_Rl (app (r1 :: r2) l2) i <= + pos_Rl (app (r1 :: r2) l2) (S i)); + apply (H4 i); simpl; apply lt_S_n; assumption. Qed. Lemma RList_P26 : - forall (l1 l2:Rlist) (i:nat), - (i < Rlength l1)%nat -> pos_Rl (cons_Rlist l1 l2) i = pos_Rl l1 i. + forall (l1 l2:list R) (i:nat), + (i < length l1)%nat -> pos_Rl (app l1 l2) i = pos_Rl l1 i. Proof. simple induction l1. intros; elim (lt_n_O _ H). @@ -735,49 +711,41 @@ Proof. apply (H l2 i); simpl in H0; apply lt_S_n; assumption. Qed. -Lemma RList_P27 : - forall l1 l2 l3:Rlist, - cons_Rlist l1 (cons_Rlist l2 l3) = cons_Rlist (cons_Rlist l1 l2) l3. -Proof. - simple induction l1; intros; - [ reflexivity | simpl; rewrite (H l2 l3); reflexivity ]. -Qed. - -Lemma RList_P28 : forall l:Rlist, cons_Rlist l nil = l. -Proof. - simple induction l; - [ reflexivity | intros; simpl; rewrite H; reflexivity ]. -Qed. - Lemma RList_P29 : - forall (l2 l1:Rlist) (i:nat), - (Rlength l1 <= i)%nat -> - (i < Rlength (cons_Rlist l1 l2))%nat -> - pos_Rl (cons_Rlist l1 l2) i = pos_Rl l2 (i - Rlength l1). + forall (l2 l1:list R) (i:nat), + (length l1 <= i)%nat -> + (i < length (app l1 l2))%nat -> + pos_Rl (app l1 l2) i = pos_Rl l2 (i - length l1). Proof. - simple induction l2. - intros; rewrite RList_P28 in H0; elim (lt_irrefl _ (le_lt_trans _ _ _ H H0)). + induction l2 as [ | r r0 H]. + intros; rewrite app_nil_r in H0; elim (lt_irrefl _ (le_lt_trans _ _ _ H H0)). intros; - replace (cons_Rlist l1 (cons r r0)) with - (cons_Rlist (cons_Rlist l1 (cons r nil)) r0). + replace (app l1 (r :: r0)) with + (app (app l1 (r :: nil)) r0). inversion H0. rewrite <- minus_n_n; simpl; rewrite RList_P26. - clear l2 r0 H i H0 H1 H2; induction l1 as [| r0 l1 Hrecl1]. + clear r0 H i H0 H1 H2; induction l1 as [| r0 l1 Hrecl1]. reflexivity. simpl; assumption. - rewrite RList_P23; rewrite plus_comm; simpl; apply lt_n_Sn. - replace (S m - Rlength l1)%nat with (S (S m - S (Rlength l1))). + rewrite app_length; rewrite plus_comm; simpl; apply lt_n_Sn. + replace (S m - length l1)%nat with (S (S m - S (length l1))). rewrite H3; simpl; - replace (S (Rlength l1)) with (Rlength (cons_Rlist l1 (cons r nil))). - apply (H (cons_Rlist l1 (cons r nil)) i). - rewrite RList_P23; rewrite plus_comm; simpl; rewrite <- H3; + replace (S (length l1)) with (length (app l1 (r :: nil))). + apply (H (app l1 (r :: nil)) i). + rewrite app_length; rewrite plus_comm; simpl; rewrite <- H3; apply le_n_S; assumption. - repeat rewrite RList_P23; simpl; rewrite RList_P23 in H1; - rewrite plus_comm in H1; simpl in H1; rewrite (plus_comm (Rlength l1)); + repeat rewrite app_length; simpl; rewrite app_length in H1; + rewrite plus_comm in H1; simpl in H1; rewrite (plus_comm (length l1)); simpl; rewrite plus_comm; apply H1. - rewrite RList_P23; rewrite plus_comm; reflexivity. - change (S (m - Rlength l1) = (S m - Rlength l1)%nat); + rewrite app_length; rewrite plus_comm; reflexivity. + change (S (m - length l1) = (S m - length l1)%nat); apply minus_Sn_m; assumption. - replace (cons r r0) with (cons_Rlist (cons r nil) r0); - [ symmetry ; apply RList_P27 | reflexivity ]. + replace (r :: r0) with (app (r :: nil) r0); + [ symmetry ; apply app_assoc | reflexivity ]. Qed. + +#[deprecated(since="8.12",note="use List.cons instead")] +Notation cons := List.cons. + +#[deprecated(since="8.12",note="use List.nil instead")] +Notation nil := List.nil. diff --git a/theories/Reals/RiemannInt.v b/theories/Reals/RiemannInt.v index 0337b12cad..23094c6b93 100644 --- a/theories/Reals/RiemannInt.v +++ b/theories/Reals/RiemannInt.v @@ -464,7 +464,7 @@ Proof. elim (Rlt_irrefl _ H7) ] ]. Qed. -Fixpoint SubEquiN (N:nat) (x y:R) (del:posreal) : Rlist := +Fixpoint SubEquiN (N:nat) (x y:R) (del:posreal) : list R := match N with | O => cons y nil | S p => cons x (SubEquiN p (x + del) y del) @@ -473,7 +473,7 @@ Fixpoint SubEquiN (N:nat) (x y:R) (del:posreal) : Rlist := Definition max_N (a b:R) (del:posreal) (h:a < b) : nat := let (N,_) := maxN del h in N. -Definition SubEqui (a b:R) (del:posreal) (h:a < b) : Rlist := +Definition SubEqui (a b:R) (del:posreal) (h:a < b) : list R := SubEquiN (S (max_N del h)) a b del. Lemma Heine_cor1 : @@ -566,25 +566,25 @@ Qed. Lemma SubEqui_P2 : forall (a b:R) (del:posreal) (h:a < b), - pos_Rl (SubEqui del h) (pred (Rlength (SubEqui del h))) = b. + pos_Rl (SubEqui del h) (pred (length (SubEqui del h))) = b. Proof. intros; unfold SubEqui; destruct (maxN del h)as (x,_). cut (forall (x:nat) (a:R) (del:posreal), pos_Rl (SubEquiN (S x) a b del) - (pred (Rlength (SubEquiN (S x) a b del))) = b); + (pred (length (SubEquiN (S x) a b del))) = b); [ intro; apply H | simple induction x0; [ intros; reflexivity | intros; change (pos_Rl (SubEquiN (S n) (a0 + del0) b del0) - (pred (Rlength (SubEquiN (S n) (a0 + del0) b del0))) = b) + (pred (length (SubEquiN (S n) (a0 + del0) b del0))) = b) ; apply H ] ]. Qed. Lemma SubEqui_P3 : - forall (N:nat) (a b:R) (del:posreal), Rlength (SubEquiN N a b del) = S N. + forall (N:nat) (a b:R) (del:posreal), length (SubEquiN N a b del) = S N. Proof. simple induction N; intros; [ reflexivity | simpl; rewrite H; reflexivity ]. @@ -605,7 +605,7 @@ Qed. Lemma SubEqui_P5 : forall (a b:R) (del:posreal) (h:a < b), - Rlength (SubEqui del h) = S (S (max_N del h)). + length (SubEqui del h) = S (S (max_N del h)). Proof. intros; unfold SubEqui; apply SubEqui_P3. Qed. @@ -623,7 +623,7 @@ Proof. intros; unfold ordered_Rlist; intros; rewrite SubEqui_P5 in H; simpl in H; inversion H. rewrite (SubEqui_P6 del h (i:=(max_N del h))). - replace (S (max_N del h)) with (pred (Rlength (SubEqui del h))). + replace (S (max_N del h)) with (pred (length (SubEqui del h))). rewrite SubEqui_P2; unfold max_N; case (maxN del h) as (?&?&?); left; assumption. rewrite SubEqui_P5; reflexivity. @@ -639,7 +639,7 @@ Qed. Lemma SubEqui_P8 : forall (a b:R) (del:posreal) (h:a < b) (i:nat), - (i < Rlength (SubEqui del h))%nat -> a <= pos_Rl (SubEqui del h) i <= b. + (i < length (SubEqui del h))%nat -> a <= pos_Rl (SubEqui del h) i <= b. Proof. intros; split. pattern a at 1; rewrite <- (SubEqui_P1 del h); apply RList_P5. @@ -657,7 +657,7 @@ Lemma SubEqui_P9 : { g:StepFun a b | g b = f b /\ (forall i:nat, - (i < pred (Rlength (SubEqui del h)))%nat -> + (i < pred (length (SubEqui del h)))%nat -> constant_D_eq g (co_interval (pos_Rl (SubEqui del h) i) (pos_Rl (SubEqui del h) (S i))) @@ -713,7 +713,7 @@ Proof. a <= t <= b -> t = b \/ (exists i : nat, - (i < pred (Rlength (SubEqui del H)))%nat /\ + (i < pred (length (SubEqui del H)))%nat /\ co_interval (pos_Rl (SubEqui del H) i) (pos_Rl (SubEqui del H) (S i)) t)). intro; elim (H8 _ H7); intro. @@ -722,7 +722,7 @@ Proof. elim H9; clear H9; intros I [H9 H10]; assert (H11 := H6 I H9 t H10); rewrite H11; left; apply H4. assumption. - apply SubEqui_P8; apply lt_trans with (pred (Rlength (SubEqui del H))). + apply SubEqui_P8; apply lt_trans with (pred (length (SubEqui del H))). assumption. apply lt_pred_n_n; apply neq_O_lt; red; intro; rewrite <- H12 in H9; elim (lt_n_O _ H9). @@ -734,7 +734,7 @@ Proof. (t - pos_Rl (SubEqui del H) (max_N del H))) with t; [ idtac | ring ]; apply Rlt_le_trans with b. rewrite H14 in H12; - assert (H13 : S (max_N del H) = pred (Rlength (SubEqui del H))). + assert (H13 : S (max_N del H) = pred (length (SubEqui del H))). rewrite SubEqui_P5; reflexivity. rewrite H13 in H12; rewrite SubEqui_P2 in H12; apply H12. rewrite SubEqui_P6. @@ -785,7 +785,7 @@ Proof. apply H5. assumption. inversion H7. - replace (S (max_N del H)) with (pred (Rlength (SubEqui del H))). + replace (S (max_N del H)) with (pred (length (SubEqui del H))). rewrite (SubEqui_P2 del H); elim H8; intros. elim H11; intro. assumption. @@ -1753,7 +1753,7 @@ Proof. rewrite <- H5; elim (RList_P6 l); intros; apply H10. assumption. apply le_O_n. - apply lt_trans with (pred (Rlength l)); [ assumption | apply lt_pred_n_n ]. + apply lt_trans with (pred (length l)); [ assumption | apply lt_pred_n_n ]. apply neq_O_lt; intro; rewrite <- H12 in H6; discriminate. unfold Rmin; decide (Rle_dec a b) with H; reflexivity. assert (H11 : pos_Rl l (S i) <= b). @@ -1960,7 +1960,7 @@ Proof. replace b with (Rmin b c). rewrite <- H5; elim (RList_P6 l1); intros; apply H10; try assumption. apply le_O_n. - apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n; + apply lt_trans with (pred (length l1)); try assumption; apply lt_pred_n_n; apply neq_O_lt; red; intro; rewrite <- H12 in H6; discriminate. unfold Rmin; decide (Rle_dec b c) with Hyp2; @@ -1991,7 +1991,7 @@ Proof. replace a with (Rmin a b). rewrite <- H5; elim (RList_P6 l1); intros; apply H11; try assumption. apply le_O_n. - apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n; + apply lt_trans with (pred (length l1)); try assumption; apply lt_pred_n_n; apply neq_O_lt; red; intro; rewrite <- H13 in H6; discriminate. unfold Rmin; decide (Rle_dec a b) with Hyp1; reflexivity. @@ -2018,7 +2018,7 @@ Proof. replace a with (Rmin a b). rewrite <- H5; elim (RList_P6 l1); intros; apply H11; try assumption. apply le_O_n. - apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n; + apply lt_trans with (pred (length l1)); try assumption; apply lt_pred_n_n; apply neq_O_lt; red; intro; rewrite <- H13 in H6; discriminate. unfold Rmin; decide (Rle_dec a b) with Hyp1; reflexivity. @@ -2037,7 +2037,7 @@ Proof. replace b with (Rmin b c). rewrite <- H5; elim (RList_P6 l1); intros; apply H10; try assumption. apply le_O_n. - apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n; + apply lt_trans with (pred (length l1)); try assumption; apply lt_pred_n_n; apply neq_O_lt; red; intro; rewrite <- H12 in H6; discriminate. unfold Rmin; decide (Rle_dec b c) with Hyp2; reflexivity. diff --git a/theories/Reals/RiemannInt_SF.v b/theories/Reals/RiemannInt_SF.v index c8ec4782d9..65221c67d2 100644 --- a/theories/Reals/RiemannInt_SF.v +++ b/theories/Reals/RiemannInt_SF.v @@ -12,6 +12,7 @@ Require Import Rbase. Require Import Rfunctions. Require Import Ranalysis_reg. Require Import Classical_Prop. +Require Import List. Require Import RList. Local Open Scope R_scope. @@ -114,41 +115,41 @@ Qed. Definition open_interval (a b x:R) : Prop := a < x < b. Definition co_interval (a b x:R) : Prop := a <= x < b. -Definition adapted_couple (f:R -> R) (a b:R) (l lf:Rlist) : Prop := +Definition adapted_couple (f:R -> R) (a b:R) (l lf:list R) : Prop := ordered_Rlist l /\ pos_Rl l 0 = Rmin a b /\ - pos_Rl l (pred (Rlength l)) = Rmax a b /\ - Rlength l = S (Rlength lf) /\ + pos_Rl l (pred (length l)) = Rmax a b /\ + length l = S (length lf) /\ (forall i:nat, - (i < pred (Rlength l))%nat -> + (i < pred (length l))%nat -> constant_D_eq f (open_interval (pos_Rl l i) (pos_Rl l (S i))) (pos_Rl lf i)). -Definition adapted_couple_opt (f:R -> R) (a b:R) (l lf:Rlist) := +Definition adapted_couple_opt (f:R -> R) (a b:R) (l lf:list R) := adapted_couple f a b l lf /\ (forall i:nat, - (i < pred (Rlength lf))%nat -> + (i < pred (length lf))%nat -> pos_Rl lf i <> pos_Rl lf (S i) \/ f (pos_Rl l (S i)) <> pos_Rl lf i) /\ - (forall i:nat, (i < pred (Rlength l))%nat -> pos_Rl l i <> pos_Rl l (S i)). + (forall i:nat, (i < pred (length l))%nat -> pos_Rl l i <> pos_Rl l (S i)). -Definition is_subdivision (f:R -> R) (a b:R) (l:Rlist) : Type := - { l0:Rlist & adapted_couple f a b l l0 }. +Definition is_subdivision (f:R -> R) (a b:R) (l:list R) : Type := + { l0:list R & adapted_couple f a b l l0 }. Definition IsStepFun (f:R -> R) (a b:R) : Type := - { l:Rlist & is_subdivision f a b l }. + { l:list R & is_subdivision f a b l }. (** ** Class of step functions *) Record StepFun (a b:R) : Type := mkStepFun {fe :> R -> R; pre : IsStepFun fe a b}. -Definition subdivision (a b:R) (f:StepFun a b) : Rlist := projT1 (pre f). +Definition subdivision (a b:R) (f:StepFun a b) : list R := projT1 (pre f). -Definition subdivision_val (a b:R) (f:StepFun a b) : Rlist := +Definition subdivision_val (a b:R) (f:StepFun a b) : list R := match projT2 (pre f) with | existT _ a b => a end. -Fixpoint Int_SF (l k:Rlist) : R := +Fixpoint Int_SF (l k:list R) : R := match l with | nil => 0 | cons a l' => @@ -179,7 +180,7 @@ Proof. Qed. Lemma StepFun_P2 : - forall (a b:R) (f:R -> R) (l lf:Rlist), + forall (a b:R) (f:R -> R) (l lf:list R), adapted_couple f a b l lf -> adapted_couple f b a l lf. Proof. unfold adapted_couple; intros; decompose [and] H; clear H; @@ -219,7 +220,7 @@ Proof. Qed. Lemma StepFun_P5 : - forall (a b:R) (f:R -> R) (l:Rlist), + forall (a b:R) (f:R -> R) (l:list R), is_subdivision f a b l -> is_subdivision f b a l. Proof. destruct 1 as (x,(H0,(H1,(H2,(H3,H4))))); exists x; @@ -236,7 +237,7 @@ Proof. Qed. Lemma StepFun_P7 : - forall (a b r1 r2 r3:R) (f:R -> R) (l lf:Rlist), + forall (a b r1 r2 r3:R) (f:R -> R) (l lf:list R), a <= b -> adapted_couple f a b (cons r1 (cons r2 l)) (cons r3 lf) -> adapted_couple f r2 b (cons r2 l) lf. @@ -257,31 +258,36 @@ Proof. rewrite H4; reflexivity. intros; unfold constant_D_eq, open_interval; intros; unfold constant_D_eq, open_interval in H6; - assert (H9 : (S i < pred (Rlength (cons r1 (cons r2 l))))%nat). + assert (H9 : (S i < pred (length (cons r1 (cons r2 l))))%nat). simpl; simpl in H0; apply lt_n_S; assumption. assert (H10 := H6 _ H9); apply H10; assumption. Qed. Lemma StepFun_P8 : - forall (f:R -> R) (l1 lf1:Rlist) (a b:R), + forall (f:R -> R) (l1 lf1:list R) (a b:R), adapted_couple f a b l1 lf1 -> a = b -> Int_SF lf1 l1 = 0. Proof. simple induction l1. intros; induction lf1 as [| r lf1 Hreclf1]; reflexivity. - simple induction r0. + intros r r0. + induction r0 as [ | r1 r2 H0]. intros; induction lf1 as [| r1 lf1 Hreclf1]. reflexivity. unfold adapted_couple in H0; decompose [and] H0; clear H0; simpl in H5; discriminate. - intros; induction lf1 as [| r3 lf1 Hreclf1]. + intros H. + induction lf1 as [| r3 lf1 Hreclf1]; intros a b H1 H2. reflexivity. simpl; cut (r = r1). - intro; rewrite H3; rewrite (H0 lf1 r b). + intros H3. + rewrite H3; rewrite (H lf1 r b). ring. rewrite H3; apply StepFun_P7 with a r r3; [ right; assumption | assumption ]. - clear H H0 Hreclf1 r0; unfold adapted_couple in H1; decompose [and] H1; + clear H H0 Hreclf1; unfold adapted_couple in H1. + decompose [and] H1. intros; simpl in H4; rewrite H4; unfold Rmin; case (Rle_dec a b); intro; [ assumption | reflexivity ]. + unfold adapted_couple in H1; decompose [and] H1; intros; apply Rle_antisym. apply (H3 0%nat); simpl; apply lt_O_Sn. simpl in H5; rewrite H2 in H5; rewrite H5; replace (Rmin b b) with (Rmax a b); @@ -292,8 +298,8 @@ Proof. Qed. Lemma StepFun_P9 : - forall (a b:R) (f:R -> R) (l lf:Rlist), - adapted_couple f a b l lf -> a <> b -> (2 <= Rlength l)%nat. + forall (a b:R) (f:R -> R) (l lf:list R), + adapted_couple f a b l lf -> a <> b -> (2 <= length l)%nat. Proof. intros; unfold adapted_couple in H; decompose [and] H; clear H; induction l as [| r l Hrecl]; @@ -307,13 +313,13 @@ Proof. Qed. Lemma StepFun_P10 : - forall (f:R -> R) (l lf:Rlist) (a b:R), + forall (f:R -> R) (l lf:list R) (a b:R), a <= b -> adapted_couple f a b l lf -> - exists l' : Rlist, - (exists lf' : Rlist, adapted_couple_opt f a b l' lf'). + exists l' : list R, + (exists lf' : list R, adapted_couple_opt f a b l' lf'). Proof. - simple induction l. + induction l as [ | r r0 H]. intros; unfold adapted_couple in H0; decompose [and] H0; simpl in H4; discriminate. intros; case (Req_dec a b); intro. @@ -503,7 +509,7 @@ Proof. Qed. Lemma StepFun_P11 : - forall (a b r r1 r3 s1 s2 r4:R) (r2 lf1 s3 lf2:Rlist) + forall (a b r r1 r3 s1 s2 r4:R) (r2 lf1 s3 lf2:list R) (f:R -> R), a < b -> adapted_couple f a b (cons r (cons r1 r2)) (cons r3 lf1) -> @@ -627,7 +633,7 @@ Proof. Qed. Lemma StepFun_P12 : - forall (a b:R) (f:R -> R) (l lf:Rlist), + forall (a b:R) (f:R -> R) (l lf:list R), adapted_couple_opt f a b l lf -> adapted_couple_opt f b a l lf. Proof. unfold adapted_couple_opt; unfold adapted_couple; intros; @@ -643,7 +649,7 @@ Proof. Qed. Lemma StepFun_P13 : - forall (a b r r1 r3 s1 s2 r4:R) (r2 lf1 s3 lf2:Rlist) + forall (a b r r1 r3 s1 s2 r4:R) (r2 lf1 s3 lf2:list R) (f:R -> R), a <> b -> adapted_couple f a b (cons r (cons r1 r2)) (cons r3 lf1) -> @@ -657,15 +663,15 @@ Proof. Qed. Lemma StepFun_P14 : - forall (f:R -> R) (l1 l2 lf1 lf2:Rlist) (a b:R), + forall (f:R -> R) (l1 l2 lf1 lf2:list R) (a b:R), a <= b -> adapted_couple f a b l1 lf1 -> adapted_couple_opt f a b l2 lf2 -> Int_SF lf1 l1 = Int_SF lf2 l2. Proof. - simple induction l1. + induction l1 as [ | r r0 H0]. intros l2 lf1 lf2 a b Hyp H H0; unfold adapted_couple in H; decompose [and] H; clear H H0 H2 H3 H1 H6; simpl in H4; discriminate. - simple induction r0. + induction r0 as [|r1 r2 H]. intros; case (Req_dec a b); intro. unfold adapted_couple_opt in H2; elim H2; intros; rewrite (StepFun_P8 H4 H3); rewrite (StepFun_P8 H1 H3); reflexivity. @@ -798,7 +804,7 @@ Proof. rewrite H9; change (forall i:nat, - (i < pred (Rlength (cons r4 lf2)))%nat -> + (i < pred (length (cons r4 lf2)))%nat -> pos_Rl (cons r4 lf2) i <> pos_Rl (cons r4 lf2) (S i) \/ f (pos_Rl (cons s1 (cons s2 s3)) (S i)) <> pos_Rl (cons r4 lf2) i) ; rewrite <- H5; apply H3. @@ -840,7 +846,7 @@ Proof. rewrite <- H10; unfold open_interval; apply H2. elim H3; clear H3; intros; split. rewrite H5 in H3; intros; apply (H3 (S i)). - simpl; replace (Rlength lf2) with (S (pred (Rlength lf2))). + simpl; replace (length lf2) with (S (pred (length lf2))). apply lt_n_S; apply H12. symmetry ; apply S_pred with 0%nat; apply neq_O_lt; red; intro; rewrite <- H13 in H12; elim (lt_n_O _ H12). @@ -863,7 +869,7 @@ Proof. Qed. Lemma StepFun_P15 : - forall (f:R -> R) (l1 l2 lf1 lf2:Rlist) (a b:R), + forall (f:R -> R) (l1 l2 lf1 lf2:list R) (a b:R), adapted_couple f a b l1 lf1 -> adapted_couple_opt f a b l2 lf2 -> Int_SF lf1 l1 = Int_SF lf2 l2. Proof. @@ -876,10 +882,10 @@ Proof. Qed. Lemma StepFun_P16 : - forall (f:R -> R) (l lf:Rlist) (a b:R), + forall (f:R -> R) (l lf:list R) (a b:R), adapted_couple f a b l lf -> - exists l' : Rlist, - (exists lf' : Rlist, adapted_couple_opt f a b l' lf'). + exists l' : list R, + (exists lf' : list R, adapted_couple_opt f a b l' lf'). Proof. intros; destruct (Rle_dec a b) as [Hle|Hnle]; [ apply (StepFun_P10 Hle H) @@ -891,7 +897,7 @@ Proof. Qed. Lemma StepFun_P17 : - forall (f:R -> R) (l1 l2 lf1 lf2:Rlist) (a b:R), + forall (f:R -> R) (l1 l2 lf1 lf2:list R) (a b:R), adapted_couple f a b l1 lf1 -> adapted_couple f a b l2 lf2 -> Int_SF lf1 l1 = Int_SF lf2 l2. Proof. @@ -922,7 +928,7 @@ Proof. Qed. Lemma StepFun_P19 : - forall (l1:Rlist) (f g:R -> R) (l:R), + forall (l1:list R) (f g:R -> R) (l:R), Int_SF (FF l1 (fun x:R => f x + l * g x)) l1 = Int_SF (FF l1 f) l1 + l * Int_SF (FF l1 g) l1. Proof. @@ -933,8 +939,8 @@ Proof. Qed. Lemma StepFun_P20 : - forall (l:Rlist) (f:R -> R), - (0 < Rlength l)%nat -> Rlength l = S (Rlength (FF l f)). + forall (l:list R) (f:R -> R), + (0 < length l)%nat -> length l = S (length (FF l f)). Proof. intros l f H; induction l; [ elim (lt_irrefl _ H) @@ -942,7 +948,7 @@ Proof. Qed. Lemma StepFun_P21 : - forall (a b:R) (f:R -> R) (l:Rlist), + forall (a b:R) (f:R -> R) (l:list R), is_subdivision f a b l -> adapted_couple f a b l (FF l f). Proof. intros * (x & H & H1 & H0 & H2 & H4). @@ -979,7 +985,7 @@ Proof. Qed. Lemma StepFun_P22 : - forall (a b:R) (f g:R -> R) (lf lg:Rlist), + forall (a b:R) (f g:R -> R) (lf lg:list R), a <= b -> is_subdivision f a b lf -> is_subdivision g a b lg -> is_subdivision f a b (cons_ORlist lf lg). @@ -1032,25 +1038,25 @@ Proof. (H8 : In (pos_Rl (cons_ORlist (cons r lf) lg) - (pred (Rlength (cons_ORlist (cons r lf) lg)))) + (pred (length (cons_ORlist (cons r lf) lg)))) (cons_ORlist (cons r lf) lg)). elim (RList_P3 (cons_ORlist (cons r lf) lg) (pos_Rl (cons_ORlist (cons r lf) lg) - (pred (Rlength (cons_ORlist (cons r lf) lg))))); + (pred (length (cons_ORlist (cons r lf) lg))))); intros _ H10; apply H10; - exists (pred (Rlength (cons_ORlist (cons r lf) lg))); + exists (pred (length (cons_ORlist (cons r lf) lg))); split; [ reflexivity | rewrite RList_P11; simpl; apply lt_n_Sn ]. elim (RList_P9 (cons r lf) lg (pos_Rl (cons_ORlist (cons r lf) lg) - (pred (Rlength (cons_ORlist (cons r lf) lg))))); + (pred (length (cons_ORlist (cons r lf) lg))))); intros H10 _. assert (H11 := H10 H8); elim H11; intro. elim (RList_P3 (cons r lf) (pos_Rl (cons_ORlist (cons r lf) lg) - (pred (Rlength (cons_ORlist (cons r lf) lg))))); + (pred (length (cons_ORlist (cons r lf) lg))))); intros H13 _; assert (H14 := H13 H12); elim H14; intros; elim H15; clear H15; intros; rewrite H15; rewrite <- H5; elim (RList_P6 (cons r lf)); intros; apply H17; @@ -1060,10 +1066,10 @@ Proof. elim (RList_P3 lg (pos_Rl (cons_ORlist (cons r lf) lg) - (pred (Rlength (cons_ORlist (cons r lf) lg))))); + (pred (length (cons_ORlist (cons r lf) lg))))); intros H13 _; assert (H14 := H13 H12); elim H14; intros; elim H15; clear H15; intros. - rewrite H15; assert (H17 : Rlength lg = S (pred (Rlength lg))). + rewrite H15; assert (H17 : length lg = S (pred (length lg))). apply S_pred with 0%nat; apply neq_O_lt; red; intro; rewrite <- H17 in H16; elim (lt_n_O _ H16). rewrite <- H0; elim (RList_P6 lg); intros; apply H18; @@ -1075,7 +1081,7 @@ Proof. assert (H8 : In b (cons_ORlist (cons r lf) lg)). elim (RList_P9 (cons r lf) lg b); intros; apply H10; left; elim (RList_P3 (cons r lf) b); intros; apply H12; - exists (pred (Rlength (cons r lf))); split; + exists (pred (length (cons r lf))); split; [ symmetry ; assumption | simpl; apply lt_n_Sn ]. apply RList_P7; [ apply RList_P2; assumption | assumption ]. apply StepFun_P20; rewrite RList_P11; rewrite H2; rewrite H7; simpl; @@ -1089,7 +1095,7 @@ Proof. intros; elim H11; clear H11; intros; assert (H12 := H11); assert (Hyp_cons : - exists r : R, (exists r0 : Rlist, cons_ORlist lf lg = cons r r0)). + exists r : R, (exists r0 : list R, cons_ORlist lf lg = cons r r0)). apply RList_P19; red; intro; rewrite H13 in H8; elim (lt_n_O _ H8). elim Hyp_cons; clear Hyp_cons; intros r [r0 Hyp_cons]; rewrite Hyp_cons; unfold FF; rewrite RList_P12. @@ -1128,7 +1134,7 @@ Proof. elim (RList_P6 (cons_ORlist lf lg)); intros; apply H11. apply RList_P2; assumption. apply le_O_n. - apply lt_trans with (pred (Rlength (cons_ORlist lf lg))); + apply lt_trans with (pred (length (cons_ORlist lf lg))); [ assumption | apply lt_pred_n_n; apply neq_O_lt; red; intro; rewrite <- H13 in H8; elim (lt_n_O _ H8) ]. @@ -1147,9 +1153,9 @@ Proof. set (I := fun j:nat => - pos_Rl lf j <= pos_Rl (cons_ORlist lf lg) i /\ (j < Rlength lf)%nat); + pos_Rl lf j <= pos_Rl (cons_ORlist lf lg) i /\ (j < length lf)%nat); assert (H12 : Nbound I). - unfold Nbound; exists (Rlength lf); intros; unfold I in H12; elim H12; + unfold Nbound; exists (length lf); intros; unfold I in H12; elim H12; intros; apply lt_le_weak; assumption. assert (H13 : exists n : nat, I n). exists 0%nat; unfold I; split. @@ -1159,7 +1165,7 @@ Proof. elim (RList_P6 (cons_ORlist lf lg)); intros; apply H13. apply RList_P2; assumption. apply le_O_n. - apply lt_trans with (pred (Rlength (cons_ORlist lf lg))). + apply lt_trans with (pred (length (cons_ORlist lf lg))). assumption. apply lt_pred_n_n; apply neq_O_lt; red; intro; rewrite <- H15 in H8; elim (lt_n_O _ H8). @@ -1167,12 +1173,12 @@ Proof. rewrite <- H6 in H11; rewrite <- H5 in H11; elim (Rlt_irrefl _ H11). assert (H14 := Nzorn H13 H12); elim H14; clear H14; intros x0 H14; exists (pos_Rl lf0 x0); unfold constant_D_eq, open_interval; - intros; assert (H16 := H9 x0); assert (H17 : (x0 < pred (Rlength lf))%nat). + intros; assert (H16 := H9 x0); assert (H17 : (x0 < pred (length lf))%nat). elim H14; clear H14; intros; unfold I in H14; elim H14; clear H14; intros; - apply lt_S_n; replace (S (pred (Rlength lf))) with (Rlength lf). + apply lt_S_n; replace (S (pred (length lf))) with (length lf). inversion H18. 2: apply lt_n_S; assumption. - cut (x0 = pred (Rlength lf)). + cut (x0 = pred (length lf)). intro; rewrite H19 in H14; rewrite H5 in H14; cut (pos_Rl (cons_ORlist lf lg) i < b). intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H14 H21)). @@ -1180,7 +1186,7 @@ Proof. elim H10; intros; apply Rlt_trans with x; assumption. rewrite <- H5; apply Rle_trans with - (pos_Rl (cons_ORlist lf lg) (pred (Rlength (cons_ORlist lf lg)))). + (pos_Rl (cons_ORlist lf lg) (pred (length (cons_ORlist lf lg)))). elim (RList_P6 (cons_ORlist lf lg)); intros; apply H21. apply RList_P2; assumption. apply lt_n_Sm_le; apply lt_n_S; assumption. @@ -1197,8 +1203,8 @@ Proof. elim H14; clear H14; intros; split. apply Rle_lt_trans with (pos_Rl (cons_ORlist lf lg) i); assumption. apply Rlt_le_trans with (pos_Rl (cons_ORlist lf lg) (S i)); try assumption. - assert (H22 : (S x0 < Rlength lf)%nat). - replace (Rlength lf) with (S (pred (Rlength lf))); + assert (H22 : (S x0 < length lf)%nat). + replace (length lf) with (S (pred (length lf))); [ apply lt_n_S; assumption | symmetry ; apply S_pred with 0%nat; apply neq_O_lt; red; intro; rewrite <- H22 in H21; elim (lt_n_O _ H21) ]. @@ -1216,7 +1222,7 @@ Proof. Qed. Lemma StepFun_P23 : - forall (a b:R) (f g:R -> R) (lf lg:Rlist), + forall (a b:R) (f g:R -> R) (lf lg:list R), is_subdivision f a b lf -> is_subdivision g a b lg -> is_subdivision f a b (cons_ORlist lf lg). Proof. @@ -1229,7 +1235,7 @@ Proof. Qed. Lemma StepFun_P24 : - forall (a b:R) (f g:R -> R) (lf lg:Rlist), + forall (a b:R) (f g:R -> R) (lf lg:list R), a <= b -> is_subdivision f a b lf -> is_subdivision g a b lg -> is_subdivision g a b (cons_ORlist lf lg). @@ -1282,24 +1288,24 @@ Proof. (H8 : In (pos_Rl (cons_ORlist (cons r lf) lg) - (pred (Rlength (cons_ORlist (cons r lf) lg)))) + (pred (length (cons_ORlist (cons r lf) lg)))) (cons_ORlist (cons r lf) lg)). elim (RList_P3 (cons_ORlist (cons r lf) lg) (pos_Rl (cons_ORlist (cons r lf) lg) - (pred (Rlength (cons_ORlist (cons r lf) lg))))); + (pred (length (cons_ORlist (cons r lf) lg))))); intros _ H10; apply H10; - exists (pred (Rlength (cons_ORlist (cons r lf) lg))); + exists (pred (length (cons_ORlist (cons r lf) lg))); split; [ reflexivity | rewrite RList_P11; simpl; apply lt_n_Sn ]. elim (RList_P9 (cons r lf) lg (pos_Rl (cons_ORlist (cons r lf) lg) - (pred (Rlength (cons_ORlist (cons r lf) lg))))); + (pred (length (cons_ORlist (cons r lf) lg))))); intros H10 _; assert (H11 := H10 H8); elim H11; intro. elim (RList_P3 (cons r lf) (pos_Rl (cons_ORlist (cons r lf) lg) - (pred (Rlength (cons_ORlist (cons r lf) lg))))); + (pred (length (cons_ORlist (cons r lf) lg))))); intros H13 _; assert (H14 := H13 H12); elim H14; intros; elim H15; clear H15; intros; rewrite H15; rewrite <- H5; elim (RList_P6 (cons r lf)); intros; apply H17; @@ -1309,10 +1315,10 @@ Proof. elim (RList_P3 lg (pos_Rl (cons_ORlist (cons r lf) lg) - (pred (Rlength (cons_ORlist (cons r lf) lg))))); + (pred (length (cons_ORlist (cons r lf) lg))))); intros H13 _; assert (H14 := H13 H12); elim H14; intros; elim H15; clear H15; intros; rewrite H15; - assert (H17 : Rlength lg = S (pred (Rlength lg))). + assert (H17 : length lg = S (pred (length lg))). apply S_pred with 0%nat; apply neq_O_lt; red; intro; rewrite <- H17 in H16; elim (lt_n_O _ H16). rewrite <- H0; elim (RList_P6 lg); intros; apply H18; @@ -1324,7 +1330,7 @@ Proof. assert (H8 : In b (cons_ORlist (cons r lf) lg)). elim (RList_P9 (cons r lf) lg b); intros; apply H10; left; elim (RList_P3 (cons r lf) b); intros; apply H12; - exists (pred (Rlength (cons r lf))); split; + exists (pred (length (cons r lf))); split; [ symmetry ; assumption | simpl; apply lt_n_Sn ]. apply RList_P7; [ apply RList_P2; assumption | assumption ]. apply StepFun_P20; rewrite RList_P11; rewrite H7; rewrite H2; simpl; @@ -1338,7 +1344,7 @@ Proof. intros; elim H11; clear H11; intros; assert (H12 := H11); assert (Hyp_cons : - exists r : R, (exists r0 : Rlist, cons_ORlist lf lg = cons r r0)). + exists r : R, (exists r0 : list R, cons_ORlist lf lg = cons r r0)). apply RList_P19; red; intro; rewrite H13 in H8; elim (lt_n_O _ H8). elim Hyp_cons; clear Hyp_cons; intros r [r0 Hyp_cons]; rewrite Hyp_cons; unfold FF; rewrite RList_P12. @@ -1377,7 +1383,7 @@ Proof. elim (RList_P6 (cons_ORlist lf lg)); intros; apply H11. apply RList_P2; assumption. apply le_O_n. - apply lt_trans with (pred (Rlength (cons_ORlist lf lg))); + apply lt_trans with (pred (length (cons_ORlist lf lg))); [ assumption | apply lt_pred_n_n; apply neq_O_lt; red; intro; rewrite <- H13 in H8; elim (lt_n_O _ H8) ]. @@ -1394,9 +1400,9 @@ Proof. set (I := fun j:nat => - pos_Rl lg j <= pos_Rl (cons_ORlist lf lg) i /\ (j < Rlength lg)%nat); + pos_Rl lg j <= pos_Rl (cons_ORlist lf lg) i /\ (j < length lg)%nat); assert (H12 : Nbound I). - unfold Nbound; exists (Rlength lg); intros; unfold I in H12; elim H12; + unfold Nbound; exists (length lg); intros; unfold I in H12; elim H12; intros; apply lt_le_weak; assumption. assert (H13 : exists n : nat, I n). exists 0%nat; unfold I; split. @@ -1406,7 +1412,7 @@ Proof. elim (RList_P6 (cons_ORlist lf lg)); intros; apply H13; [ apply RList_P2; assumption | apply le_O_n - | apply lt_trans with (pred (Rlength (cons_ORlist lf lg))); + | apply lt_trans with (pred (length (cons_ORlist lf lg))); [ assumption | apply lt_pred_n_n; apply neq_O_lt; red; intro; rewrite <- H15 in H8; elim (lt_n_O _ H8) ] ]. @@ -1414,12 +1420,12 @@ Proof. rewrite <- H1 in H11; rewrite <- H0 in H11; elim (Rlt_irrefl _ H11). assert (H14 := Nzorn H13 H12); elim H14; clear H14; intros x0 H14; exists (pos_Rl lg0 x0); unfold constant_D_eq, open_interval; - intros; assert (H16 := H4 x0); assert (H17 : (x0 < pred (Rlength lg))%nat). + intros; assert (H16 := H4 x0); assert (H17 : (x0 < pred (length lg))%nat). elim H14; clear H14; intros; unfold I in H14; elim H14; clear H14; intros; - apply lt_S_n; replace (S (pred (Rlength lg))) with (Rlength lg). + apply lt_S_n; replace (S (pred (length lg))) with (length lg). inversion H18. 2: apply lt_n_S; assumption. - cut (x0 = pred (Rlength lg)). + cut (x0 = pred (length lg)). intro; rewrite H19 in H14; rewrite H0 in H14; cut (pos_Rl (cons_ORlist lf lg) i < b). intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H14 H21)). @@ -1427,7 +1433,7 @@ Proof. elim H10; intros; apply Rlt_trans with x; assumption. rewrite <- H0; apply Rle_trans with - (pos_Rl (cons_ORlist lf lg) (pred (Rlength (cons_ORlist lf lg)))). + (pos_Rl (cons_ORlist lf lg) (pred (length (cons_ORlist lf lg)))). elim (RList_P6 (cons_ORlist lf lg)); intros; apply H21. apply RList_P2; assumption. apply lt_n_Sm_le; apply lt_n_S; assumption. @@ -1445,8 +1451,8 @@ Proof. elim H14; clear H14; intros; split. apply Rle_lt_trans with (pos_Rl (cons_ORlist lf lg) i); assumption. apply Rlt_le_trans with (pos_Rl (cons_ORlist lf lg) (S i)); try assumption. - assert (H22 : (S x0 < Rlength lg)%nat). - replace (Rlength lg) with (S (pred (Rlength lg))). + assert (H22 : (S x0 < length lg)%nat). + replace (length lg) with (S (pred (length lg))). apply lt_n_S; assumption. symmetry ; apply S_pred with 0%nat; apply neq_O_lt; red; intro; rewrite <- H22 in H21; elim (lt_n_O _ H21). @@ -1463,7 +1469,7 @@ Proof. Qed. Lemma StepFun_P25 : - forall (a b:R) (f g:R -> R) (lf lg:Rlist), + forall (a b:R) (f g:R -> R) (lf lg:list R), is_subdivision f a b lf -> is_subdivision g a b lg -> is_subdivision g a b (cons_ORlist lf lg). Proof. @@ -1476,7 +1482,7 @@ Proof. Qed. Lemma StepFun_P26 : - forall (a b l:R) (f g:R -> R) (l1:Rlist), + forall (a b l:R) (f g:R -> R) (l1:list R), is_subdivision f a b l1 -> is_subdivision g a b l1 -> is_subdivision (fun x:R => f x + l * g x) a b l1. @@ -1494,7 +1500,7 @@ Proof. change (pos_Rl x0 i + l * pos_Rl x i = pos_Rl - (app_Rlist (mid_Rlist (cons r r0) r) (fun x2:R => f x2 + l * g x2)) + (map (fun x2:R => f x2 + l * g x2) (mid_Rlist (cons r r0) r)) (S i)); rewrite RList_P12. rewrite RList_P13. rewrite <- H12; rewrite (H9 _ H8); try rewrite (H4 _ H8); @@ -1521,7 +1527,7 @@ Proof. Qed. Lemma StepFun_P27 : - forall (a b l:R) (f g:R -> R) (lf lg:Rlist), + forall (a b l:R) (f g:R -> R) (lf lg:list R), is_subdivision f a b lf -> is_subdivision g a b lg -> is_subdivision (fun x:R => f x + l * g x) a b (cons_ORlist lf lg). @@ -1586,9 +1592,9 @@ Proof. Qed. Lemma StepFun_P31 : - forall (a b:R) (f:R -> R) (l lf:Rlist), + forall (a b:R) (f:R -> R) (l lf:list R), adapted_couple f a b l lf -> - adapted_couple (fun x:R => Rabs (f x)) a b l (app_Rlist lf Rabs). + adapted_couple (fun x:R => Rabs (f x)) a b l (map Rabs lf). Proof. unfold adapted_couple; intros; decompose [and] H; clear H; repeat split; try assumption. @@ -1604,15 +1610,15 @@ Lemma StepFun_P32 : Proof. intros a b f; unfold IsStepFun; apply existT with (subdivision f); unfold is_subdivision; - apply existT with (app_Rlist (subdivision_val f) Rabs); + apply existT with (map Rabs (subdivision_val f)); apply StepFun_P31; apply StepFun_P1. Qed. Lemma StepFun_P33 : - forall l2 l1:Rlist, - ordered_Rlist l1 -> Rabs (Int_SF l2 l1) <= Int_SF (app_Rlist l2 Rabs) l1. + forall l2 l1:list R, + ordered_Rlist l1 -> Rabs (Int_SF l2 l1) <= Int_SF (map Rabs l2) l1. Proof. - simple induction l2; intros. + induction l2 as [ | r r0 H]; intros. simpl; rewrite Rabs_R0; right; reflexivity. simpl; induction l1 as [| r1 l1 Hrecl1]. rewrite Rabs_R0; right; reflexivity. @@ -1635,7 +1641,7 @@ Proof. replace (Int_SF (subdivision_val (mkStepFun (StepFun_P32 f))) (subdivision (mkStepFun (StepFun_P32 f)))) with - (Int_SF (app_Rlist (subdivision_val f) Rabs) (subdivision f)). + (Int_SF (map Rabs (subdivision_val f)) (subdivision f)). apply StepFun_P33; assert (H0 := StepFun_P29 f); unfold is_subdivision in H0; elim H0; intros; unfold adapted_couple in p; decompose [and] p; assumption. @@ -1645,14 +1651,14 @@ Proof. Qed. Lemma StepFun_P35 : - forall (l:Rlist) (a b:R) (f g:R -> R), + forall (l:list R) (a b:R) (f g:R -> R), ordered_Rlist l -> pos_Rl l 0 = a -> - pos_Rl l (pred (Rlength l)) = b -> + pos_Rl l (pred (length l)) = b -> (forall x:R, a < x < b -> f x <= g x) -> Int_SF (FF l f) l <= Int_SF (FF l g) l. Proof. - simple induction l; intros. + induction l as [ | r r0 H]; intros. right; reflexivity. simpl; induction r0 as [| r0 r1 Hrecr0]. right; reflexivity. @@ -1682,7 +1688,7 @@ Proof. rewrite <- Rinv_r_sym. rewrite Rmult_1_l; rewrite double; assert (H5 : r0 <= b). replace b with - (pos_Rl (cons r (cons r0 r1)) (pred (Rlength (cons r (cons r0 r1))))). + (pos_Rl (cons r (cons r0 r1)) (pred (length (cons r (cons r0 r1))))). replace r0 with (pos_Rl (cons r (cons r0 r1)) 1). elim (RList_P6 (cons r (cons r0 r1))); intros; apply H5. assumption. @@ -1712,7 +1718,7 @@ Proof. Qed. Lemma StepFun_P36 : - forall (a b:R) (f g:StepFun a b) (l:Rlist), + forall (a b:R) (f g:StepFun a b) (l:list R), a <= b -> is_subdivision f a b l -> is_subdivision g a b l -> @@ -1748,18 +1754,18 @@ Proof. Qed. Lemma StepFun_P38 : - forall (l:Rlist) (a b:R) (f:R -> R), + forall (l:list R) (a b:R) (f:R -> R), ordered_Rlist l -> pos_Rl l 0 = a -> - pos_Rl l (pred (Rlength l)) = b -> + pos_Rl l (pred (length l)) = b -> { g:StepFun a b | g b = f b /\ (forall i:nat, - (i < pred (Rlength l))%nat -> + (i < pred (length l))%nat -> constant_D_eq g (co_interval (pos_Rl l i) (pos_Rl l (S i))) (f (pos_Rl l i))) }. Proof. - intros l a b f; generalize a; clear a; induction l. + intros l a b f; generalize a; clear a; induction l as [|r l IHl]. intros a H H0 H1; simpl in H0; simpl in H1; exists (mkStepFun (StepFun_P4 a b (f b))); split. reflexivity. @@ -1772,7 +1778,7 @@ Proof. apply RList_P4 with r; assumption. assert (H3 : pos_Rl (cons r1 l) 0 = r1). reflexivity. - assert (H4 : pos_Rl (cons r1 l) (pred (Rlength (cons r1 l))) = b). + assert (H4 : pos_Rl (cons r1 l) (pred (length (cons r1 l))) = b). rewrite <- H1; reflexivity. elim (IHl r1 H2 H3 H4); intros g [H5 H6]. set @@ -1796,7 +1802,7 @@ Proof. simpl in H0; rewrite <- H0; apply (H 0%nat); simpl; apply lt_O_Sn. unfold Rmin; decide (Rle_dec r1 b) with H7; reflexivity. apply (H10 i); apply lt_S_n. - replace (S (pred (Rlength lg))) with (Rlength lg). + replace (S (pred (length lg))) with (length lg). apply H9. apply S_pred with 0%nat; apply neq_O_lt; intro; rewrite <- H14 in H9; elim (lt_n_O _ H9). @@ -1825,9 +1831,9 @@ Proof. change (constant_D_eq g' (open_interval (pos_Rl lg i) (pos_Rl lg (S i))) (pos_Rl lg2 i)); clear Hreci; assert (H16 := H15 i); - assert (H17 : (i < pred (Rlength lg))%nat). + assert (H17 : (i < pred (length lg))%nat). apply lt_S_n. - replace (S (pred (Rlength lg))) with (Rlength lg). + replace (S (pred (length lg))) with (length lg). assumption. apply S_pred with 0%nat; apply neq_O_lt; red; intro; rewrite <- H14 in H9; elim (lt_n_O _ H9). @@ -1843,7 +1849,7 @@ Proof. assumption. elim (RList_P3 lg (pos_Rl lg i)); intros; apply H21; exists i; split. reflexivity. - apply lt_trans with (pred (Rlength lg)); try assumption. + apply lt_trans with (pred (length lg)); try assumption. apply lt_pred_n_n; apply neq_O_lt; red; intro; rewrite <- H22 in H17; elim (lt_n_O _ H17). unfold Rmin; decide (Rle_dec r1 b) with H7; reflexivity. @@ -1860,7 +1866,7 @@ Proof. (constant_D_eq (mkStepFun H8) (co_interval (pos_Rl (cons r1 l) i) (pos_Rl (cons r1 l) (S i))) (f (pos_Rl (cons r1 l) i))); assert (H10 := H6 i); - assert (H11 : (i < pred (Rlength (cons r1 l)))%nat). + assert (H11 : (i < pred (length (cons r1 l)))%nat). simpl; apply lt_S_n; assumption. assert (H12 := H10 H11); unfold constant_D_eq, co_interval in H12; unfold constant_D_eq, co_interval; intros; @@ -1873,7 +1879,7 @@ Proof. elim (RList_P6 (cons r1 l)); intros; apply H15; [ assumption | apply le_O_n - | simpl; apply lt_trans with (Rlength l); + | simpl; apply lt_trans with (length l); [ apply lt_S_n; assumption | apply lt_n_Sn ] ]. Qed. @@ -1912,12 +1918,12 @@ Proof. Qed. Lemma StepFun_P40 : - forall (f:R -> R) (a b c:R) (l1 l2 lf1 lf2:Rlist), + forall (f:R -> R) (a b c:R) (l1 l2 lf1 lf2:list R), a < b -> b < c -> adapted_couple f a b l1 lf1 -> adapted_couple f b c l2 lf2 -> - adapted_couple f a c (cons_Rlist l1 l2) (FF (cons_Rlist l1 l2) f). + adapted_couple f a c (app l1 l2) (FF (app l1 l2) f). Proof. intros f a b c l1 l2 lf1 lf2 H H0 H1 H2; unfold adapted_couple in H1, H2; unfold adapted_couple; decompose [and] H1; @@ -1941,28 +1947,28 @@ Proof. | left; assumption ]. red; intro; rewrite H1 in H11; discriminate. apply StepFun_P20. - rewrite RList_P23; apply neq_O_lt; red; intro. - assert (H2 : (Rlength l1 + Rlength l2)%nat = 0%nat). + rewrite app_length; apply neq_O_lt; red; intro. + assert (H2 : (length l1 + length l2)%nat = 0%nat). symmetry ; apply H1. elim (plus_is_O _ _ H2); intros; rewrite H12 in H6; discriminate. unfold constant_D_eq, open_interval; intros; - elim (le_or_lt (S (S i)) (Rlength l1)); intro. - assert (H14 : pos_Rl (cons_Rlist l1 l2) i = pos_Rl l1 i). + elim (le_or_lt (S (S i)) (length l1)); intro. + assert (H14 : pos_Rl (app l1 l2) i = pos_Rl l1 i). apply RList_P26; apply lt_S_n; apply le_lt_n_Sm; apply le_S_n; - apply le_trans with (Rlength l1); [ assumption | apply le_n_Sn ]. - assert (H15 : pos_Rl (cons_Rlist l1 l2) (S i) = pos_Rl l1 (S i)). + apply le_trans with (length l1); [ assumption | apply le_n_Sn ]. + assert (H15 : pos_Rl (app l1 l2) (S i) = pos_Rl l1 (S i)). apply RList_P26; apply lt_S_n; apply le_lt_n_Sm; assumption. - rewrite H14 in H2; rewrite H15 in H2; assert (H16 : (2 <= Rlength l1)%nat). + rewrite H14 in H2; rewrite H15 in H2; assert (H16 : (2 <= length l1)%nat). apply le_trans with (S (S i)); [ repeat apply le_n_S; apply le_O_n | assumption ]. elim (RList_P20 _ H16); intros r1 [r2 [r3 H17]]; rewrite H17; change - (f x = pos_Rl (app_Rlist (mid_Rlist (cons_Rlist (cons r2 r3) l2) r1) f) i) + (f x = pos_Rl (map f (mid_Rlist (app (cons r2 r3) l2) r1)) i) ; rewrite RList_P12. induction i as [| i Hreci]. simpl; assert (H18 := H8 0%nat); unfold constant_D_eq, open_interval in H18; - assert (H19 : (0 < pred (Rlength l1))%nat). + assert (H19 : (0 < pred (length l1))%nat). rewrite H17; simpl; apply lt_O_Sn. assert (H20 := H18 H19); repeat rewrite H20. reflexivity. @@ -1991,14 +1997,14 @@ Proof. clear Hreci; rewrite RList_P13. rewrite H17 in H14; rewrite H17 in H15; change - (pos_Rl (cons_Rlist (cons r2 r3) l2) i = + (pos_Rl (app (cons r2 r3) l2) i = pos_Rl (cons r1 (cons r2 r3)) (S i)) in H14; rewrite H14; change - (pos_Rl (cons_Rlist (cons r2 r3) l2) (S i) = + (pos_Rl (app (cons r2 r3) l2) (S i) = pos_Rl (cons r1 (cons r2 r3)) (S (S i))) in H15; rewrite H15; assert (H18 := H8 (S i)); unfold constant_D_eq, open_interval in H18; - assert (H19 : (S i < pred (Rlength l1))%nat). + assert (H19 : (S i < pred (length l1))%nat). apply lt_pred; apply lt_S_n; apply le_lt_n_Sm; assumption. assert (H20 := H18 H19); repeat rewrite H20. reflexivity. @@ -2025,7 +2031,7 @@ Proof. simpl; rewrite H17 in H1; simpl in H1; apply lt_S_n; assumption. rewrite RList_P14; rewrite H17 in H1; simpl in H1; apply H1. inversion H12. - assert (H16 : pos_Rl (cons_Rlist l1 l2) (S i) = b). + assert (H16 : pos_Rl (app l1 l2) (S i) = b). rewrite RList_P29. rewrite H15; rewrite <- minus_n_n; rewrite H10; unfold Rmin; case (Rle_dec b c) as [|[]]; [ reflexivity | left; assumption ]. @@ -2033,30 +2039,30 @@ Proof. induction l1 as [| r l1 Hrecl1]. simpl in H15; discriminate. clear Hrecl1; simpl in H1; simpl; apply lt_n_S; assumption. - assert (H17 : pos_Rl (cons_Rlist l1 l2) i = b). + assert (H17 : pos_Rl (app l1 l2) i = b). rewrite RList_P26. - replace i with (pred (Rlength l1)); + replace i with (pred (length l1)); [ rewrite H4; unfold Rmax; case (Rle_dec a b) as [|[]]; [ reflexivity | left; assumption ] | rewrite H15; reflexivity ]. rewrite H15; apply lt_n_Sn. rewrite H16 in H2; rewrite H17 in H2; elim H2; intros; elim (Rlt_irrefl _ (Rlt_trans _ _ _ H14 H18)). - assert (H16 : pos_Rl (cons_Rlist l1 l2) i = pos_Rl l2 (i - Rlength l1)). + assert (H16 : pos_Rl (app l1 l2) i = pos_Rl l2 (i - length l1)). apply RList_P29. apply le_S_n; assumption. - apply lt_le_trans with (pred (Rlength (cons_Rlist l1 l2))); + apply lt_le_trans with (pred (length (app l1 l2))); [ assumption | apply le_pred_n ]. assert - (H17 : pos_Rl (cons_Rlist l1 l2) (S i) = pos_Rl l2 (S (i - Rlength l1))). - replace (S (i - Rlength l1)) with (S i - Rlength l1)%nat. + (H17 : pos_Rl (app l1 l2) (S i) = pos_Rl l2 (S (i - length l1))). + replace (S (i - length l1)) with (S i - length l1)%nat. apply RList_P29. apply le_S_n; apply le_trans with (S i); [ assumption | apply le_n_Sn ]. induction l1 as [| r l1 Hrecl1]. simpl in H6; discriminate. clear Hrecl1; simpl in H1; simpl; apply lt_n_S; assumption. symmetry ; apply minus_Sn_m; apply le_S_n; assumption. - assert (H18 : (2 <= Rlength l1)%nat). + assert (H18 : (2 <= length l1)%nat). clear f c l2 lf2 H0 H3 H8 H7 H10 H9 H11 H13 i H1 x H2 H12 m H14 H15 H16 H17; induction l1 as [| r l1 Hrecl1]. discriminate. @@ -2068,7 +2074,7 @@ Proof. clear Hrecl1; simpl; repeat apply le_n_S; apply le_O_n. elim (RList_P20 _ H18); intros r1 [r2 [r3 H19]]; rewrite H19; change - (f x = pos_Rl (app_Rlist (mid_Rlist (cons_Rlist (cons r2 r3) l2) r1) f) i) + (f x = pos_Rl (map f (mid_Rlist (app (cons r2 r3) l2) r1)) i) ; rewrite RList_P12. induction i as [| i Hreci]. assert (H20 := le_S_n _ _ H15); assert (H21 := le_trans _ _ _ H18 H20); @@ -2076,31 +2082,31 @@ Proof. clear Hreci; rewrite RList_P13. rewrite H19 in H16; rewrite H19 in H17; change - (pos_Rl (cons_Rlist (cons r2 r3) l2) i = - pos_Rl l2 (S i - Rlength (cons r1 (cons r2 r3)))) + (pos_Rl (app (cons r2 r3) l2) i = + pos_Rl l2 (S i - length (cons r1 (cons r2 r3)))) in H16; rewrite H16; change - (pos_Rl (cons_Rlist (cons r2 r3) l2) (S i) = - pos_Rl l2 (S (S i - Rlength (cons r1 (cons r2 r3))))) - in H17; rewrite H17; assert (H20 := H13 (S i - Rlength l1)%nat); + (pos_Rl (app (cons r2 r3) l2) (S i) = + pos_Rl l2 (S (S i - length (cons r1 (cons r2 r3))))) + in H17; rewrite H17; assert (H20 := H13 (S i - length l1)%nat); unfold constant_D_eq, open_interval in H20; - assert (H21 : (S i - Rlength l1 < pred (Rlength l2))%nat). + assert (H21 : (S i - length l1 < pred (length l2))%nat). apply lt_pred; rewrite minus_Sn_m. - apply plus_lt_reg_l with (Rlength l1); rewrite <- le_plus_minus. + apply plus_lt_reg_l with (length l1); rewrite <- le_plus_minus. rewrite H19 in H1; simpl in H1; rewrite H19; simpl; - rewrite RList_P23 in H1; apply lt_n_S; assumption. + rewrite app_length in H1; apply lt_n_S; assumption. apply le_trans with (S i); [ apply le_S_n; assumption | apply le_n_Sn ]. apply le_S_n; assumption. assert (H22 := H20 H21); repeat rewrite H22. reflexivity. rewrite <- H19; assert - (H23 : pos_Rl l2 (S i - Rlength l1) <= pos_Rl l2 (S (S i - Rlength l1))). + (H23 : pos_Rl l2 (S i - length l1) <= pos_Rl l2 (S (S i - length l1))). apply H7; apply lt_pred. rewrite minus_Sn_m. - apply plus_lt_reg_l with (Rlength l1); rewrite <- le_plus_minus. + apply plus_lt_reg_l with (length l1); rewrite <- le_plus_minus. rewrite H19 in H1; simpl in H1; rewrite H19; simpl; - rewrite RList_P23 in H1; apply lt_n_S; assumption. + rewrite app_length in H1; apply lt_n_S; assumption. apply le_trans with (S i); [ apply le_S_n; assumption | apply le_n_Sn ]. apply le_S_n; assumption. elim H23; intro. @@ -2115,7 +2121,7 @@ Proof. [ prove_sup0 | unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym; - [ rewrite Rmult_1_l; rewrite (Rplus_comm (pos_Rl l2 (S i - Rlength l1))); + [ rewrite Rmult_1_l; rewrite (Rplus_comm (pos_Rl l2 (S i - length l1))); rewrite double; apply Rplus_lt_compat_l; assumption | discrR ] ]. rewrite <- H19 in H16; rewrite <- H19 in H17; elim H2; intros; @@ -2123,11 +2129,11 @@ Proof. simpl in H16; rewrite H16 in H25; simpl in H26; simpl in H17; rewrite H17 in H26; simpl in H24; rewrite H24 in H25; elim (Rlt_irrefl _ (Rlt_trans _ _ _ H25 H26)). - assert (H23 : pos_Rl (cons_Rlist l1 l2) (S i) = pos_Rl l2 (S i - Rlength l1)). + assert (H23 : pos_Rl (app l1 l2) (S i) = pos_Rl l2 (S i - length l1)). rewrite H19; simpl; simpl in H16; apply H16. assert (H24 : - pos_Rl (cons_Rlist l1 l2) (S (S i)) = pos_Rl l2 (S (S i - Rlength l1))). + pos_Rl (app l1 l2) (S (S i)) = pos_Rl l2 (S (S i - length l1))). rewrite H19; simpl; simpl in H17; apply H17. rewrite <- H23; rewrite <- H24; assumption. simpl; rewrite H19 in H1; simpl in H1; apply lt_S_n; assumption. @@ -2141,7 +2147,7 @@ Proof. intros f a b c H H0 (l1,(lf1,H1)) (l2,(lf2,H2)); destruct (total_order_T a b) as [[Hltab|Hab]|Hgtab]. destruct (total_order_T b c) as [[Hltbc|Hbc]|Hgtbc]. - exists (cons_Rlist l1 l2); exists (FF (cons_Rlist l1 l2) f); + exists (app l1 l2); exists (FF (app l1 l2) f); apply StepFun_P40 with b lf1 lf2; assumption. exists l1; exists lf1; rewrite Hbc in H1; assumption. elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 Hgtbc)). @@ -2150,9 +2156,9 @@ Proof. Qed. Lemma StepFun_P42 : - forall (l1 l2:Rlist) (f:R -> R), - pos_Rl l1 (pred (Rlength l1)) = pos_Rl l2 0 -> - Int_SF (FF (cons_Rlist l1 l2) f) (cons_Rlist l1 l2) = + forall (l1 l2:list R) (f:R -> R), + pos_Rl l1 (pred (length l1)) = pos_Rl l2 0 -> + Int_SF (FF (app l1 l2) f) (app l1 l2) = Int_SF (FF l1 f) l1 + Int_SF (FF l2 f) l2. Proof. intros l1 l2 f; induction l1 as [| r l1 IHl1]; intros H; @@ -2193,7 +2199,7 @@ Proof. elim Hle; intro. elim Hle'; intro. replace (Int_SF lf3 l3) with - (Int_SF (FF (cons_Rlist l1 l2) f) (cons_Rlist l1 l2)). + (Int_SF (FF (app l1 l2) f) (app l1 l2)). replace (Int_SF lf1 l1) with (Int_SF (FF l1 f) l1). replace (Int_SF lf2 l2) with (Int_SF (FF l2 f) l2). symmetry ; apply StepFun_P42. @@ -2225,7 +2231,7 @@ Proof. elim Hle''; intro. rewrite Rplus_comm; replace (Int_SF lf1 l1) with - (Int_SF (FF (cons_Rlist l3 l2) f) (cons_Rlist l3 l2)). + (Int_SF (FF (app l3 l2) f) (app l3 l2)). replace (Int_SF lf3 l3) with (Int_SF (FF l3 f) l3). replace (Int_SF lf2 l2) with (Int_SF (FF l2 f) l2). apply StepFun_P42. @@ -2249,7 +2255,7 @@ Proof. ring. elim Hle; intro. replace (Int_SF lf2 l2) with - (Int_SF (FF (cons_Rlist l3 l1) f) (cons_Rlist l3 l1)). + (Int_SF (FF (app l3 l1) f) (app l3 l1)). replace (Int_SF lf3 l3) with (Int_SF (FF l3 f) l3). replace (Int_SF lf1 l1) with (Int_SF (FF l1 f) l1). symmetry ; apply StepFun_P42. @@ -2277,7 +2283,7 @@ Proof. ring. rewrite Rplus_comm; elim Hle''; intro. replace (Int_SF lf2 l2) with - (Int_SF (FF (cons_Rlist l1 l3) f) (cons_Rlist l1 l3)). + (Int_SF (FF (app l1 l3) f) (app l1 l3)). replace (Int_SF lf3 l3) with (Int_SF (FF l3 f) l3). replace (Int_SF lf1 l1) with (Int_SF (FF l1 f) l1). symmetry ; apply StepFun_P42. @@ -2304,7 +2310,7 @@ Proof. ring. elim Hle'; intro. replace (Int_SF lf1 l1) with - (Int_SF (FF (cons_Rlist l2 l3) f) (cons_Rlist l2 l3)). + (Int_SF (FF (app l2 l3) f) (app l2 l3)). replace (Int_SF lf3 l3) with (Int_SF (FF l3 f) l3). replace (Int_SF lf2 l2) with (Int_SF (FF l2 f) l2). symmetry ; apply StepFun_P42. @@ -2334,7 +2340,7 @@ Proof. replace (Int_SF lf3 l3) with (Int_SF lf2 l2 + Int_SF lf1 l1). ring. replace (Int_SF lf3 l3) with - (Int_SF (FF (cons_Rlist l2 l1) f) (cons_Rlist l2 l1)). + (Int_SF (FF (app l2 l1) f) (app l2 l1)). replace (Int_SF lf1 l1) with (Int_SF (FF l1 f) l1). replace (Int_SF lf2 l2) with (Int_SF (FF l2 f) l2). symmetry ; apply StepFun_P42. @@ -2395,17 +2401,17 @@ Proof. elim H; clear H; intros; unfold IsStepFun in X; unfold is_subdivision in X; elim X; clear X; intros l1 [lf1 H2]; cut - (forall (l1 lf1:Rlist) (a b c:R) (f:R -> R), + (forall (l1 lf1:list R) (a b c:R) (f:R -> R), adapted_couple f a b l1 lf1 -> a <= c <= b -> - { l:Rlist & { l0:Rlist & adapted_couple f a c l l0 } }). + { l:list R & { l0:list R & adapted_couple f a c l l0 } }). intro X; unfold IsStepFun; unfold is_subdivision; eapply X. apply H2. split; assumption. clear f a b c H0 H H1 H2 l1 lf1; simple induction l1. intros; unfold adapted_couple in H; decompose [and] H; clear H; simpl in H4; discriminate. - simple induction r0. + intros r r0; elim r0. intros X lf1 a b c f H H0; assert (H1 : a = b). unfold adapted_couple in H; decompose [and] H; clear H; simpl in H3; simpl in H2; assert (H7 : a <= b). @@ -2438,7 +2444,7 @@ Proof. unfold constant_D_eq, open_interval; intros; simpl in H8; inversion H8. simpl; assert (H10 := H7 0%nat); - assert (H12 : (0 < pred (Rlength (cons r (cons r1 r2))))%nat). + assert (H12 : (0 < pred (length (cons r (cons r1 r2))))%nat). simpl; apply lt_O_Sn. apply (H10 H12); unfold open_interval; simpl; rewrite H11 in H9; simpl in H9; elim H9; clear H9; @@ -2479,7 +2485,7 @@ Proof. intros; simpl in H; unfold constant_D_eq, open_interval; intros; induction i as [| i Hreci]. simpl; assert (H17 := H10 0%nat); - assert (H18 : (0 < pred (Rlength (cons r (cons r1 r2))))%nat). + assert (H18 : (0 < pred (length (cons r (cons r1 r2))))%nat). simpl; apply lt_O_Sn. apply (H17 H18); unfold open_interval; simpl; simpl in H4; elim H4; clear H4; intros; split; try assumption; @@ -2507,16 +2513,16 @@ Proof. elim H; clear H; intros; unfold IsStepFun in X; unfold is_subdivision in X; elim X; clear X; intros l1 [lf1 H2]; cut - (forall (l1 lf1:Rlist) (a b c:R) (f:R -> R), + (forall (l1 lf1:list R) (a b c:R) (f:R -> R), adapted_couple f a b l1 lf1 -> a <= c <= b -> - { l:Rlist & { l0:Rlist & adapted_couple f c b l l0 } }). + { l:list R & { l0:list R & adapted_couple f c b l l0 } }). intro X; unfold IsStepFun; unfold is_subdivision; eapply X; [ apply H2 | split; assumption ]. clear f a b c H0 H H1 H2 l1 lf1; simple induction l1. intros; unfold adapted_couple in H; decompose [and] H; clear H; simpl in H4; discriminate. - simple induction r0. + intros r r0; elim r0. intros X lf1 a b c f H H0; assert (H1 : a = b). unfold adapted_couple in H; decompose [and] H; clear H; simpl in H3; simpl in H2; assert (H7 : a <= b). diff --git a/theories/Reals/Rtopology.v b/theories/Reals/Rtopology.v index d21042884e..fa5442e86f 100644 --- a/theories/Reals/Rtopology.v +++ b/theories/Reals/Rtopology.v @@ -12,6 +12,7 @@ Require Import Rbase. Require Import Rfunctions. Require Import Ranalysis1. Require Import RList. +Require Import List. Require Import Classical_Prop. Require Import Classical_Pred_Type. Local Open Scope R_scope. @@ -388,7 +389,7 @@ Record family : Type := mkfamily Definition family_open_set (f:family) : Prop := forall x:R, open_set (f x). Definition domain_finite (D:R -> Prop) : Prop := - exists l : Rlist, (forall x:R, D x <-> In x l). + exists l : list R, (forall x:R, D x <-> In x l). Definition family_finite (f:family) : Prop := domain_finite (ind f). @@ -669,7 +670,7 @@ Proof. intro H14; simpl in H14; unfold intersection_domain in H14; specialize H13 with x0; destruct H13 as (H13,H15); destruct (Req_dec x0 y0) as [H16|H16]. - simpl; left; apply H16. + simpl; left. symmetry; apply H16. simpl; right; apply H13. simpl; unfold intersection_domain; unfold Db in H14; decompose [and or] H14. @@ -678,8 +679,8 @@ Proof. intro H14; simpl in H14; destruct H14 as [H15|H15]; simpl; unfold intersection_domain. split. - apply (cond_fam f0); rewrite H15; exists b; apply H6. - unfold Db; right; assumption. + apply (cond_fam f0); rewrite <- H15; exists b; apply H6. + unfold Db; right; symmetry; assumption. simpl; unfold intersection_domain; elim (H13 x0). intros _ H16; assert (H17 := H16 H15); simpl in H17; unfold intersection_domain in H17; split. @@ -750,15 +751,15 @@ Proof. intro H14; simpl in H14; unfold intersection_domain in H14; specialize (H13 x0); destruct H13 as (H13,H15); destruct (Req_dec x0 y0) as [Heq|Hneq]. - simpl; left; apply Heq. + simpl; left; symmetry; apply Heq. simpl; right; apply H13; simpl; unfold intersection_domain; unfold Db in H14; decompose [and or] H14. split; assumption. elim Hneq; assumption. intros [H15|H15]. split. - apply (cond_fam f0); rewrite H15; exists m; apply H6. - unfold Db; right; assumption. + apply (cond_fam f0); rewrite <- H15; exists m; apply H6. + unfold Db; right; symmetry; assumption. elim (H13 x0); intros _ H16. assert (H17 := H16 H15). simpl in H17. @@ -810,9 +811,10 @@ Proof. unfold family_finite; unfold domain_finite; exists (cons y0 nil); intro; split. simpl; unfold intersection_domain; intros (H3,H4). - unfold D' in H4; left; apply H4. + unfold D' in H4; left; symmetry; apply H4. simpl; unfold intersection_domain; intros [H4|[]]. - split; [ rewrite H4; apply (cond_fam f0); exists a; apply H2 | apply H4 ]. + split; [ rewrite <- H4; apply (cond_fam f0); exists a; apply H2 | + symmetry; apply H4 ]. split; [ right; reflexivity | apply Hle ]. apply compact_eqDom with (fun c:R => False). apply compact_EMP. diff --git a/tools/coqdep.ml b/tools/coqdep.ml index 2140014c58..950c784325 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -9,9 +9,8 @@ (************************************************************************) open Format -open Coqdep_lexer -open Coqdep_common open Minisys +open Coqdep_common (** The basic parts of coqdep (i.e. the parts used by [coqdep -boot]) are now in [Coqdep_common]. The code that remains here concerns @@ -20,7 +19,6 @@ open Minisys As of today, this module depends on the following Coq modules: - - Flags - Envars - CoqProject_file @@ -28,424 +26,12 @@ open Minisys coqlib handling up so this can be bootstrapped earlier. *) -let option_D = ref false -let option_w = ref false let option_sort = ref false -let option_dump = ref None - -let warning_mult suf iter = - let tab = Hashtbl.create 151 in - let check f d = - begin try - let d' = Hashtbl.find tab f in - if (Filename.dirname (file_name f d)) - <> (Filename.dirname (file_name f d')) then begin - coqdep_warning "the file %s is defined twice!" (f ^ suf) - end - with Not_found -> () end; - Hashtbl.add tab f d - in - iter check - -let sort () = - let seen = Hashtbl.create 97 in - let rec loop file = - let file = canonize file in - if not (Hashtbl.mem seen file) then begin - Hashtbl.add seen file (); - let cin = open_in (file ^ ".v") in - let lb = Lexing.from_channel cin in - try - while true do - match coq_action lb with - | Require (from, sl) -> - List.iter - (fun s -> - match search_v_known ?from s with - | None -> () - | Some f -> loop f) - sl - | _ -> () - done - with Fin_fichier -> - close_in cin; - printf "%s%s " file !suffixe - end - in - List.iter (fun (name,_) -> loop name) !vAccu - -let (dep_tab : (string,string list) Hashtbl.t) = Hashtbl.create 151 - -let mL_dep_list b f = - try - Hashtbl.find dep_tab f - with Not_found -> - let deja_vu = ref ([] : string list) in - try - let chan = open_in f in - let buf = Lexing.from_channel chan in - try - while true do - let (Use_module str) = caml_action buf in - if str = b then begin - coqdep_warning "in file %s the notation %s. is useless !\n" f b - end else - if not (List.mem str !deja_vu) then addQueue deja_vu str - done; [] - with Fin_fichier -> begin - close_in chan; - let rl = List.rev !deja_vu in - Hashtbl.add dep_tab f rl; - rl - end - with Sys_error _ -> [] - -let affiche_Declare f dcl = - printf "\n*** In file %s: \n" f; - printf "Declare ML Module"; - List.iter (fun str -> printf " \"%s\"" str) dcl; - printf ".\n%!" - -let warning_Declare f dcl = - eprintf "*** Warning : in file %s, the ML modules declaration should be\n" f; - eprintf "*** Declare ML Module"; - List.iter (fun str -> eprintf " \"%s\"" str) dcl; - eprintf ".\n%!" - -let traite_Declare f = - let decl_list = ref ([] : string list) in - let rec treat = function - | s :: ll -> - let s' = basename_noext s in - (match search_ml_known s with - | Some mldir when not (List.mem s' !decl_list) -> - let fullname = file_name s' mldir in - let depl = mL_dep_list s (fullname ^ ".ml") in - treat depl; - decl_list := s :: !decl_list - | _ -> ()); - treat ll - | [] -> () - in - try - let chan = open_in f in - let buf = Lexing.from_channel chan in - begin try - while true do - let tok = coq_action buf in - (match tok with - | Declare sl -> - decl_list := []; - treat sl; - decl_list := List.rev !decl_list; - if !option_D then - affiche_Declare f !decl_list - else if !decl_list <> sl then - warning_Declare f !decl_list - | _ -> ()) - done - with Fin_fichier -> () end; - close_in chan - with Sys_error _ -> () - -let declare_dependencies () = - List.iter - (fun (name,_) -> - traite_Declare (name^".v"); - pp_print_flush std_formatter ()) - (List.rev !vAccu) - -(** DAGs guaranteed to be transitive reductions *) -module DAG (Node : Set.OrderedType) : -sig - type node = Node.t - type t - val empty : t - val add_transitive_edge : node -> node -> t -> t - val iter : (node -> node -> unit) -> t -> unit -end = -struct - type node = Node.t - module NSet = Set.Make(Node) - module NMap = Map.Make(Node) - - (** Associate to a node the set of its neighbours *) - type _t = NSet.t NMap.t - - (** Optimisation: construct the reverse graph at the same time *) - type t = { dir : _t; rev : _t; } - - - let node_equal x y = Node.compare x y = 0 - - let add_edge x y graph = - let set = try NMap.find x graph with Not_found -> NSet.empty in - NMap.add x (NSet.add y set) graph - - let remove_edge x y graph = - let set = try NMap.find x graph with Not_found -> NSet.empty in - let set = NSet.remove y set in - if NSet.is_empty set then NMap.remove x graph - else NMap.add x set graph - - let has_edge x y graph = - let set = try NMap.find x graph with Not_found -> NSet.empty in - NSet.mem y set - - let connected x y graph = - let rec aux rem seen = - if NSet.is_empty rem then false - else - let x = NSet.choose rem in - if node_equal x y then true - else - let rem = NSet.remove x rem in - if NSet.mem x seen then - aux rem seen - else - let seen = NSet.add x seen in - let next = try NMap.find x graph with Not_found -> NSet.empty in - let rem = NSet.union next rem in - aux rem seen - in - aux (NSet.singleton x) NSet.empty - - (** Check whether there is a path from a to b going through the edge - x -> y. *) - let connected_through a b x y graph = - let rec aux rem seen = - if NMap.is_empty rem then false - else - let (n, through) = NMap.choose rem in - if node_equal n b && through then true - else - let rem = NMap.remove n rem in - let is_seen = try Some (NMap.find n seen) with Not_found -> None in - match is_seen with - | None -> - let seen = NMap.add n through seen in - let next = try NMap.find n graph with Not_found -> NSet.empty in - let is_x = node_equal n x in - let push m accu = - let through = through || (is_x && node_equal m y) in - NMap.add m through accu - in - let rem = NSet.fold push next rem in - aux rem seen - | Some false -> - (* The path we took encountered x -> y but not the one in seen *) - if through then aux (NMap.add n true rem) (NMap.add n true seen) - else aux rem seen - | Some true -> aux rem seen - in - aux (NMap.singleton a false) NMap.empty - - let closure x graph = - let rec aux rem seen = - if NSet.is_empty rem then seen - else - let x = NSet.choose rem in - let rem = NSet.remove x rem in - if NSet.mem x seen then - aux rem seen - else - let seen = NSet.add x seen in - let next = try NMap.find x graph with Not_found -> NSet.empty in - let rem = NSet.union next rem in - aux rem seen - in - aux (NSet.singleton x) NSet.empty - - let empty = { dir = NMap.empty; rev = NMap.empty; } - - (** Online transitive reduction algorithm *) - let add_transitive_edge x y graph = - if connected x y graph.dir then graph - else - let dir = add_edge x y graph.dir in - let rev = add_edge y x graph.rev in - let graph = { dir; rev; } in - let ancestors = closure x rev in - let descendents = closure y dir in - let fold_ancestor a graph = - let fold_descendent b graph = - let to_remove = has_edge a b graph.dir in - let to_remove = to_remove && not (node_equal x a && node_equal y b) in - let to_remove = to_remove && connected_through a b x y graph.dir in - if to_remove then - let dir = remove_edge a b graph.dir in - let rev = remove_edge b a graph.rev in - { dir; rev; } - else graph - in - NSet.fold fold_descendent descendents graph - in - NSet.fold fold_ancestor ancestors graph - - let iter f graph = - let iter x set = NSet.iter (fun y -> f x y) set in - NMap.iter iter graph.dir - -end - -module Graph = -struct -(** Dumping a dependency graph **) - -module DAG = DAG(struct type t = string let compare = compare end) - -(** TODO: we should share this code with Coqdep_common *) -module VData = struct - type t = string list option * string list - let compare = Util.pervasives_compare -end - -module VCache = Set.Make(VData) - -let treat_coq_file chan = - let buf = Lexing.from_channel chan in - let deja_vu_v = ref VCache.empty in - let deja_vu_ml = ref StrSet.empty in - let mark_v_done from acc str = - let seen = VCache.mem (from, str) !deja_vu_v in - if not seen then - let () = deja_vu_v := VCache.add (from, str) !deja_vu_v in - match search_v_known ?from str with - | None -> acc - | Some file_str -> (canonize file_str, !suffixe) :: acc - else acc - in - let rec loop acc = - let token = try Some (coq_action buf) with Fin_fichier -> None in - match token with - | None -> acc - | Some action -> - let acc = match action with - | Require (from, strl) -> - List.fold_left (fun accu v -> mark_v_done from accu v) acc strl - | Declare sl -> - let declare suff dir s = - let base = escape (file_name s dir) in - match !option_dynlink with - | No -> [] - | Byte -> [base,suff] - | Opt -> [base,".cmxs"] - | Both -> [base,suff; base,".cmxs"] - | Variable -> - if suff=".cmo" then [base,"$(DYNOBJ)"] - else [base,"$(DYNLIB)"] - in - let decl acc str = - let s = basename_noext str in - if not (StrSet.mem s !deja_vu_ml) then - let () = deja_vu_ml := StrSet.add s !deja_vu_ml in - match search_mllib_known s with - | Some mldir -> (declare ".cma" mldir s) @ acc - | None -> - match search_ml_known s with - | Some mldir -> (declare ".cmo" mldir s) @ acc - | None -> acc - else acc - in - List.fold_left decl acc sl - | Load str -> - let str = Filename.basename str in - let seen = VCache.mem (None, [str]) !deja_vu_v in - if not seen then - let () = deja_vu_v := VCache.add (None, [str]) !deja_vu_v in - match search_v_known [str] with - | None -> acc - | Some file_str -> (canonize file_str, ".v") :: acc - else acc - | AddLoadPath _ | AddRecLoadPath _ -> acc (* TODO *) - in - loop acc - in - loop [] - -let treat_coq_file f = - let chan = try Some (open_in f) with Sys_error _ -> None in - match chan with - | None -> [] - | Some chan -> - try - let ans = treat_coq_file chan in - let () = close_in chan in - ans - with Syntax_error (i, j) -> close_in chan; error_cannot_parse f (i, j) - -type graph = - | Element of string - | Subgraph of string * graph list - -let rec insert_graph name path graphs = match path, graphs with - | [] , graphs -> (Element name) :: graphs - | (box :: boxes), (Subgraph (hd, names)) :: tl when hd = box -> - Subgraph (hd, insert_graph name boxes names) :: tl - | _, hd :: tl -> hd :: (insert_graph name path tl) - | (box :: boxes), [] -> [ Subgraph (box, insert_graph name boxes []) ] - -let print_graphs chan graph = - let rec print_aux name = function - | [] -> name - | (Element str) :: tl -> fprintf chan "\"%s\";\n" str; print_aux name tl - | Subgraph (box, names) :: tl -> - fprintf chan "subgraph cluster%n {\nlabel=\"%s\";\n" name box; - let name = print_aux (name + 1) names in - fprintf chan "}\n"; print_aux name tl - in - ignore (print_aux 0 graph) - -let rec pop_common_prefix = function - | [Subgraph (_, graphs)] -> pop_common_prefix graphs - | graphs -> graphs - -let split_path = Str.split (Str.regexp "/") - -let rec pop_last = function - | [] -> [] - | [ x ] -> [] - | x :: xs -> x :: pop_last xs - -let get_boxes path = pop_last (split_path path) - -let insert_raw_graph file = - insert_graph file (get_boxes file) - -let rec get_dependencies name args = - let vdep = treat_coq_file (name ^ ".v") in - let fold (deps, graphs, alseen) (dep, _) = - let dag = DAG.add_transitive_edge name dep deps in - if not (List.mem dep alseen) then - get_dependencies dep (dag, insert_raw_graph dep graphs, dep :: alseen) - else - (dag, graphs, alseen) - in - List.fold_left fold args vdep - -let coq_dependencies_dump chan dumpboxes = - let (deps, graphs, _) = - List.fold_left (fun ih (name, _) -> get_dependencies name ih) - (DAG.empty, List.fold_left (fun ih (file, _) -> insert_raw_graph file ih) [] !vAccu, - List.map fst !vAccu) !vAccu - in - fprintf chan "digraph dependencies {\n"; - if dumpboxes then print_graphs chan (pop_common_prefix graphs) - else List.iter (fun (name, _) -> fprintf chan "\"%s\"[label=\"%s\"]\n" name (basename_noext name)) !vAccu; - DAG.iter (fun name dep -> fprintf chan "\"%s\" -> \"%s\"\n" dep name) deps; - fprintf chan "}\n%!" - -end let usage () = eprintf " usage: coqdep [options] <filename>+\n"; eprintf " options:\n"; eprintf " -c : Also print the dependencies of caml modules (=ocamldep).\n"; - (* Does not work anymore *) - (* eprintf " -w : Print informations on missing or wrong \"Declare - ML Module\" commands in coq files.\n"; *) - (* Does not work anymore: *) - (* eprintf " -D : Prints the missing ocmal module names. No dependency computed.\n"; *) eprintf " -boot : For coq developers, prints dependencies over coq library files (omitted by default).\n"; eprintf " -sort : output the given file name ordered by dependencies\n"; eprintf " -noglob | -no-glob : \n"; @@ -456,8 +42,6 @@ let usage () = eprintf " -R dir logname : add and import dir recursively to coq load path under logical name logname\n"; eprintf " -Q dir logname : add (recursively) and open (non recursively) dir to coq load path under logical name logname\n"; eprintf " -vos : also output dependencies about .vos files\n"; - eprintf " -dumpgraph f : print a dot dependency graph in file 'f'\n"; - eprintf " -dumpgraphbox f : print a dot dependency graph box in file 'f'\n"; eprintf " -exclude-dir dir : skip subdirectories named 'dir' during -R/-Q search\n"; eprintf " -coqlib dir : set the coq standard library directory\n"; eprintf " -suffix s : \n"; @@ -468,7 +52,6 @@ let usage () = let split_period = Str.split (Str.regexp (Str.quote ".")) let add_q_include path l = add_rec_dir_no_import add_known path (split_period l) - let add_r_include path l = add_rec_dir_import add_known path (split_period l) let treat_coqproject f = @@ -482,9 +65,8 @@ let treat_coqproject f = iter_sourced (fun f -> treat_file None f) (all_files project) let rec parse = function + (* TODO, deprecate option -c *) | "-c" :: ll -> option_c := true; parse ll - | "-D" :: ll -> option_D := true; parse ll - | "-w" :: ll -> option_w := true; parse ll | "-boot" :: ll -> option_boot := true; parse ll | "-sort" :: ll -> option_sort := true; parse ll | "-vos" :: ll -> write_vos := true; parse ll @@ -495,17 +77,12 @@ let rec parse = function | "-R" :: r :: ln :: ll -> add_r_include r ln; parse ll | "-Q" :: r :: ln :: ll -> add_q_include r ln; parse ll | "-R" :: ([] | [_]) -> usage () - | "-dumpgraph" :: f :: ll -> option_dump := Some (false, f); parse ll - | "-dumpgraphbox" :: f :: ll -> option_dump := Some (true, f); parse ll | "-exclude-dir" :: r :: ll -> System.exclude_directory r; parse ll | "-exclude-dir" :: [] -> usage () | "-coqlib" :: r :: ll -> Envars.set_user_coqlib r; parse ll | "-coqlib" :: [] -> usage () | "-suffix" :: s :: ll -> suffixe := s ; parse ll | "-suffix" :: [] -> usage () - | "-slash" :: ll -> - coqdep_warning "warning: option -slash has no effect and is deprecated."; - parse ll | "-dyndep" :: "no" :: ll -> option_dynlink := No; parse ll | "-dyndep" :: "opt" :: ll -> option_dynlink := Opt; parse ll | "-dyndep" :: "byte" :: ll -> option_dynlink := Byte; parse ll @@ -525,19 +102,8 @@ let coqdep () = (* Add current dir with empty logical path if not set by options above. *) (try ignore (Coqdep_common.find_dir_logpath (Sys.getcwd())) with Not_found -> add_norec_dir_import add_known "." []); - (* NOTE: These directories are searched from last to first *) - if !option_boot then begin - add_rec_dir_import add_known "theories" ["Coq"]; - add_rec_dir_import add_known "plugins" ["Coq"]; - add_rec_dir_import (fun _ -> add_caml_known) "theories" ["Coq"]; - add_rec_dir_import (fun _ -> add_caml_known) "plugins" ["Coq"]; - let user = "user-contrib" in - if Sys.file_exists user then begin - add_rec_dir_no_import add_known user []; - add_rec_dir_no_import (fun _ -> add_caml_known) user []; - end; - end else begin - (* option_boot is actually always false in this branch *) + (* We don't setup any loadpath if the -boot is passed *) + if not !option_boot then begin Envars.set_coqlib ~fail:(fun msg -> raise (CoqlibError msg)); let coqlib = Envars.coqlib () in add_rec_dir_import add_coqlib_known (coqlib//"theories") ["Coq"]; @@ -551,20 +117,10 @@ let coqdep () = List.iter (fun (f,d) -> add_mli_known f d ".mli") !mliAccu; List.iter (fun (f,d) -> add_mllib_known f d ".mllib") !mllibAccu; List.iter (fun (f,suff,d) -> add_ml_known f d suff) !mlAccu; - warning_mult ".mli" iter_mli_known; - warning_mult ".ml" iter_ml_known; if !option_sort then begin sort (); exit 0 end; - if !option_c && not !option_D then mL_dependencies (); - if not !option_D then coq_dependencies (); - if !option_w || !option_D then declare_dependencies (); - begin match !option_dump with - | None -> () - | Some (box, file) -> - let chan = open_out file in - let chan_fmt = formatter_of_out_channel chan in - try Graph.coq_dependencies_dump chan_fmt box; close_out chan - with e -> close_out chan; raise e - end + if !option_c then mL_dependencies (); + coq_dependencies (); + () let _ = try diff --git a/tools/coqdep_boot.ml b/tools/coqdep_boot.ml index 1730dd3d68..1cebb3638e 100644 --- a/tools/coqdep_boot.ml +++ b/tools/coqdep_boot.ml @@ -19,6 +19,7 @@ open Coqdep_common let split_period = Str.split (Str.regexp (Str.quote ".")) let add_q_include path l = add_rec_dir_no_import add_known path (split_period l) +let add_r_include path l = add_rec_dir_import add_known path (split_period l) let rec parse = function | "-dyndep" :: "no" :: ll -> option_dynlink := No; parse ll @@ -26,16 +27,14 @@ let rec parse = function | "-dyndep" :: "byte" :: ll -> option_dynlink := Byte; parse ll | "-dyndep" :: "both" :: ll -> option_dynlink := Both; parse ll | "-dyndep" :: "var" :: ll -> option_dynlink := Variable; parse ll - | "-c" :: ll -> option_c := true; parse ll | "-boot" :: ll -> parse ll (* We're already in boot mode by default *) - | "-mldep" :: ocamldep :: ll -> - option_mldep := Some ocamldep; option_c := true; parse ll | "-I" :: r :: ll -> (* To solve conflict (e.g. same filename in kernel and checker) we allow to state an explicit order *) add_caml_dir r; norec_dirs := StrSet.add r !norec_dirs; parse ll + | "-R" :: r :: ln :: ll -> add_r_include r ln; parse ll | "-Q" :: r :: ln :: ll -> add_q_include r ln; parse ll | f :: ll -> treat_file None f; parse ll | [] -> () @@ -44,16 +43,4 @@ let _ = let () = option_boot := true in if Array.length Sys.argv < 2 then exit 1; parse (List.tl (Array.to_list Sys.argv)); - if !option_c then begin - add_rec_dir_import add_known "." []; - add_rec_dir_import (fun _ -> add_caml_known) "." ["Coq"]; - end - else begin - add_rec_dir_import add_known "theories" ["Coq"]; - add_rec_dir_import add_known "plugins" ["Coq"]; - add_caml_dir "tactics"; - add_rec_dir_import (fun _ -> add_caml_known) "theories" ["Coq"]; - add_rec_dir_import (fun _ -> add_caml_known) "plugins" ["Coq"]; - end; - if !option_c then mL_dependencies (); coq_dependencies () diff --git a/tools/coqdep_common.ml b/tools/coqdep_common.ml index 775c528176..5ece595f13 100644 --- a/tools/coqdep_common.ml +++ b/tools/coqdep_common.ml @@ -35,7 +35,6 @@ let option_c = ref false let option_noglob = ref false let option_dynlink = ref Both let option_boot = ref false -let option_mldep = ref None let norec_dirs = ref StrSet.empty @@ -126,8 +125,8 @@ let mkknown () = with Not_found -> None in add, iter, search -let add_ml_known, iter_ml_known, search_ml_known = mkknown () -let add_mli_known, iter_mli_known, search_mli_known = mkknown () +let add_ml_known, _, search_ml_known = mkknown () +let add_mli_known, _, search_mli_known = mkknown () let add_mllib_known, _, search_mllib_known = mkknown () let add_mlpack_known, _, search_mlpack_known = mkknown () @@ -246,26 +245,7 @@ let depend_ML str = (" "^mlifile^".cmi"," "^mlifile^".cmi") | None, None -> "", "" -let soustraite_fichier_ML dep md ext = - try - let chan = open_process_in (dep^" -modules "^md^ext) in - let list = ocamldep_parse (Lexing.from_channel chan) in - let a_faire = ref "" in - let a_faire_opt = ref "" in - List.iter - (fun str -> - let byte,opt = depend_ML str in - a_faire := !a_faire ^ byte; - a_faire_opt := !a_faire_opt ^ opt) - (List.rev list); - (!a_faire, !a_faire_opt) - with - | Sys_error _ -> ("","") - | _ -> - Printf.eprintf "Coqdep: subprocess %s failed on file %s%s\n" dep md ext; - exit 1 - -let autotraite_fichier_ML md ext = +let traite_fichier_ML md ext = try let chan = open_in (md ^ ext) in let buf = Lexing.from_channel chan in @@ -290,11 +270,6 @@ let autotraite_fichier_ML md ext = (!a_faire, !a_faire_opt) with Sys_error _ -> ("","") -let traite_fichier_ML md ext = - match !option_mldep with - | Some dep -> soustraite_fichier_ML dep md ext - | None -> autotraite_fichier_ML md ext - let traite_fichier_modules md ext = try let chan = open_in (md ^ ext) in @@ -641,3 +616,30 @@ let rec treat_file old_dirname old_name = | (base,".mlpack") -> addQueue mlpackAccu (base,dirname) | _ -> ()) | _ -> () + +let sort () = + let seen = Hashtbl.create 97 in + let rec loop file = + let file = canonize file in + if not (Hashtbl.mem seen file) then begin + Hashtbl.add seen file (); + let cin = open_in (file ^ ".v") in + let lb = Lexing.from_channel cin in + try + while true do + match coq_action lb with + | Require (from, sl) -> + List.iter + (fun s -> + match search_v_known ?from s with + | None -> () + | Some f -> loop f) + sl + | _ -> () + done + with Fin_fichier -> + close_in cin; + printf "%s%s " file !suffixe + end + in + List.iter (fun (name,_) -> loop name) !vAccu diff --git a/tools/coqdep_common.mli b/tools/coqdep_common.mli index 6d49f7e06c..1820db4a1e 100644 --- a/tools/coqdep_common.mli +++ b/tools/coqdep_common.mli @@ -20,45 +20,34 @@ val coqdep_warning : ('a, Format.formatter, unit, unit) format4 -> 'a twice.*) val find_dir_logpath: string -> string list +(** Options *) val option_c : bool ref val option_noglob : bool ref val option_boot : bool ref - val write_vos : bool ref -(** output vos and vok dependencies *) +val suffixe : string ref type dynlink = Opt | Byte | Both | No | Variable - val option_dynlink : dynlink ref -val option_mldep : string option ref + val norec_dirs : StrSet.t ref -val suffixe : string ref + type dir = string option -val get_extension : string -> string list -> string * string -val basename_noext : string -> string +val treat_file : dir -> string -> unit + +(** ML-related manipulation *) val mlAccu : (string * string * dir) list ref val mliAccu : (string * dir) list ref val mllibAccu : (string * dir) list ref -val vAccu : (string * string) list ref -val addQueue : 'a list ref -> 'a -> unit val add_ml_known : string -> dir -> string -> unit -val iter_ml_known : (string -> dir -> unit) -> unit -val search_ml_known : string -> dir option val add_mli_known : string -> dir -> string -> unit -val iter_mli_known : (string -> dir -> unit) -> unit -val search_mli_known : string -> dir option val add_mllib_known : string -> dir -> string -> unit -val search_mllib_known : string -> dir option -val search_v_known : ?from:string list -> string list -> string option -val file_name : string -> string option -> string -val escape : string -> string -val canonize : string -> string val mL_dependencies : unit -> unit + val coq_dependencies : unit -> unit -val suffixes : 'a list -> 'a list list val add_known : bool -> string -> string list -> string -> unit val add_coqlib_known : bool -> string -> string list -> string -> unit -val add_caml_known : string -> string list -> string -> unit + val add_caml_dir : string -> unit (** Simply add this directory and imports it, no subdirs. This is used @@ -74,5 +63,4 @@ val add_rec_dir_no_import : val add_rec_dir_import : (bool -> string -> string list -> string -> unit) -> string -> string list -> unit -val treat_file : dir -> string -> unit -val error_cannot_parse : string -> int * int -> 'a +val sort : unit -> unit diff --git a/topbin/coqtop_byte_bin.ml b/topbin/coqtop_byte_bin.ml index aaabd90370..604c6e251a 100644 --- a/topbin/coqtop_byte_bin.ml +++ b/topbin/coqtop_byte_bin.ml @@ -8,6 +8,14 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +(* We register this handler for lower-level toplevel loading code *) +let _ = CErrors.register_handler (function + | Symtable.Error e -> + Pp.str (Format.asprintf "%a" Symtable.report_error e) + | _ -> + raise CErrors.Unhandled + ) + let drop_setup () = begin try (* Enable rectypes in the toplevel if it has the directive #rectypes *) @@ -23,7 +31,6 @@ let drop_setup () = { load_obj = (fun f -> if not (Topdirs.load_file ppf f) then CErrors.user_err Pp.(str ("Could not load plugin "^f)) ); - use_file = Topdirs.dir_use ppf; add_dir = Topdirs.dir_directory; ml_loop = (fun () -> Toploop.loop ppf); }) diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index 56a6312b61..506a8dc5b0 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -32,10 +32,6 @@ let set_type_in_type () = let typing_flags = Environ.typing_flags (Global.env ()) in Global.set_typing_flags { typing_flags with Declarations.check_universes = false } -let set_no_template_check () = - let typing_flags = Environ.typing_flags (Global.env ()) in - Global.set_typing_flags { typing_flags with Declarations.check_template = false } - (******************************************************************************) type color = [`ON | `AUTO | `EMACS | `OFF] @@ -198,14 +194,6 @@ let set_query opts q = | Queries queries -> Queries (queries@[q]) } -let warn_depr_load_ml_object = - CWarnings.create ~name:"deprecated-mlobject" ~category:"deprecated" - (fun () -> Pp.strbrk "The -load-ml-object option is deprecated, see the changelog for more details.") - -let warn_depr_ml_load_source = - CWarnings.create ~name:"deprecated-mlsource" ~category:"deprecated" - (fun () -> Pp.strbrk "The -load-ml-source option is deprecated, see the changelog for more details.") - let warn_deprecated_inputstate = CWarnings.create ~name:"deprecated-inputstate" ~category:"deprecated" (fun () -> Pp.strbrk "The inputstate option is deprecated and discouraged.") @@ -279,8 +267,7 @@ let get_compat_file = function | "8.12" -> "Coq.Compat.Coq812" | "8.11" -> "Coq.Compat.Coq811" | "8.10" -> "Coq.Compat.Coq810" - | "8.9" -> "Coq.Compat.Coq89" - | ("8.8" | "8.7" | "8.6" | "8.5" | "8.4" | "8.3" | "8.2" | "8.1" | "8.0") as s -> + | ("8.9" | "8.8" | "8.7" | "8.6" | "8.5" | "8.4" | "8.3" | "8.2" | "8.1" | "8.0") as s -> CErrors.user_err ~hdr:"get_compat_file" Pp.(str "Compatibility with version " ++ str s ++ str " not supported.") | s -> @@ -403,14 +390,6 @@ let parse_args ~help ~init arglist : t * string list = |"-inputstate"|"-is" -> set_inputstate oval (next ()) - |"-load-ml-object" -> - warn_depr_load_ml_object (); - Mltop.dir_ml_load (next ()); oval - - |"-load-ml-source" -> - warn_depr_ml_load_source (); - Mltop.dir_ml_use (next ()); oval - |"-load-vernac-object" -> add_vo_require oval (next ()) None None @@ -513,7 +492,7 @@ let parse_args ~help ~init arglist : t * string list = }}} |"-test-mode" -> Vernacinterp.test_mode := true; oval |"-beautify" -> Flags.beautify := true; oval - |"-bt" -> Backtrace.record_backtrace true; oval + |"-bt" -> Exninfo.record_backtrace true; oval |"-color" -> set_color oval (next ()) |"-config"|"--config" -> set_query oval PrintConfig |"-debug" -> Coqinit.set_debug (); oval @@ -543,7 +522,6 @@ let parse_args ~help ~init arglist : t * string list = |"-list-tags" -> set_query oval PrintTags |"-time" -> { oval with config = { oval.config with time = true }} |"-type-in-type" -> set_type_in_type (); oval - |"-no-template-check" -> set_no_template_check (); oval |"-unicode" -> add_vo_require oval "Utf8_core" None (Some false) |"-where" -> set_query oval PrintWhere |"-h"|"-H"|"-?"|"-help"|"--help" -> set_query oval (PrintHelp help) diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml index ae37e40101..ac348b9646 100644 --- a/toplevel/coqinit.ml +++ b/toplevel/coqinit.ml @@ -14,7 +14,7 @@ open Pp let ( / ) s1 s2 = Filename.concat s1 s2 let set_debug () = - let () = Backtrace.record_backtrace true in + let () = Exninfo.record_backtrace true in Flags.debug := true (* Loading of the resource file. diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index e1748d5c1c..e4508e9bfc 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -368,128 +368,138 @@ let top_goal_print ~doc c oldp newp = let exit_on_error = let open Goptions in - declare_bool_option_and_ref ~depr:false ~name:"coqtop-exit-on-error" ~key:["Coqtop";"Exit";"On";"Error"] + declare_bool_option_and_ref ~depr:false ~key:["Coqtop";"Exit";"On";"Error"] ~value:false -let rec vernac_loop ~state = - let open CAst in +(* XXX: This is duplicated with Vernacentries.show_proof , at some + point we should consolidate the code *) +let show_proof_diff_to_pp pstate = + let p = Option.get pstate in + let sigma, env = Pfedit.get_proof_context p in + let pprf = Proof.partial_proof p in + Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf + +let show_proof_diff_cmd ~state removed = let open Vernac.State in - let open G_toplevel in - loop_flush_all (); - top_stderr (fnl()); - if !print_emacs then top_stderr (str (top_buffer.prompt state.doc)); - resynch_buffer top_buffer; - (* execute one command *) try - let input = top_buffer.tokens in - match read_sentence ~state input with - | Some (VernacBackTo bid) -> - let bid = Stateid.of_int bid in - let doc, res = Stm.edit_at ~doc:state.doc bid in - assert (res = `NewTip); - let state = { state with doc; sid = bid } in - vernac_loop ~state - - | Some VernacQuit -> - exit 0 - - | Some VernacDrop -> - if Mltop.is_ocaml_top() - then (drop_last_doc := Some state; state) - else (Feedback.msg_warning (str "There is no ML toplevel."); vernac_loop ~state) - - | Some VernacControl { loc; v=c } -> - let nstate = Vernac.process_expr ~state (make ?loc c) in - top_goal_print ~doc:state.doc c state.proof nstate.proof; - vernac_loop ~state:nstate - - | Some (VernacShowGoal {gid; sid}) -> - let proof = Stm.get_proof ~doc:state.doc (Stateid.of_int sid) in - let goal = Printer.pr_goal_emacs ~proof gid sid in - let evars = - match proof with - | None -> mt() - | Some p -> - let gl = (Evar.unsafe_of_int gid) in - let { Proof.sigma } = Proof.data p in - try Printer.print_dependent_evars (Some gl) sigma [ gl ] - with Not_found -> mt() - in - Feedback.msg_notice (v 0 (goal ++ evars)); - vernac_loop ~state - - | Some VernacShowProofDiffs removed -> - (* extension of Vernacentries.show_proof *) - let to_pp pstate = - let p = Option.get pstate in - let sigma, env = Pfedit.get_proof_context p in - let pprf = Proof.partial_proof p in - Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf - (* We print nothing if there are no goals left *) - in - - if not (Proof_diffs.color_enabled ()) then - CErrors.user_err Pp.(str "Show Proof Diffs requires setting the \"-color\" command line argument to \"on\" or \"auto\".") - else begin - let out = - try - let n_pp = to_pp state.proof in - if true (*Proof_diffs.show_diffs ()*) then - let doc = state.doc in - let oproof = Stm.get_prev_proof ~doc (Stm.get_current_state ~doc) in - try - let o_pp = to_pp oproof in - let tokenize_string = Proof_diffs.tokenize_string in - let show_removed = Some removed in - Pp_diff.diff_pp_combined ~tokenize_string ?show_removed o_pp n_pp - with - | Pfedit.NoSuchGoal - | Option.IsNone -> n_pp - | Pp_diff.Diff_Failure msg -> begin - (* todo: print the unparsable string (if we know it) *) - Feedback.msg_warning Pp.(str ("Diff failure: " ^ msg) ++ cut() - ++ str "Showing results without diff highlighting" ); - n_pp - end - else - n_pp - with - | Pfedit.NoSuchGoal - | Option.IsNone -> - CErrors.user_err (str "No goals to show.") - in - Feedback.msg_notice out; - end; - vernac_loop ~state - - | None -> - top_stderr (fnl ()); exit 0 + let n_pp = show_proof_diff_to_pp state.proof in + if true (*Proof_diffs.show_diffs ()*) then + let doc = state.doc in + let oproof = Stm.get_prev_proof ~doc (Stm.get_current_state ~doc) in + try + let o_pp = show_proof_diff_to_pp oproof in + let tokenize_string = Proof_diffs.tokenize_string in + let show_removed = Some removed in + Pp_diff.diff_pp_combined ~tokenize_string ?show_removed o_pp n_pp + with + | Pfedit.NoSuchGoal + | Option.IsNone -> n_pp + | Pp_diff.Diff_Failure msg -> begin + (* todo: print the unparsable string (if we know it) *) + Feedback.msg_warning Pp.(str ("Diff failure: " ^ msg) ++ cut() + ++ str "Showing results without diff highlighting" ); + n_pp + end + else + n_pp + with + | Pfedit.NoSuchGoal + | Option.IsNone -> + CErrors.user_err (str "No goals to show.") +let process_toplevel_command ~state stm = + let open Vernac.State in + let open G_toplevel in + match stm with + (* Usually handled in the caller *) + | VernacDrop -> + state + + | VernacBackTo bid -> + let bid = Stateid.of_int bid in + let doc, res = Stm.edit_at ~doc:state.doc bid in + assert (res = `NewTip); + { state with doc; sid = bid } + + | VernacQuit -> + exit 0 + + | VernacControl { CAst.loc; v=c } -> + let nstate = Vernac.process_expr ~state (CAst.make ?loc c) in + top_goal_print ~doc:state.doc c state.proof nstate.proof; + nstate + + | VernacShowGoal { gid; sid } -> + let proof = Stm.get_proof ~doc:state.doc (Stateid.of_int sid) in + let goal = Printer.pr_goal_emacs ~proof gid sid in + let evars = + match proof with + | None -> mt() + | Some p -> + let gl = (Evar.unsafe_of_int gid) in + let { Proof.sigma } = Proof.data p in + try Printer.print_dependent_evars (Some gl) sigma [ gl ] + with Not_found -> mt() + in + Feedback.msg_notice (v 0 (goal ++ evars)); + state + + | VernacShowProofDiffs removed -> + (* We print nothing if there are no goals left *) + if not (Proof_diffs.color_enabled ()) then + CErrors.user_err Pp.(str "Show Proof Diffs requires setting the \"-color\" command line argument to \"on\" or \"auto\".") + else + let out = show_proof_diff_cmd ~state removed in + Feedback.msg_notice out; + state + +(* We return a new state and true if we got a `Drop` command *) +let read_and_execute_base ~state = + let input = top_buffer.tokens in + match read_sentence ~state input with + | Some G_toplevel.VernacDrop -> + if Mltop.is_ocaml_top() + then (drop_last_doc := Some state; state, true) + else (Feedback.msg_warning (str "There is no ML toplevel."); state, false) + | Some stm -> + process_toplevel_command ~state stm, false + (* End of file *) + | None -> + top_stderr (fnl ()); exit 0 + +let read_and_execute ~state = + try read_and_execute_base ~state with (* Exception printing should be done by the feedback listener, however this is not yet ready so we rely on the exception for now. *) + | Sys_blocked_io -> + (* the parser doesn't like nonblocking mode, cf #10918 *) + let msg = + Pp.(strbrk "Coqtop needs the standard input to be in blocking mode." ++ spc() + ++ str "One way of clearing the non-blocking flag is through Python:" ++ fnl() + ++ str " import os" ++ fnl() + ++ str " os.set_blocking(0, True)") + in + TopErr.print_error_for_buffer Feedback.Error msg top_buffer; + exit 1 | any -> let (e, info) = CErrors.push 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; if exit_on_error () then exit 1; - vernac_loop ~state + state, false -let rec loop ~state = +(* This function will only return on [Drop], careful to keep it tail-recursive *) +let rec vernac_loop ~state = let open Vernac.State in - Sys.catch_break true; - try - reset_input_buffer state.doc stdin top_buffer; - vernac_loop ~state - with - | any -> - top_stderr - (hov 0 (str "Anomaly: main loop exited with exception:" ++ spc () ++ - str (Printexc.to_string any)) ++ spc () ++ - hov 0 (str "Please report at " ++ str Coq_config.wwwbugtracker ++ str ".")); - loop ~state + loop_flush_all (); + top_stderr (fnl()); + if !print_emacs then top_stderr (str (top_buffer.prompt state.doc)); + resynch_buffer top_buffer; + let state, drop = read_and_execute ~state in + if drop then state else vernac_loop ~state (* Default toplevel loop *) @@ -501,7 +511,11 @@ let loop ~opts ~state = print_emacs := opts.config.print_emacs; (* We initialize the console only if we run the toploop_run *) let tl_feed = Feedback.add_feeder coqloop_feed in - let _ = loop ~state in + (* Initialize buffer *) + Sys.catch_break true; + reset_input_buffer state.Vernac.State.doc stdin top_buffer; + (* Call the main loop *) + let _ : Vernac.State.t = vernac_loop ~state in (* Initialise and launch the Ocaml toplevel *) Coqinit.init_ocaml_path(); Mltop.ocaml_toploop(); diff --git a/toplevel/usage.ml b/toplevel/usage.ml index b17ca71f4c..6848862603 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -36,8 +36,6 @@ let print_usage_common co command = \n -nois (idem)\ \n -compat X.Y provides compatibility support for Coq version X.Y\ \n\ -\n -load-ml-object f load ML object file f\ -\n -load-ml-source f load ML file f\ \n -load-vernac-source f load Coq file f.v (Load \"f\".)\ \n -l f (idem)\ \n -load-vernac-source-verbose f load Coq file f.v (Load Verbose \"f\".)\ @@ -83,7 +81,6 @@ let print_usage_common co command = \n -sprop-cumulative make sort SProp cumulative with the rest of the hierarchy\ \n -indices-matter levels of indices (and nonuniform parameters) contribute to the level of inductives\ \n -type-in-type disable universe consistency checking\ -\n -no-template-check disable checking of universes constraints on universes parameterizing template polymorphic inductive types\ \n -mangle-names x mangle auto-generated names using prefix x\ \n -set \"Foo Bar\" enable Foo Bar (as Set Foo Bar. in a file)\ \n -set \"Foo Bar=value\" set Foo Bar to value (value is interpreted according to Foo Bar's type)\ diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index bca6b48499..adcce67b0d 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -69,10 +69,10 @@ 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 (* 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); - let (reraise, info) = CErrors.push reraise in let info = begin match Loc.get_loc info with | None -> Option.cata (Loc.add_loc info) info loc diff --git a/user-contrib/Ltac2/Array.v b/user-contrib/Ltac2/Array.v index c55e20bc88..ee3bf88647 100644 --- a/user-contrib/Ltac2/Array.v +++ b/user-contrib/Ltac2/Array.v @@ -8,9 +8,220 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +(* This is mostly a translation of OCaml stdlib/array.ml *) + +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + Require Import Ltac2.Init. +Require Ltac2.Int. +Require Ltac2.Control. +Require Ltac2.Bool. +Require Ltac2.Message. + +(* Question: what is returned in case of an out of range value? + Answer: Ltac2 throws a panic *) +Ltac2 @external empty : unit -> 'a array := "ltac2" "array_empty". Ltac2 @external make : int -> 'a -> 'a array := "ltac2" "array_make". Ltac2 @external length : 'a array -> int := "ltac2" "array_length". Ltac2 @external get : 'a array -> int -> 'a := "ltac2" "array_get". Ltac2 @external set : 'a array -> int -> 'a -> unit := "ltac2" "array_set". +Ltac2 @external lowlevel_blit : 'a array -> int -> 'a array -> int -> int -> unit := "ltac2" "array_blit". +Ltac2 @external lowlevel_fill : 'a array -> int -> int -> 'a -> unit := "ltac2" "array_fill". +Ltac2 @external concat : ('a array) list -> 'a array := "ltac2" "array_concat". + +(* Low level array operations *) + +Ltac2 lowlevel_sub (arr : 'a array) (start : int) (len : int) := + let l := length arr in + match Int.equal l 0 with + | true => empty () + | false => + let newarr:=make len (get arr 0) in + lowlevel_blit arr start newarr 0 len; + newarr + end. + +(* Array functions as defined in the OCaml library *) + +Ltac2 init (l : int) (f : int->'a) := + let rec init_aux (dst : 'a array) (pos : int) (len : int) (f : int->'a) := + match Int.equal len 0 with + | true => () + | false => + set dst pos (f pos); + init_aux dst (Int.add pos 1) (Int.sub len 1) f + end + in + match Int.le l 0 with + | true => empty () + | false => + let arr:=make l (f 0) in + init_aux arr 0 (length arr) f; + arr + end. + +Ltac2 make_matrix (sx : int) (sy : int) (v : 'a) := + let init1 i := v in + let initr i := init sy init1 in + init sx initr. + +Ltac2 copy a := lowlevel_sub a 0 (length a). + +Ltac2 append (a1 : 'a array) (a2 : 'a array) := + match Int.equal (length a1) 0 with + | true => copy a2 + | false => match Int.equal (length a2) 0 with + | true => copy a1 + | false => + let newarr:=make (Int.add (length a1) (length a2)) (get a1 0) in + lowlevel_blit a1 0 newarr 0 (length a1); + lowlevel_blit a2 0 newarr (length a1) (length a2); + newarr + end + end. + +Ltac2 sub (a : 'a array) (ofs : int) (len : int) := + Control.assert_valid_argument "Array.sub ofs<0" (Int.ge ofs 0); + Control.assert_valid_argument "Array.sub len<0" (Int.ge len 0); + Control.assert_bounds "Array.sub" (Int.le ofs (Int.sub (length a) len)); + lowlevel_sub a ofs len. + +Ltac2 fill (a : 'a array) (ofs : int) (len : int) (v : 'a) := + Control.assert_valid_argument "Array.fill ofs<0" (Int.ge ofs 0); + Control.assert_valid_argument "Array.fill len<0" (Int.ge len 0); + Control.assert_bounds "Array.fill" (Int.le ofs (Int.sub (length a) len)); + lowlevel_fill a ofs len v. + +Ltac2 blit (a1 : 'a array) (ofs1 : int) (a2 : 'a array) (ofs2 : int) (len : int) := + Control.assert_valid_argument "Array.blit ofs1<0" (Int.ge ofs1 0); + Control.assert_valid_argument "Array.blit ofs2<0" (Int.ge ofs2 0); + Control.assert_valid_argument "Array.blit len<0" (Int.ge len 0); + Control.assert_bounds "Array.blit ofs1+len>len a1" (Int.le ofs1 (Int.sub (length a1) len)); + Control.assert_bounds "Array.blit ofs2+len>len a2" (Int.le ofs2 (Int.sub (length a2) len)); + lowlevel_blit a1 ofs1 a2 ofs2 len. + +Ltac2 rec iter_aux (f : 'a -> unit) (a : 'a array) (pos : int) (len : int) := + match Int.equal len 0 with + | true => () + | false => f (get a pos); iter_aux f a (Int.add pos 1) (Int.sub len 1) + end. + +Ltac2 iter (f : 'a -> unit) (a : 'a array) := iter_aux f a 0 (length a). + +Ltac2 rec iter2_aux (f : 'a -> 'b -> unit) (a : 'a array) (b : 'b array) (pos : int) (len : int) := + match Int.equal len 0 with + | true => () + | false => f (get a pos) (get b pos); iter2_aux f a b (Int.add pos 1) (Int.sub len 1) + end. + +Ltac2 rec iter2 (f : 'a -> 'b -> unit) (a : 'a array) (b : 'b array) := + Control.assert_valid_argument "Array.iter2" (Int.equal (length a) (length b)); + iter2_aux f a b 0 (length a). + +Ltac2 map (f : 'a -> 'b) (a : 'a array) := + init (length a) (fun i => f (get a i)). + +Ltac2 map2 (f : 'a -> 'b -> 'c) (a : 'a array) (b : 'b array) := + Control.assert_valid_argument "Array.map2" (Int.equal (length a) (length b)); + init (length a) (fun i => f (get a i) (get b i)). + +Ltac2 rec iteri_aux (f : int -> 'a -> unit) (a : 'a array) (pos : int) (len : int) := + match Int.equal len 0 with + | true => () + | false => f pos (get a pos); iteri_aux f a (Int.add pos 1) (Int.sub len 1) + end. + +Ltac2 iteri (f : int -> 'a -> unit) (a : 'a array) := iteri_aux f a 0 (length a). + +Ltac2 mapi (f : int -> 'a -> 'b) (a : 'a array) := + init (length a) (fun i => f i (get a i)). + +Ltac2 rec to_list_aux (a : 'a array) (pos : int) (len : int) := + match Int.equal len 0 with + | true => [] + | false => get a pos :: to_list_aux a (Int.add pos 1) (Int.sub len 1) + end. + +Ltac2 to_list (a : 'a array) := to_list_aux a 0 (length a). + +Ltac2 rec of_list_aux (ls : 'a list) (dst : 'a array) (pos : int) := + match ls with + | [] => () + | hd::tl => + set dst pos hd; + of_list_aux tl dst (Int.add pos 1) + end. + +Ltac2 of_list (ls : 'a list) := + (* Don't use List.length here because the List module might depend on Array some day *) + let rec list_length (ls : 'a list) := + match ls with + | [] => 0 + | _ :: tl => Int.add 1 (list_length tl) + end in + match ls with + | [] => empty () + | hd::tl => + let anew := make (list_length ls) hd in + of_list_aux ls anew 0; + anew + end. + +Ltac2 rec fold_left_aux (f : 'a -> 'b -> 'a) (x : 'a) (a : 'b array) (pos : int) (len : int) := + match Int.equal len 0 with + | true => x + | false => fold_left_aux f (f x (get a pos)) a (Int.add pos 1) (Int.sub len 1) + end. + +Ltac2 fold_left (f : 'a -> 'b -> 'a) (x : 'a) (a : 'b array) := fold_left_aux f x a 0 (length a). + +Ltac2 rec fold_right_aux (f : 'a -> 'b -> 'a) (x : 'a) (a : 'b array) (pos : int) (len : int) := + (* Note: one could compare pos<0. + We keep an extra len parameter so that the function can be used for any sub array *) + match Int.equal len 0 with + | true => x + | false => fold_right_aux f (f x (get a pos)) a (Int.sub pos 1) (Int.sub len 1) + end. + +Ltac2 fold_right (f : 'a -> 'b -> 'a) (x : 'a) (a : 'b array) := fold_right_aux f x a (Int.sub (length a) 1) (length a). + +Ltac2 rec exist_aux (p : 'a -> bool) (a : 'a array) (pos : int) (len : int) := + match Int.equal len 0 with + | true => false + | false => match p (get a pos) with + | true => true + | false => exist_aux p a (Int.add pos 1) (Int.sub len 1) + end + end. + +(* Note: named exist (as in Coq library) rather than exists cause exists is a notation *) +Ltac2 exist (p : 'a -> bool) (a : 'a array) := exist_aux p a 0 (length a). + +Ltac2 rec for_all_aux (p : 'a -> bool) (a : 'a array) (pos : int) (len : int) := + match Int.equal len 0 with + | true => true + | false => match p (get a pos) with + | true => for_all_aux p a (Int.add pos 1) (Int.sub len 1) + | false => false + end + end. + +Ltac2 for_all (p : 'a -> bool) (a : 'a array) := for_all_aux p a 0 (length a). + +(* Note: we don't have (yet) a generic equality function in Ltac2 *) +Ltac2 mem (eq : 'a -> 'a -> bool) (x : 'a) (a : 'a array) := + exist (eq x) a. diff --git a/user-contrib/Ltac2/tac2core.ml b/user-contrib/Ltac2/tac2core.ml index 55cd7f7692..431589aa30 100644 --- a/user-contrib/Ltac2/tac2core.ml +++ b/user-contrib/Ltac2/tac2core.ml @@ -213,6 +213,14 @@ let define3 name r0 r1 r2 f = define_primitive name (arity_suc (arity_suc arity_ f (Value.repr_to r0 x) (Value.repr_to r1 y) (Value.repr_to r2 z) end +let define4 name r0 r1 r2 r3 f = define_primitive name (arity_suc (arity_suc (arity_suc arity_one))) begin fun x0 x1 x2 x3 -> + f (Value.repr_to r0 x0) (Value.repr_to r1 x1) (Value.repr_to r2 x2) (Value.repr_to r3 x3) +end + +let define5 name r0 r1 r2 r3 r4 f = define_primitive name (arity_suc (arity_suc (arity_suc (arity_suc arity_one)))) begin fun x0 x1 x2 x3 x4 -> + f (Value.repr_to r0 x0) (Value.repr_to r1 x1) (Value.repr_to r2 x2) (Value.repr_to r3 x3) (Value.repr_to r4 x4) +end + (** Printing *) let () = define1 "print" pp begin fun pp -> @@ -253,6 +261,10 @@ end (** Array *) +let () = define0 "array_empty" begin + return (v_blk 0 (Array.of_list [])) +end + let () = define2 "array_make" int valexpr begin fun n x -> if n < 0 || n > Sys.max_array_length then throw err_outofbounds else wrap (fun () -> v_blk 0 (Array.make n x)) @@ -272,6 +284,20 @@ let () = define2 "array_get" block int begin fun (_, v) n -> else wrap (fun () -> v.(n)) end +let () = define5 "array_blit" block int block int int begin fun (_, v0) s0 (_, v1) s1 l -> + if s0 < 0 || s0+l > Array.length v0 || s1 < 0 || s1+l > Array.length v1 || l<0 then throw err_outofbounds + else wrap_unit (fun () -> Array.blit v0 s0 v1 s1 l) +end + +let () = define4 "array_fill" block int int valexpr begin fun (_, d) s l v -> + if s < 0 || s+l > Array.length d || l<0 then throw err_outofbounds + else wrap_unit (fun () -> Array.fill d s l v) +end + +let () = define1 "array_concat" (list block) begin fun l -> + wrap (fun () -> v_blk 0 (Array.concat (List.map snd l))) +end + (** Ident *) let () = define2 "ident_equal" ident ident begin fun id1 id2 -> diff --git a/user-contrib/Ltac2/tac2entries.ml b/user-contrib/Ltac2/tac2entries.ml index bcc5f54505..d6db4a735c 100644 --- a/user-contrib/Ltac2/tac2entries.ml +++ b/user-contrib/Ltac2/tac2entries.ml @@ -824,7 +824,6 @@ let register_struct ?local str = match str with let _ = Goptions.declare_bool_option { Goptions.optdepr = false; - Goptions.optname = "print Ltac2 backtrace"; Goptions.optkey = ["Ltac2"; "Backtrace"]; Goptions.optread = (fun () -> !Tac2interp.print_ltac2_backtrace); Goptions.optwrite = (fun b -> Tac2interp.print_ltac2_backtrace := b); diff --git a/user-contrib/Ltac2/tac2tactics.ml b/user-contrib/Ltac2/tac2tactics.ml index 561bd9c0c5..8a14be9ca7 100644 --- a/user-contrib/Ltac2/tac2tactics.ml +++ b/user-contrib/Ltac2/tac2tactics.ml @@ -33,6 +33,7 @@ let delayed_of_tactic tac env sigma = let _, pv = Proofview.init sigma [] in let name, poly = Id.of_string "ltac2_delayed", false in let c, pv, _, _ = Proofview.apply ~name ~poly env tac pv in + let _, sigma = Proofview.proofview pv in (sigma, c) let delayed_of_thunk r tac env sigma = diff --git a/vernac/assumptions.ml b/vernac/assumptions.ml index dacef1cb18..fb61a1089f 100644 --- a/vernac/assumptions.ml +++ b/vernac/assumptions.ml @@ -240,8 +240,16 @@ and traverse_inductive (curr, data, ax2ty) mind obj = (* Build the context of all arities *) let arities_ctx = let global_env = Global.env () in + let instance = + let open Univ in + Instance.of_array + (Array.init + (AUContext.size + (Declareops.inductive_polymorphic_context mib)) + Level.var) + in Array.fold_left (fun accu oib -> - let pspecif = Univ.in_punivs (mib, oib) in + let pspecif = ((mib, oib), instance) in let ind_type = Inductive.type_of_inductive global_env pspecif in let indr = oib.mind_relevance in let ind_name = Name oib.mind_typename in @@ -356,8 +364,5 @@ let assumptions ?(add_opaque=false) ?(add_transparent=false) st gr t = let l = try GlobRef.Map_env.find obj ax2ty with Not_found -> [] in ContextObjectMap.add (Axiom (TypeInType obj, l)) Constr.mkProp accu in - if not mind.mind_typing_flags.check_template then - let l = try GlobRef.Map_env.find obj ax2ty with Not_found -> [] in - ContextObjectMap.add (Axiom (TemplatePolymorphic m, l)) Constr.mkProp accu - else accu + accu in GlobRef.Map_env.fold fold graph ContextObjectMap.empty diff --git a/vernac/attributes.ml b/vernac/attributes.ml index 68d2c3a00d..194308b77f 100644 --- a/vernac/attributes.ml +++ b/vernac/attributes.ml @@ -154,7 +154,6 @@ let program_mode = ref false let () = let open Goptions in declare_bool_option { optdepr = false; - optname = "use of the program extension"; optkey = program_mode_option_name; optread = (fun () -> !program_mode); optwrite = (fun b -> program_mode:=b) } @@ -188,7 +187,6 @@ let is_universe_polymorphism = let () = let open Goptions in declare_bool_option { optdepr = false; - optname = "universe polymorphism"; optkey = universe_polymorphism_option_name; optread = (fun () -> !b); optwrite = ((:=) b) } diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index f954915cf8..6bdb3159cf 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -395,7 +395,7 @@ let do_replace_lb mode lb_scheme_key aavoid narg p q = in Proofview.Goal.enter begin fun gl -> - let type_of_pq = Tacmach.New.pf_unsafe_type_of gl p in + let type_of_pq = Tacmach.New.pf_get_type_of gl p in let sigma = Tacmach.New.project gl in let env = Tacmach.New.pf_env gl in let u,v = destruct_ind env sigma type_of_pq @@ -458,11 +458,11 @@ let do_replace_bl bl_scheme_key (ind,u as indu) aavoid narg lft rgt = match (l1,l2) with | (t1::q1,t2::q2) -> Proofview.Goal.enter begin fun gl -> - let tt1 = Tacmach.New.pf_unsafe_type_of gl t1 in let sigma = Tacmach.New.project gl in let env = Tacmach.New.pf_env gl in if EConstr.eq_constr sigma t1 t2 then aux q1 q2 else ( + let tt1 = Tacmach.New.pf_get_type_of gl t1 in let u,v = try destruct_ind env sigma tt1 (* trick so that the good sequence is returned*) with e when CErrors.noncritical e -> indu,[||] diff --git a/vernac/classes.ml b/vernac/classes.ml index c9b5144299..b92c9e9b71 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -42,13 +42,10 @@ let () = Hook.set Typeclasses.classes_transparent_state_hook classes_transparent_state let add_instance_hint inst path local info poly = - let inst' = match inst with IsConstr c -> Hints.IsConstr (EConstr.of_constr c, Univ.ContextSet.empty) - | IsGlobal gr -> Hints.IsGlobRef gr - in Flags.silently (fun () -> Hints.add_hints ~local [typeclasses_db] (Hints.HintsResolveEntry - [info, poly, false, Hints.PathHints path, inst'])) () + [info, poly, false, Hints.PathHints path, inst])) () let is_local_for_hint i = match i.is_global with @@ -61,9 +58,9 @@ let is_local_for_hint i = let add_instance check inst = let poly = Global.is_polymorphic inst.is_impl in let local = is_local_for_hint inst in - add_instance_hint (IsGlobal inst.is_impl) [inst.is_impl] local + 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 (IsConstr c) path + List.iter (fun (path, pri, c) -> add_instance_hint (Hints.IsConstr (EConstr.of_constr c, Univ.ContextSet.empty)) 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) @@ -513,7 +510,7 @@ let do_instance_program env env' sigma ?hook ~global ~poly cty k u ctx ctx' pri let interp_instance_context ~program_mode env ctx ~generalize pl tclass = let sigma, decl = Constrexpr_ops.interp_univ_decl_opt env pl in let tclass = - if generalize then CAst.make @@ CGeneralization (Glob_term.Implicit, Some AbsPi, tclass) + if generalize then CAst.make @@ CGeneralization (Glob_term.MaxImplicit, Some AbsPi, tclass) else tclass in let sigma, (impls, ((env', ctx), imps)) = interp_context_evars ~program_mode env sigma ctx in diff --git a/vernac/comArguments.ml b/vernac/comArguments.ml index 15077298aa..9d43debb77 100644 --- a/vernac/comArguments.ml +++ b/vernac/comArguments.ml @@ -228,7 +228,7 @@ let vernac_arguments ~section_local reference args more_implicits flags = let implicits = List.map (List.map snd) implicits in let implicits_specified = match implicits with - | [l] -> List.exists (function Impargs.NotImplicit -> false | _ -> true) l + | [l] -> List.exists (function Glob_term.Explicit -> false | _ -> true) l | _ -> true in if implicits_specified && clear_implicits_flag then diff --git a/vernac/comArguments.mli b/vernac/comArguments.mli index 71effddf67..cbc5fc15e2 100644 --- a/vernac/comArguments.mli +++ b/vernac/comArguments.mli @@ -12,6 +12,6 @@ val vernac_arguments : section_local:bool -> Libnames.qualid Constrexpr.or_by_notation -> Vernacexpr.vernac_argument_status list - -> (Names.Name.t * Impargs.implicit_kind) list list + -> (Names.Name.t * Glob_term.binding_kind) list list -> Vernacexpr.arguments_modifier list -> unit diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index 625ffb5a06..d97bf6724c 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -270,7 +270,7 @@ let context ~poly l = | Some (Name id',_) -> Id.equal name id' | _ -> false in - let impl = Glob_term.(if List.exists test impls then Implicit else Explicit) in + let impl = Glob_term.(if List.exists test impls then MaxImplicit else Explicit) in (* ??? *) name,b,t,impl) ctx in diff --git a/vernac/comCoercion.ml b/vernac/comCoercion.ml index 56ab6f289d..2c582da495 100644 --- a/vernac/comCoercion.ml +++ b/vernac/comCoercion.ml @@ -198,10 +198,9 @@ let build_id_coercion idf_opt source poly = lams in (* juste pour verification *) - let _ = - if not - (Reductionops.is_conv_leq env sigma - (Typing.unsafe_type_of env sigma (EConstr.of_constr val_f)) (EConstr.of_constr typ_f)) + let sigma, val_t = Typing.type_of env sigma (EConstr.of_constr val_f) in + let () = + if not (Reductionops.is_conv_leq env sigma val_t (EConstr.of_constr typ_f)) then user_err (strbrk "Cannot be defined as coercion (maybe a bad number of arguments).") diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index 8de1c69424..d711c9aea0 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -42,7 +42,6 @@ let should_auto_template = let auto = ref true in let () = declare_bool_option { optdepr = false; - optname = "Automatically make some inductive types template polymorphic"; optkey = ["Auto";"Template";"Polymorphism"]; optread = (fun () -> !auto); optwrite = (fun b -> auto := b); } @@ -323,16 +322,15 @@ let check_named {CAst.loc;v=na} = match na with let msg = str "Parameters must be named." in user_err ?loc msg -let template_polymorphism_candidate ~template_check ~ctor_levels uctx params concl = +let template_polymorphism_candidate ~ctor_levels uctx params concl = match uctx with | Entries.Monomorphic_entry uctx -> let concltemplate = Option.cata (fun s -> not (Sorts.is_small s)) false concl in if not concltemplate then false - else if not template_check then true else let conclu = Option.cata Sorts.univ_of_sort Univ.type0m_univ concl in let params, conclunivs = - IndTyping.template_polymorphic_univs ~template_check ~ctor_levels uctx params conclu + IndTyping.template_polymorphic_univs ~ctor_levels uctx params conclu in not (Univ.LSet.is_empty conclunivs) | Entries.Polymorphic_entry _ -> false @@ -385,7 +383,7 @@ let interp_mutual_inductive_constr ~sigma ~template ~udecl ~ctx_params ~indnames List.fold_left (fun levels c -> add_levels c levels) param_levels ctypes in - template_polymorphism_candidate ~template_check:(Environ.check_template env_ar_params) ~ctor_levels uctx ctx_params concl + template_polymorphism_candidate ~ctor_levels uctx ctx_params concl in let template = match template with | Some template -> diff --git a/vernac/comInductive.mli b/vernac/comInductive.mli index cc104b3762..1286e4a5c3 100644 --- a/vernac/comInductive.mli +++ b/vernac/comInductive.mli @@ -76,17 +76,15 @@ val should_auto_template : Id.t -> bool -> bool inductive under consideration. *) val template_polymorphism_candidate - : template_check:bool - -> ctor_levels:Univ.LSet.t + : ctor_levels:Univ.LSet.t -> Entries.universes_entry -> Constr.rel_context -> Sorts.t option -> bool -(** [template_polymorphism_candidate ~template_check ~ctor_levels uctx params +(** [template_polymorphism_candidate ~ctor_levels uctx params conclsort] is [true] iff an inductive with params [params], conclusion [conclsort] and universe levels appearing in the constructor arguments [ctor_levels] would be definable as template polymorphic. It should have at least one universe in its monomorphic universe context that can be made parametric in its - conclusion sort, if one is given. If the [template_check] flag is - false we just check that the conclusion sort is not small. *) + conclusion sort, if one is given. *) diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index d48e2139d1..84f8578ad4 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -127,7 +127,7 @@ let build_wellfounded (recname,pl,bl,arityc,body) poly r measure notation = let binders = letbinders @ [arg] in let binders_env = push_rel_context binders_rel env in let sigma, (rel, _) = interp_constr_evars_impls ~program_mode:true env sigma r in - let relty = Typing.unsafe_type_of env sigma rel in + let relty = Retyping.get_type_of env sigma rel in let relargty = let error () = user_err ?loc:(constr_loc r) diff --git a/vernac/declareInd.ml b/vernac/declareInd.ml index 2375028541..7dd53564cc 100644 --- a/vernac/declareInd.ml +++ b/vernac/declareInd.ml @@ -60,9 +60,9 @@ let cache_inductive ((sp, kn), names) = let discharge_inductive ((sp, kn), names) = Some names -let inInductive : inductive_obj -> Libobject.obj = +let objInductive : inductive_obj Libobject.Dyn.tag = let open Libobject in - declare_object {(default_object "INDUCTIVE") with + declare_object_full {(default_object "INDUCTIVE") with cache_function = cache_inductive; load_function = load_inductive; open_function = open_inductive; @@ -71,6 +71,7 @@ let inInductive : inductive_obj -> Libobject.obj = discharge_function = discharge_inductive; } +let inInductive v = Libobject.Dyn.Easy.inj v objInductive let cache_prim (_,(p,c)) = Recordops.register_primitive_projection p c @@ -212,3 +213,9 @@ let declare_mutual_inductive_with_eliminations ?(primitive_expected=false) mie p if mie.mind_entry_private == None then Indschemes.declare_default_schemes mind; mind + +module Internal = +struct + type nonrec inductive_obj = inductive_obj + let objInductive = objInductive +end diff --git a/vernac/declareInd.mli b/vernac/declareInd.mli index df8895a999..17647d50aa 100644 --- a/vernac/declareInd.mli +++ b/vernac/declareInd.mli @@ -21,3 +21,12 @@ val declare_mutual_inductive_with_eliminations -> UnivNames.universe_binders -> one_inductive_impls list -> Names.MutInd.t + +(** {6 For legacy support, do not use} *) +module Internal : +sig + +type inductive_obj +val objInductive : inductive_obj Libobject.Dyn.tag + +end diff --git a/vernac/declareObl.ml b/vernac/declareObl.ml index b56b9c8ce2..dcb28b898f 100644 --- a/vernac/declareObl.ml +++ b/vernac/declareObl.ml @@ -56,7 +56,7 @@ type program_info = let get_shrink_obligations = Goptions.declare_bool_option_and_ref ~depr:true (* remove in 8.8 *) - ~name:"Shrinking of Program obligations" ~key:["Shrink"; "Obligations"] + ~key:["Shrink"; "Obligations"] ~value:true (* XXX: Is this the right place for this? *) @@ -133,7 +133,6 @@ let add_hint local prg cst = let get_hide_obligations = Goptions.declare_bool_option_and_ref ~depr:false - ~name:"Hidding of Program obligations" ~key:["Hide"; "Obligations"] ~value:false diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 3302231fd1..74249301d7 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -16,13 +16,11 @@ open Util open Names open Glob_term open Vernacexpr -open Impargs open Constrexpr open Constrexpr_ops open Extend open Decls open Declaremods -open Declarations open Namegen open Tok (* necessary for camlp5 *) @@ -201,9 +199,7 @@ GRAMMAR EXTEND Gram (* Gallina inductive declarations *) | cum = OPT cumulativity_token; priv = private_token; f = finite_token; indl = LIST1 inductive_definition SEP "with" -> - { let (k,f) = f in - let indl=List.map (fun ((a,b,c,d),e) -> ((a,b,c,k,d),e)) indl in - VernacInductive (cum, priv,f,indl) } + { VernacInductive (cum, priv, f, indl) } | "Fixpoint"; recs = LIST1 rec_definition SEP "with" -> { VernacFixpoint (NoDischarge, recs) } | IDENT "Let"; "Fixpoint"; recs = LIST1 rec_definition SEP "with" -> @@ -338,12 +334,12 @@ GRAMMAR EXTEND Gram ] ] ; finite_token: - [ [ IDENT "Inductive" -> { (Inductive_kw,Finite) } - | IDENT "CoInductive" -> { (CoInductive,CoFinite) } - | IDENT "Variant" -> { (Variant,BiFinite) } - | IDENT "Record" -> { (Record,BiFinite) } - | IDENT "Structure" -> { (Structure,BiFinite) } - | IDENT "Class" -> { (Class true,BiFinite) } ] ] + [ [ IDENT "Inductive" -> { Inductive_kw } + | IDENT "CoInductive" -> { CoInductive } + | IDENT "Variant" -> { Variant } + | IDENT "Record" -> { Record } + | IDENT "Structure" -> { Structure } + | IDENT "Class" -> { Class true } ] ] ; cumulativity_token: [ [ IDENT "Cumulative" -> { VernacCumulative } @@ -817,7 +813,7 @@ GRAMMAR EXTEND Gram { let name, recarg_like, notation_scope = item in [RealArg { name=name; recarg_like=recarg_like; notation_scope=notation_scope; - implicit_status = NotImplicit}] } + implicit_status = Explicit}] } | "/" -> { [VolatileArg] } | "&" -> { [BidiArg] } | "("; items = LIST1 argument_spec; ")"; sc = OPT scope_delimiter -> @@ -827,7 +823,7 @@ GRAMMAR EXTEND Gram List.map (fun (name,recarg_like,notation_scope) -> RealArg { name=name; recarg_like=recarg_like; notation_scope=f notation_scope; - implicit_status = NotImplicit}) items } + implicit_status = Explicit}) items } | "["; items = LIST1 argument_spec; "]"; sc = OPT scope_delimiter -> { let f x = match sc, x with | None, x -> x | x, None -> Option.map (fun y -> CAst.make ~loc y) x @@ -835,7 +831,7 @@ GRAMMAR EXTEND Gram List.map (fun (name,recarg_like,notation_scope) -> RealArg { name=name; recarg_like=recarg_like; notation_scope=f notation_scope; - implicit_status = Implicit}) items } + implicit_status = NonMaxImplicit}) items } | "{"; items = LIST1 argument_spec; "}"; sc = OPT scope_delimiter -> { let f x = match sc, x with | None, x -> x | x, None -> Option.map (fun y -> CAst.make ~loc y) x @@ -843,16 +839,16 @@ GRAMMAR EXTEND Gram List.map (fun (name,recarg_like,notation_scope) -> RealArg { name=name; recarg_like=recarg_like; notation_scope=f notation_scope; - implicit_status = MaximallyImplicit}) items } + implicit_status = MaxImplicit}) items } ] ]; (* Same as [argument_spec_block], but with only implicit status and names *) more_implicits_block: [ - [ name = name -> { [(name.CAst.v, NotImplicit)] } + [ name = name -> { [(name.CAst.v, Explicit)] } | "["; items = LIST1 name; "]" -> - { List.map (fun name -> (name.CAst.v, Impargs.Implicit)) items } + { List.map (fun name -> (name.CAst.v, NonMaxImplicit)) items } | "{"; items = LIST1 name; "}" -> - { List.map (fun name -> (name.CAst.v, MaximallyImplicit)) items } + { List.map (fun name -> (name.CAst.v, MaxImplicit)) items } ] ]; strategy_level: diff --git a/vernac/himsg.ml b/vernac/himsg.ml index ba7ae5069b..dfc4631572 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -201,9 +201,7 @@ let explain_bad_assumption env sigma j = str "because this term is not a type." let explain_reference_variables sigma id c = - (* c is intended to be a global reference *) - let pc = pr_global (fst (Termops.global_of_constr sigma c)) in - pc ++ strbrk " depends on the variable " ++ Id.print id ++ + pr_global c ++ strbrk " depends on the variable " ++ Id.print id ++ strbrk " which is not declared in the context." let rec pr_disjunction pr = function @@ -1216,8 +1214,12 @@ let error_bad_entry () = let error_large_non_prop_inductive_not_in_type () = str "Large non-propositional inductive types must be in Type." -let error_inductive_bad_univs () = - str "Incorrect universe constraints declared for inductive type." +let error_inductive_missing_constraints (us,ind_univ) = + let pr_u = Univ.Universe.pr_with UnivNames.pr_with_global_universes in + str "Missing universe constraint declared for inductive type:" ++ spc() + ++ v 0 (prlist_with_sep spc (fun u -> + hov 0 (pr_u u ++ str " <= " ++ pr_u ind_univ)) + (Univ.Universe.Set.elements us)) (* Recursion schemes errors *) @@ -1256,7 +1258,7 @@ let explain_inductive_error = function | BadEntry -> error_bad_entry () | LargeNonPropInductiveNotInType -> error_large_non_prop_inductive_not_in_type () - | BadUnivs -> error_inductive_bad_univs () + | MissingConstraints csts -> error_inductive_missing_constraints csts (* Recursion schemes errors *) @@ -1364,7 +1366,6 @@ let explain_exn_default = function | Sys_error msg -> hov 0 (str "System error: " ++ quote (str msg)) | Out_of_memory -> hov 0 (str "Out of memory.") | Stack_overflow -> hov 0 (str "Stack overflow.") - | Dynlink.Error e -> hov 0 (str "Dynlink error: " ++ str Dynlink.(error_message e)) | CErrors.Timeout -> hov 0 (str "Timeout!") | Sys.Break -> hov 0 (fnl () ++ str "User interrupt.") (* Otherwise, not handled here *) diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index 2f0b1062a7..227d2f1554 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -44,7 +44,6 @@ let elim_flag = ref true let () = declare_bool_option { optdepr = false; - optname = "automatic declaration of induction schemes"; optkey = ["Elimination";"Schemes"]; optread = (fun () -> !elim_flag) ; optwrite = (fun b -> elim_flag := b) } @@ -53,7 +52,6 @@ let bifinite_elim_flag = ref false let () = declare_bool_option { optdepr = false; - optname = "automatic declaration of induction schemes for non-recursive types"; optkey = ["Nonrecursive";"Elimination";"Schemes"]; optread = (fun () -> !bifinite_elim_flag) ; optwrite = (fun b -> bifinite_elim_flag := b) } @@ -62,7 +60,6 @@ let case_flag = ref false let () = declare_bool_option { optdepr = false; - optname = "automatic declaration of case analysis schemes"; optkey = ["Case";"Analysis";"Schemes"]; optread = (fun () -> !case_flag) ; optwrite = (fun b -> case_flag := b) } @@ -71,7 +68,6 @@ let eq_flag = ref false let () = declare_bool_option { optdepr = false; - optname = "automatic declaration of boolean equality"; optkey = ["Boolean";"Equality";"Schemes"]; optread = (fun () -> !eq_flag) ; optwrite = (fun b -> eq_flag := b) } @@ -82,7 +78,6 @@ let eq_dec_flag = ref false let () = declare_bool_option { optdepr = false; - optname = "automatic declaration of decidable equality"; optkey = ["Decidable";"Equality";"Schemes"]; optread = (fun () -> !eq_dec_flag) ; optwrite = (fun b -> eq_dec_flag := b) } @@ -91,7 +86,6 @@ let rewriting_flag = ref false let () = declare_bool_option { optdepr = false; - optname ="automatic declaration of rewriting schemes for equality types"; optkey = ["Rewriting";"Schemes"]; optread = (fun () -> !rewriting_flag) ; optwrite = (fun b -> rewriting_flag := b) } diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 865eded545..f7606f4ede 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -268,7 +268,6 @@ let warn_let_as_axiom = let get_keep_admitted_vars = Goptions.declare_bool_option_and_ref ~depr:false - ~name:"keep section variables in admitted proofs" ~key:["Keep"; "Admitted"; "Variables"] ~value:true diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 222e9eb825..0c39aba70a 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -126,7 +126,7 @@ let parse_format ({CAst.loc;v=str} : lstring) = let rec parse_non_format i = let n = nonspaces false 0 i in push_token (make_loc i (i+n-1)) (UnpTerminal (String.sub str i n)) (parse_token 1 (i+n)) - and parse_quoted n i = + and parse_quoted n k i = if i < len then match str.[i] with (* Parse " // " *) | '/' when i+1 < len && str.[i+1] == '/' -> @@ -140,7 +140,7 @@ let parse_format ({CAst.loc;v=str} : lstring) = (parse_token 1 (close_quotation i (i+p+1))) | c -> (* The spaces are real spaces *) - push_white i n (match c with + push_white (i-n-1-k) n (match c with | '[' -> if i+1 < len then match str.[i+1] with (* Parse " [h .. ", *) @@ -177,7 +177,7 @@ let parse_format ({CAst.loc;v=str} : lstring) = push_white (i-n) (n-k) (push_token (make_loc i (i+1)) (UnpTerminal "'") (parse_token 1 (i+1))) (* Parse the beginning of a quoted expression *) | '\'' -> - parse_quoted (n-k) (i+1) + parse_quoted (n-k) k (i+1) (* Otherwise *) | _ -> push_white (i-n) (n-k) (parse_non_format i) @@ -477,6 +477,9 @@ let warn_format_break = (fun () -> strbrk "Discarding format implicitly indicated by multiple spaces in notation because an explicit format modifier is given.") +let has_ldots l = + List.exists (function (_,UnpTerminal s) -> String.equal s (Id.to_string Notation_ops.ldots_var) | _ -> false) l + let rec split_format_at_ldots hd = function | (loc,UnpTerminal s) :: fmt when String.equal s (Id.to_string Notation_ops.ldots_var) -> loc, List.rev hd, fmt | u :: fmt -> @@ -504,11 +507,32 @@ let find_prod_list_loc sfmt fmt = (* A separator; we highlight the separating sequence *) Loc.merge_opt (fst (List.hd sfmt)) (fst (List.last sfmt)) +let is_blank s = + let n = String.length s in + let rec aux i s = i >= n || s.[i] = ' ' && aux (i+1) s in + aux 0 s + +let is_formatting = function + | (_,UnpCut _) -> true + | (_,UnpTerminal s) -> is_blank s + | _ -> false + +let rec is_var_in_recursive_format = function + | (_,UnpTerminal s) when not (is_blank s) -> true + | (loc,UnpBox (b,l)) -> + (match List.filter (fun a -> not (is_formatting a)) l with + | [a] -> is_var_in_recursive_format a + | _ -> error_not_same ?loc ()) + | _ -> false + +let rec check_eq_var_upto_name = function + | (_,UnpTerminal s1), (_,UnpTerminal s2) when not (is_blank s1 && is_blank s2) || s1 = s2 -> () + | (_,UnpBox (b1,l1)), (_,UnpBox (b2,l2)) when b1 = b2 -> List.iter check_eq_var_upto_name (List.combine l1 l2) + | (_,UnpCut b1), (_,UnpCut b2) when b1 = b2 -> () + | _, (loc,_) -> error_not_same ?loc () + let skip_var_in_recursive_format = function - | (_,UnpTerminal s) :: sl (* skip first var *) when not (List.for_all (fun c -> c = " ") (String.explode s)) -> - (* To do, though not so important: check that the names match - the names in the notation *) - sl + | a :: sl when is_var_in_recursive_format a -> a, sl | (loc,_) :: _ -> error_not_same ?loc () | [] -> assert false @@ -516,15 +540,20 @@ let read_recursive_format sl fmt = (* Turn [[UnpTerminal s :: some-list @ UnpTerminal ".." :: same-some-list @ UnpTerminal s' :: rest] *) (* into [(some-list,rest)] *) let get_head fmt = - let sl = skip_var_in_recursive_format fmt in - try split_format_at_ldots [] sl with Exit -> error_not_same ?loc:(fst (List.last (if sl = [] then fmt else sl))) () in + let var,sl = skip_var_in_recursive_format fmt in + try var, split_format_at_ldots [] sl + with Exit -> error_not_same ?loc:(fst (List.last (if sl = [] then fmt else sl))) () in let rec get_tail = function | (loc,a) :: sepfmt, (_,b) :: fmt when (=) a b -> get_tail (sepfmt, fmt) (* FIXME *) | [], tail -> skip_var_in_recursive_format tail | (loc,_) :: _, ([] | (_,UnpTerminal _) :: _)-> error_not_same ?loc () | _, (loc,_)::_ -> error_not_same ?loc () in - let loc, slfmt, fmt = get_head fmt in - slfmt, get_tail (slfmt, fmt) + let var1, (loc, slfmt, fmt) = get_head fmt in + let var2, res = get_tail (slfmt, fmt) in + check_eq_var_upto_name (var1,var2); + (* To do, though not so important: check that the names match + the names in the notation *) + slfmt, res let hunks_of_format (from,(vars,typs)) symfmt = let rec aux = function @@ -537,13 +566,9 @@ let hunks_of_format (from,(vars,typs)) symfmt = | NonTerminal s :: symbs, (_,UnpTerminal s') :: fmt when Id.equal s (Id.of_string s') -> let i = index_id s vars in let symbs, l = aux (symbs,fmt) in symbs, unparsing_metavar i from typs :: l - | symbs, (_,UnpBox (a,b)) :: fmt -> - let symbs', b' = aux (symbs,b) in - let symbs', l = aux (symbs',fmt) in - symbs', UnpBox (a,List.map (fun x -> (None,x)) b') :: l | symbs, (_,(UnpCut _ as u)) :: fmt -> let symbs, l = aux (symbs,fmt) in symbs, u :: l - | SProdList (m,sl) :: symbs, fmt -> + | SProdList (m,sl) :: symbs, fmt when has_ldots fmt -> let i = index_id m vars in let typ = List.nth typs (i-1) in let _,prec = precedence_of_entry_type from typ in @@ -558,6 +583,10 @@ let hunks_of_format (from,(vars,typs)) symfmt = UnpBinderListMetaVar (i,isopen,slfmt) | _ -> assert false in symbs, hunk :: l + | symbs, (_,UnpBox (a,b)) :: fmt -> + let symbs', b' = aux (symbs,b) in + let symbs', l = aux (symbs',fmt) in + symbs', UnpBox (a,List.map (fun x -> (None,x)) b') :: l | symbs, [] -> symbs, [] | Break _ :: symbs, fmt -> warn_format_break (); aux (symbs,fmt) | _, fmt -> error_format ?loc:(fst (List.hd fmt)) () @@ -1346,7 +1375,7 @@ let inNotation : notation_obj -> obj = (**********************************************************************) let with_lib_stk_protection f x = - let fs = Lib.freeze ~marshallable:false in + let fs = Lib.freeze () in try let a = f x in Lib.unfreeze fs; a with reraise -> let reraise = CErrors.push reraise in diff --git a/vernac/mltop.ml b/vernac/mltop.ml index 9c18441d9c..ab9d008659 100644 --- a/vernac/mltop.ml +++ b/vernac/mltop.ml @@ -11,7 +11,6 @@ open CErrors open Util open Pp -open Libobject open System (* Code to hook Coq into the ML toplevel -- depends on having the @@ -56,7 +55,6 @@ let keep_copy_mlpath path = (* If there is a toplevel under Coq *) type toplevel = { load_obj : string -> unit; - use_file : string -> unit; add_dir : string -> unit; ml_loop : unit -> unit } @@ -94,43 +92,26 @@ let ocaml_toploop () = | WithTop t -> Printexc.catch t.ml_loop () | _ -> () -(* Try to interpret load_obj's (internal) errors *) -let report_on_load_obj_error exc = - let x = Obj.repr exc in - (* Try an horrible (fragile) hack to report on Symtable dynlink errors *) - (* (we follow ocaml's Printexc.to_string decoding of exceptions) *) - if Obj.is_block x && String.equal (Obj.magic (Obj.field (Obj.field x 0) 0)) "Symtable.Error" - then - let err_block = Obj.field x 1 in - if Int.equal (Obj.tag err_block) 0 then - (* Symtable.Undefined_global of string *) - str "reference to undefined global " ++ - str (Obj.magic (Obj.field err_block 0)) - else str (Printexc.to_string exc) - else str (Printexc.to_string exc) - (* Dynamic loading of .cmo/.cma *) +(* We register errors at least for Dynlink, it is possible to do so Symtable + too, as we do in the bytecode init code. +*) +let _ = CErrors.register_handler (function + | Dynlink.Error e -> + hov 0 (str "Dynlink error: " ++ str Dynlink.(error_message e)) + | _ -> + raise CErrors.Unhandled + ) + let ml_load s = - match !load with - | WithTop t -> - (try t.load_obj s; s - with - | e when CErrors.noncritical e -> - let e = CErrors.push e in - match fst e with - | (UserError _ | Failure _ | Not_found as u) -> Exninfo.iraise (u, snd e) - | exc -> - let msg = report_on_load_obj_error exc in - user_err ~hdr:"Mltop.load_object" (str"Cannot link ml-object " ++ - str s ++ str" to Coq code (" ++ msg ++ str ").")) - | WithoutTop -> - try - Dynlink.loadfile s; s - with Dynlink.Error a -> - user_err ~hdr:"Mltop.load_object" - (strbrk "while loading " ++ str s ++ - strbrk ": " ++ str (Dynlink.error_message a)) + (match !load with + | WithTop t -> + t.load_obj s + | WithoutTop -> + Dynlink.loadfile s + ); + s let dir_ml_load s = match !load with @@ -140,17 +121,6 @@ let dir_ml_load s = let _,gname = find_file_in_path ~warn !coq_mlpath_copy s in ml_load gname -(* Dynamic interpretation of .ml *) -let dir_ml_use s = - match !load with - | WithTop t -> t.use_file s - | _ -> - let moreinfo = - if Sys.(backend_type = Native) then " Loading ML code works only in bytecode." - else "" - in - user_err ~hdr:"Mltop.dir_ml_use" (str "Could not load ML code." ++ str moreinfo) - (* Adds a path to the ML paths *) let add_ml_dir s = match !load with @@ -275,7 +245,6 @@ let load_ml_object mname ?path fname= init_ml_object mname; path -let dir_ml_load m = ignore(dir_ml_load m) let add_known_module m = add_known_module m None (* Summary of declared ML Modules *) @@ -334,23 +303,38 @@ let _ = (* Liboject entries of declared ML Modules *) +(* Digest of module used to compile the file *) +type ml_module_digest = + | NoDigest + | AnyDigest of Digest.t (* digest of any used cma / cmxa *) + type ml_module_object = { mlocal : Vernacexpr.locality_flag; - mnames : string list + mnames : (string * ml_module_digest) list } +let add_module_digest m = + try + let file = file_of_name m in + let path, file = System.where_in_path ~warn:false !coq_mlpath_copy file in + m, AnyDigest (Digest.file file) + with + | Not_found -> + m, NoDigest + let cache_ml_objects (_,{mnames=mnames}) = - let iter obj = trigger_ml_object true true true obj in + let iter (obj, _) = trigger_ml_object true true true obj in List.iter iter mnames let load_ml_objects _ (_,{mnames=mnames}) = - let iter obj = trigger_ml_object true false true obj in + let iter (obj, _) = trigger_ml_object true false true obj in List.iter iter mnames let classify_ml_objects ({mlocal=mlocal} as o) = - if mlocal then Dispose else Substitute o + if mlocal then Libobject.Dispose else Libobject.Substitute o -let inMLModule : ml_module_object -> obj = +let inMLModule : ml_module_object -> Libobject.obj = + let open Libobject in declare_object {(default_object "ML-MODULE") with cache_function = cache_ml_objects; @@ -360,6 +344,7 @@ let inMLModule : ml_module_object -> obj = let declare_ml_modules local l = let l = List.map mod_of_name l in + let l = List.map add_module_digest l in Lib.add_anonymous_leaf ~cache_first:false (inMLModule {mlocal=local; mnames=l}) let print_ml_path () = diff --git a/vernac/mltop.mli b/vernac/mltop.mli index 56a28b64b0..271772d7ba 100644 --- a/vernac/mltop.mli +++ b/vernac/mltop.mli @@ -14,7 +14,6 @@ record. *) type toplevel = { load_obj : string -> unit; - use_file : string -> unit; add_dir : string -> unit; ml_loop : unit -> unit } @@ -38,12 +37,6 @@ val add_ml_dir : recursive:bool -> string -> unit (** Tests if we can load ML files *) val has_dynlink : bool -(** Dynamic loading of .cmo *) -val dir_ml_load : string -> unit - -(** Dynamic interpretation of .ml *) -val dir_ml_use : string -> unit - (** List of modules linked to the toplevel *) val add_known_module : string -> unit val module_is_known : string -> bool diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index a1bd99c237..6240120cb0 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -476,7 +476,7 @@ let string_of_theorem_kind = let open Decls in function let prpri = match pri with None -> mt() | Some i -> str "| " ++ int i in prx ++ prpri ++ prlist (pr_decl_notation @@ pr_constr env sigma) ntn - let pr_record_decl b c fs = + let pr_record_decl c fs = pr_opt pr_lident c ++ (if c = None then str"{" else str" {") ++ hv 0 (prlist_with_sep pr_semicolon pr_record_field fs ++ str"}") @@ -802,7 +802,7 @@ let string_of_definition_object_kind = let open Decls in function (if coe then str":>" else str":") ++ Flags.without_option Flags.beautify pr_spc_lconstr c) in - let pr_constructor_list b l = match l with + let pr_constructor_list l = match l with | Constructors [] -> mt() | Constructors l -> let fst_sep = match l with [_] -> " " | _ -> " | " in @@ -810,21 +810,20 @@ let string_of_definition_object_kind = let open Decls in function fnl() ++ str fst_sep ++ prlist_with_sep (fun _ -> fnl() ++ str" | ") pr_constructor l | RecordDecl (c,fs) -> - pr_record_decl b c fs + pr_record_decl c fs in - let pr_oneind key (((coe,iddecl),indpar,s,k,lc),ntn) = + let pr_oneind key (((coe,iddecl),indpar,s,lc),ntn) = hov 0 ( str key ++ spc() ++ (if coe then str"> " else str"") ++ pr_ident_decl iddecl ++ pr_and_type_binders_arg indpar ++ pr_opt (fun s -> str":" ++ spc() ++ pr_lconstr_expr env sigma s) s ++ - str" :=") ++ pr_constructor_list k lc ++ + str" :=") ++ pr_constructor_list lc ++ prlist (pr_decl_notation @@ pr_constr env sigma) ntn in let key = - let (_,_,_,k,_),_ = List.hd l in let kind = - match k with Record -> "Record" | Structure -> "Structure" + match f with Record -> "Record" | Structure -> "Structure" | Inductive_kw -> "Inductive" | CoInductive -> "CoInductive" | Class _ -> "Class" | Variant -> "Variant" in @@ -1076,14 +1075,14 @@ let string_of_definition_object_kind = let open Decls in function let pr_br imp force x = let left,right = match imp with - | Impargs.Implicit -> str "[", str "]" - | Impargs.MaximallyImplicit -> str "{", str "}" - | Impargs.NotImplicit -> if force then str"(",str")" else mt(),mt() + | Glob_term.NonMaxImplicit -> str "[", str "]" + | Glob_term.MaxImplicit -> str "{", str "}" + | Glob_term.Explicit -> if force then str"(",str")" else mt(),mt() in left ++ x ++ right in let get_arguments_like s imp tl = - if s = None && imp = Impargs.NotImplicit then [], tl + if s = None && imp = Glob_term.Explicit then [], tl else let rec fold extra = function | RealArg arg :: tl when diff --git a/vernac/prettyp.ml b/vernac/prettyp.ml index b999ce9f3f..32c438c724 100644 --- a/vernac/prettyp.ml +++ b/vernac/prettyp.ml @@ -211,12 +211,10 @@ let pr_template_variables = function let print_polymorphism ref = let poly = Global.is_polymorphic ref in let template_poly = Global.is_template_polymorphic ref in - let template_checked = Global.is_template_checked ref in let template_variables = Global.get_template_polymorphic_variables ref in [ pr_global ref ++ str " is " ++ (if poly then str "universe polymorphic" else if template_poly then - (if not template_checked then str "assumed " else mt()) ++ str "template universe polymorphic " ++ h 0 (pr_template_variables template_variables) else str "not universe polymorphic") ] @@ -260,18 +258,18 @@ let implicit_name_of_pos = function | Constrexpr.ExplByPos (n,k) -> Anonymous let implicit_kind_of_status = function - | None -> Anonymous, NotImplicit - | Some (pos,_,(maximal,_)) -> implicit_name_of_pos pos, if maximal then MaximallyImplicit else Implicit + | None -> Anonymous, Glob_term.Explicit + | Some (pos,_,(maximal,_)) -> implicit_name_of_pos pos, if maximal then Glob_term.MaxImplicit else Glob_term.NonMaxImplicit let dummy = { - Vernacexpr.implicit_status = NotImplicit; + Vernacexpr.implicit_status = Glob_term.Explicit; name = Anonymous; recarg_like = false; notation_scope = None; } let is_dummy {Vernacexpr.implicit_status; name; recarg_like; notation_scope} = - name = Anonymous && not recarg_like && notation_scope = None && implicit_status = NotImplicit + name = Anonymous && not recarg_like && notation_scope = None && implicit_status = Glob_term.Explicit let rec main_implicits i renames recargs scopes impls = if renames = [] && recargs = [] && scopes = [] && impls = [] then [] @@ -283,8 +281,8 @@ let rec main_implicits i renames recargs scopes impls = let (name, implicit_status) = match renames, impls with | _, (Some _ as i) :: _ -> implicit_kind_of_status i - | name::_, _ -> (name,NotImplicit) - | [], (None::_ | []) -> (Anonymous, NotImplicit) + | name::_, _ -> (name,Glob_term.Explicit) + | [], (None::_ | []) -> (Anonymous, Glob_term.Explicit) in let notation_scope = match scopes with | scope :: _ -> Option.map CAst.make scope @@ -670,25 +668,35 @@ let gallina_print_syntactic_def env kn = Constrextern.without_specific_symbols [Notation.SynDefRule kn] (pr_glob_constr_env env) c) -let gallina_print_leaf_entry env sigma with_values ((sp,kn as oname),lobj) = +module DynHandle = Libobject.Dyn.Map(struct type 'a t = 'a -> Pp.t option end) + +let handle h (Libobject.Dyn.Dyn (tag, o)) = match DynHandle.find tag h with +| f -> f o +| exception Not_found -> None + +(* TODO: this kind of feature should not rely on the Libobject stack. There is + no reason that an object in the stack corresponds to a user-facing + declaration. It may have been so at the time this was written, but this + needs to be done in a more principled way. *) +let gallina_print_leaf_entry env sigma with_values ((sp, kn),lobj) = let sep = if with_values then " = " else " : " in match lobj with | AtomicObject o -> - let tag = object_tag o in - begin match (oname,tag) with - | (_,"VARIABLE") -> + let handler = + DynHandle.add Declare.Internal.objVariable begin fun _ -> (* Outside sections, VARIABLES still exist but only with universes constraints *) (try Some(print_named_decl env sigma (basename sp)) with Not_found -> None) - | (_,"CONSTANT") -> + end @@ + DynHandle.add Declare.Internal.objConstant begin fun _ -> Some (print_constant with_values sep (Constant.make1 kn) None) - | (_,"INDUCTIVE") -> + end @@ + DynHandle.add DeclareInd.Internal.objInductive begin fun _ -> Some (gallina_print_inductive (MutInd.make1 kn) None) - | (_,("AUTOHINT"|"GRAMMAR"|"SYNTAXCONSTANT"|"PPSYNTAX"|"TOKEN"|"CLASS"| - "COERCION"|"REQUIRE"|"END-SECTION"|"STRUCTURE")) -> None - (* To deal with forgotten cases... *) - | (_,s) -> None - end + end @@ + DynHandle.empty + in + handle handler o | ModuleObject _ -> let (mp,l) = KerName.repr kn in Some (print_module with_values ~mod_ops:Declaremods.mod_ops (MPdot (mp,l))) @@ -777,11 +785,18 @@ let print_full_context env sigma = let print_full_context_typ env sigma = print_context env sigma false None (Lib.contents ()) +module DynHandleF = Libobject.Dyn.Map(struct type 'a t = 'a -> Pp.t end) + +let handleF h (Libobject.Dyn.Dyn (tag, o)) = match DynHandleF.find tag h with +| f -> f o +| exception Not_found -> mt () + +(* TODO: see the comment for {!gallina_print_leaf_entry} *) let print_full_pure_context env sigma = let rec prec = function | ((_,kn),Lib.Leaf AtomicObject lobj)::rest -> - let pp = match object_tag lobj with - | "CONSTANT" -> + let handler = + DynHandleF.add Declare.Internal.objConstant begin fun _ -> let con = Global.constant_of_delta_kn kn in let cb = Global.lookup_constant con in let typ = cb.const_type in @@ -804,12 +819,16 @@ let print_full_pure_context env sigma = str "Primitive " ++ print_basename con ++ str " : " ++ cut () ++ pr_ltype_env env sigma typ) ++ str "." ++ fnl () ++ fnl () - | "INDUCTIVE" -> + end @@ + DynHandleF.add DeclareInd.Internal.objInductive begin fun _ -> let mind = Global.mind_of_delta_kn kn in let mib = Global.lookup_mind mind in pr_mutual_inductive_body (Global.env()) mind mib None ++ str "." ++ fnl () ++ fnl () - | _ -> mt () in + end @@ + DynHandleF.empty + in + let pp = handleF handler lobj in prec rest ++ pp | ((_,kn),Lib.Leaf ModuleObject _)::rest -> (* TODO: make it reparsable *) diff --git a/vernac/proof_using.ml b/vernac/proof_using.ml index cfb3248c7b..b329463cb0 100644 --- a/vernac/proof_using.ml +++ b/vernac/proof_using.ml @@ -140,7 +140,6 @@ let suggest_proof_using = ref false let () = Goptions.(declare_bool_option { optdepr = false; - optname = "suggest Proof using"; optkey = ["Suggest";"Proof";"Using"]; optread = (fun () -> !suggest_proof_using); optwrite = ((:=) suggest_proof_using) }) @@ -176,7 +175,6 @@ let proof_using_opt_name = ["Default";"Proof";"Using"] let () = Goptions.(declare_stringopt_option { optdepr = false; - optname = "default value for Proof using"; optkey = proof_using_opt_name; optread = (fun () -> Option.map using_to_string !value); optwrite = (fun b -> value := Option.map using_from_string b); diff --git a/vernac/record.ml b/vernac/record.ml index df9b4a0914..27bd390714 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -39,7 +39,6 @@ let primitive_flag = ref false let () = declare_bool_option { optdepr = false; - optname = "use of primitive projections"; optkey = ["Primitive";"Projections"]; optread = (fun () -> !primitive_flag) ; optwrite = (fun b -> primitive_flag := b) } @@ -48,7 +47,6 @@ let typeclasses_strict = ref false let () = declare_bool_option { optdepr = false; - optname = "strict typeclass resolution"; optkey = ["Typeclasses";"Strict";"Resolution"]; optread = (fun () -> !typeclasses_strict); optwrite = (fun b -> typeclasses_strict := b); } @@ -57,7 +55,6 @@ let typeclasses_unique = ref false let () = declare_bool_option { optdepr = false; - optname = "unique typeclass instances"; optkey = ["Typeclasses";"Unique";"Instances"]; optread = (fun () -> !typeclasses_unique); optwrite = (fun b -> typeclasses_unique := b); } @@ -446,8 +443,7 @@ let declare_structure ~cumulative finite ubinders univs paramimpls params templa univs) param_levels fields in - let template_check = Environ.check_template (Global.env ()) in - ComInductive.template_polymorphism_candidate ~template_check ~ctor_levels univs params + ComInductive.template_polymorphism_candidate ~ctor_levels univs params (Some (Sorts.sort_of_univ min_univ)) in match template with diff --git a/vernac/search.ml b/vernac/search.ml index 364dae7152..b8825c3b29 100644 --- a/vernac/search.ml +++ b/vernac/search.ml @@ -71,6 +71,14 @@ let iter_hypothesis ?pstate glnum (fn : GlobRef.t -> env -> constr -> unit) = let pfctxt = named_context e in iter_named_context_name_type iter_hyp pfctxt +(* FIXME: this is a Libobject hack that should be replaced with a proper + registration mechanism. *) +module DynHandle = Libobject.Dyn.Map(struct type 'a t = 'a -> unit end) + +let handle h (Libobject.Dyn.Dyn (tag, o)) = match DynHandle.find tag h with +| f -> f o +| exception Not_found -> () + (* General search over declarations *) let iter_declarations (fn : GlobRef.t -> env -> constr -> unit) = let env = Global.env () in @@ -78,13 +86,14 @@ let iter_declarations (fn : GlobRef.t -> env -> constr -> unit) = (Environ.named_context env); let iter_obj (sp, kn) lobj = match lobj with | AtomicObject o -> - begin match object_tag o with - | "CONSTANT" -> + let handler = + DynHandle.add Declare.Internal.objConstant begin fun _ -> let cst = Global.constant_of_delta_kn kn in let gr = GlobRef.ConstRef cst in let (typ, _) = Typeops.type_of_global_in_context (Global.env ()) gr in fn gr env typ - | "INDUCTIVE" -> + end @@ + DynHandle.add DeclareInd.Internal.objInductive begin fun _ -> let mind = Global.mind_of_delta_kn kn in let mib = Global.lookup_mind mind in let iter_packet i mip = @@ -97,8 +106,10 @@ let iter_declarations (fn : GlobRef.t -> env -> constr -> unit) = iter_constructors ind u fn env len in Array.iteri iter_packet mib.mind_packets - | _ -> () - end + end @@ + DynHandle.empty + in + handle handler o | _ -> () in try Declaremods.iter_all_segments iter_obj diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml index 45f40b1258..de02f7ecfb 100644 --- a/vernac/topfmt.ml +++ b/vernac/topfmt.ml @@ -359,7 +359,7 @@ let in_phase ~phase f x = default_phase := op; res with exn -> - let iexn = Backtrace.add_backtrace exn in + let iexn = Exninfo.capture exn in default_phase := op; Util.iraise iexn @@ -415,7 +415,7 @@ let with_output_to_file fname func input = close_out channel; output with reraise -> - let reraise = Backtrace.add_backtrace reraise in + let reraise = Exninfo.capture reraise in std_ft := Util.pi1 old_fmt; err_ft := Util.pi2 old_fmt; deep_ft := Util.pi3 old_fmt; diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib index 7b4924eaed..6e398d87ca 100644 --- a/vernac/vernac.mllib +++ b/vernac/vernac.mllib @@ -19,11 +19,9 @@ DeclareObl Canonical RecLemmas Library -Prettyp Lemmas ComCoercion Auto_ind_decl -Search Indschemes Obligations ComDefinition @@ -31,6 +29,8 @@ Classes ComPrimitive ComAssumption DeclareInd +Search +Prettyp ComInductive ComFixpoint ComProgramFixpoint diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index e98820bc98..e469323f50 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -609,27 +609,8 @@ let vernac_assumption ~atts discharge kind l nl = | DeclareDef.Discharge -> Dumpglob.dump_definition lid true "var") idl) l; ComAssumption.do_assumptions ~poly:atts.polymorphic ~program_mode:atts.program ~scope ~kind nl l -let set_template_check b = - let typing_flags = Environ.typing_flags (Global.env ()) in - Global.set_typing_flags { typing_flags with Declarations.check_template = b } - -let is_template_check () = - let typing_flags = Environ.typing_flags (Global.env ()) in - typing_flags.Declarations.check_template - -let () = - let tccheck = - { optdepr = true; - optname = "Template universe check"; - optkey = ["Template"; "Check"]; - optread = (fun () -> is_template_check ()); - optwrite = (fun b -> set_template_check b)} - in - declare_bool_option tccheck - let is_polymorphic_inductive_cumulativity = declare_bool_option_and_ref ~depr:false ~value:false - ~name:"Polymorphic inductive cumulativity" ~key:["Polymorphic"; "Inductive"; "Cumulativity"] let should_treat_as_cumulative cum poly = @@ -642,17 +623,18 @@ let should_treat_as_cumulative cum poly = else user_err Pp.(str "The NonCumulative prefix can only be used in a polymorphic context.") | None -> poly && is_polymorphic_inductive_cumulativity () -let get_uniform_inductive_parameters = - Goptions.declare_bool_option_and_ref - ~depr:false - ~name:"Uniform inductive parameters" - ~key:["Uniform"; "Inductive"; "Parameters"] - ~value:false - -let should_treat_as_uniform () = - if get_uniform_inductive_parameters () - then ComInductive.UniformParameters - else ComInductive.NonUniformParameters +let uniform_att = + let get_uniform_inductive_parameters = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:["Uniform"; "Inductive"; "Parameters"] + ~value:false + in + let open Attributes.Notations in + Attributes.bool_attribute ~name:"uniform" ~on:"uniform" ~off:"nonuniform" >>= fun u -> + let u = match u with Some u -> u | None -> get_uniform_inductive_parameters () in + let u = if u then ComInductive.UniformParameters else ComInductive.NonUniformParameters in + return u let vernac_record ~template udecl cum k poly finite records = let cumulative = should_treat_as_cumulative cum poly in @@ -681,25 +663,29 @@ let vernac_record ~template udecl cum k poly finite records = let extract_inductive_udecl (indl:(inductive_expr * decl_notation list) list) = match indl with | [] -> assert false - | (((coe,(id,udecl)),b,c,k,d),e) :: rest -> - let rest = List.map (fun (((coe,(id,udecl)),b,c,k,d),e) -> + | (((coe,(id,udecl)),b,c,d),e) :: rest -> + let rest = List.map (fun (((coe,(id,udecl)),b,c,d),e) -> if Option.has_some udecl then user_err ~hdr:"inductive udecl" Pp.(strbrk "Universe binders must be on the first inductive of the block.") - else (((coe,id),b,c,k,d),e)) + else (((coe,id),b,c,d),e)) rest in - udecl, (((coe,id),b,c,k,d),e) :: rest + udecl, (((coe,id),b,c,d),e) :: rest + +let finite_of_kind = let open Declarations in function + | Inductive_kw -> Finite + | CoInductive -> CoFinite + | Variant | Record | Structure | Class _ -> BiFinite (** When [poly] is true the type is declared polymorphic. When [lo] is true, then the type is declared private (as per the [Private] keyword). [finite] indicates whether the type is inductive, co-inductive or neither. *) -let vernac_inductive ~atts cum lo finite indl = - let template, poly = Attributes.(parse Notations.(template ++ polymorphic) atts) in +let vernac_inductive ~atts cum lo kind indl = let open Pp in let udecl, indl = extract_inductive_udecl indl in if Dumpglob.dump () then - List.iter (fun (((coe,lid), _, _, _, cstrs), _) -> + List.iter (fun (((coe,lid), _, _, cstrs), _) -> match cstrs with | Constructors cstrs -> Dumpglob.dump_definition lid false "ind"; @@ -708,16 +694,17 @@ let vernac_inductive ~atts cum lo finite indl = | _ -> () (* dumping is done by vernac_record (called below) *) ) indl; + let finite = finite_of_kind kind in let is_record = function - | ((_ , _ , _ , _, RecordDecl _), _) -> true + | ((_ , _ , _ , RecordDecl _), _) -> true | _ -> false in let is_constructor = function - | ((_ , _ , _ , _, Constructors _), _) -> true + | ((_ , _ , _ , Constructors _), _) -> true | _ -> false in - let is_defclass = match indl with - | [ ( id , bl , c , Class _, Constructors [l]), [] ] -> Some (id, bl, c, l) + let is_defclass = match kind, indl with + | Class _, [ ( id , bl , c , Constructors [l]), [] ] -> Some (id, bl, c, l) | _ -> None in if Option.has_some is_defclass then @@ -726,42 +713,42 @@ let vernac_inductive ~atts cum lo finite indl = let (coe, (lid, ce)) = l in let coe' = if coe then Some true else None in let f = AssumExpr ((make ?loc:lid.loc @@ Name lid.v), ce), - { rf_subclass = coe' ; rf_priority = None ; rf_notation = [] ; rf_canonical = true } in + { rf_subclass = coe' ; rf_priority = None ; rf_notation = [] ; rf_canonical = true } + in + let template, poly = Attributes.(parse Notations.(template ++ polymorphic) atts) in vernac_record ~template udecl cum (Class true) poly finite [id, bl, c, None, [f]] else if List.for_all is_record indl then (* Mutual record case *) - let check_kind ((_, _, _, kind, _), _) = match kind with - | Variant -> - user_err (str "The Variant keyword does not support syntax { ... }.") - | Record | Structure | Class _ | Inductive_kw | CoInductive -> () + let () = match kind with + | Variant -> + user_err (str "The Variant keyword does not support syntax { ... }.") + | Record | Structure | Class _ | Inductive_kw | CoInductive -> () in - let () = List.iter check_kind indl in - let check_where ((_, _, _, _, _), wh) = match wh with + let check_where ((_, _, _, _), wh) = match wh with | [] -> () | _ :: _ -> user_err (str "where clause not supported for records") in let () = List.iter check_where indl in - let unpack ((id, bl, c, _, decl), _) = match decl with + let unpack ((id, bl, c, decl), _) = match decl with | RecordDecl (oc, fs) -> (id, bl, c, oc, fs) | Constructors _ -> assert false (* ruled out above *) in - let ((_, _, _, kind, _), _) = List.hd indl in let kind = match kind with Class _ -> Class false | _ -> kind in let recordl = List.map unpack indl in + let template, poly = Attributes.(parse Notations.(template ++ polymorphic) atts) in vernac_record ~template udecl cum kind poly finite recordl else if List.for_all is_constructor indl then (* Mutual inductive case *) - let check_kind ((_, _, _, kind, _), _) = match kind with + let () = match kind with | (Record | Structure) -> user_err (str "The Record keyword is for types defined using the syntax { ... }.") | Class _ -> user_err (str "Inductive classes not supported") | Variant | Inductive_kw | CoInductive -> () in - let () = List.iter check_kind indl in - let check_name ((na, _, _, _, _), _) = match na with + let check_name ((na, _, _, _), _) = match na with | (true, _) -> user_err (str "Variant types do not handle the \"> Name\" \ syntax, which is reserved for records. Use the \":>\" \ @@ -769,26 +756,19 @@ let vernac_inductive ~atts cum lo finite indl = | _ -> () in let () = List.iter check_name indl in - let unpack (((_, id) , bl, c, _, decl), ntn) = match decl with + let unpack (((_, id) , bl, c, decl), ntn) = match decl with | Constructors l -> (id, bl, c, l), ntn | RecordDecl _ -> assert false (* ruled out above *) in let indl = List.map unpack indl in + let (template, poly), uniform = + Attributes.(parse Notations.(template ++ polymorphic ++ uniform_att) atts) + in let cumulative = should_treat_as_cumulative cum poly in - let uniform = should_treat_as_uniform () in - ComInductive.do_mutual_inductive ~template udecl indl ~cumulative ~poly ~private_ind:lo ~uniform finite + ComInductive.do_mutual_inductive ~template udecl indl ~cumulative ~poly + ~private_ind:lo ~uniform finite else user_err (str "Mixed record-inductive definitions are not allowed") -(* - - match indl with - | [ ( id , bl , c , Class _, Constructors [l]), [] ] -> - let f = - let (coe, ({loc;v=id}, ce)) = l in - let coe' = if coe then Some true else None in - (((coe', AssumExpr ((make ?loc @@ Name id), ce)), None), []) - in vernac_record cum (Class true) atts.polymorphic finite [id, bl, c, None, [f]] - *) let vernac_fixpoint_common ~atts discharge l = if Dumpglob.dump () then @@ -1238,7 +1218,6 @@ let vernac_generalizable ~local = let () = declare_bool_option { optdepr = false; - optname = "allow sprop"; optkey = ["Allow";"StrictProp"]; optread = (fun () -> Global.sprop_allowed()); optwrite = Global.set_allow_sprop } @@ -1246,7 +1225,6 @@ let () = let () = declare_bool_option { optdepr = false; - optname = "silent"; optkey = ["Silent"]; optread = (fun () -> !Flags.quiet); optwrite = ((:=) Flags.quiet) } @@ -1254,7 +1232,6 @@ let () = let () = declare_bool_option { optdepr = false; - optname = "implicit arguments"; optkey = ["Implicit";"Arguments"]; optread = Impargs.is_implicit_args; optwrite = Impargs.make_implicit_args } @@ -1262,7 +1239,6 @@ let () = let () = declare_bool_option { optdepr = false; - optname = "strict implicit arguments"; optkey = ["Strict";"Implicit"]; optread = Impargs.is_strict_implicit_args; optwrite = Impargs.make_strict_implicit_args } @@ -1270,7 +1246,6 @@ let () = let () = declare_bool_option { optdepr = false; - optname = "strong strict implicit arguments"; optkey = ["Strongly";"Strict";"Implicit"]; optread = Impargs.is_strongly_strict_implicit_args; optwrite = Impargs.make_strongly_strict_implicit_args } @@ -1278,7 +1253,6 @@ let () = let () = declare_bool_option { optdepr = false; - optname = "contextual implicit arguments"; optkey = ["Contextual";"Implicit"]; optread = Impargs.is_contextual_implicit_args; optwrite = Impargs.make_contextual_implicit_args } @@ -1286,7 +1260,6 @@ let () = let () = declare_bool_option { optdepr = false; - optname = "implicit status of reversible patterns"; optkey = ["Reversible";"Pattern";"Implicit"]; optread = Impargs.is_reversible_pattern_implicit_args; optwrite = Impargs.make_reversible_pattern_implicit_args } @@ -1294,7 +1267,6 @@ let () = let () = declare_bool_option { optdepr = false; - optname = "maximal insertion of implicit"; optkey = ["Maximal";"Implicit";"Insertion"]; optread = Impargs.is_maximal_implicit_args; optwrite = Impargs.make_maximal_implicit_args } @@ -1302,7 +1274,6 @@ let () = let () = declare_bool_option { optdepr = false; - optname = "coercion printing"; optkey = ["Printing";"Coercions"]; optread = (fun () -> !Constrextern.print_coercions); optwrite = (fun b -> Constrextern.print_coercions := b) } @@ -1310,7 +1281,6 @@ let () = let () = declare_bool_option { optdepr = false; - optname = "printing of existential variable instances"; optkey = ["Printing";"Existential";"Instances"]; optread = (fun () -> !Detyping.print_evar_arguments); optwrite = (:=) Detyping.print_evar_arguments } @@ -1318,7 +1288,6 @@ let () = let () = declare_bool_option { optdepr = false; - optname = "implicit arguments printing"; optkey = ["Printing";"Implicit"]; optread = (fun () -> !Constrextern.print_implicits); optwrite = (fun b -> Constrextern.print_implicits := b) } @@ -1326,7 +1295,6 @@ let () = let () = declare_bool_option { optdepr = false; - optname = "implicit arguments defensive printing"; optkey = ["Printing";"Implicit";"Defensive"]; optread = (fun () -> !Constrextern.print_implicits_defensive); optwrite = (fun b -> Constrextern.print_implicits_defensive := b) } @@ -1334,7 +1302,6 @@ let () = let () = declare_bool_option { optdepr = false; - optname = "projection printing using dot notation"; optkey = ["Printing";"Projections"]; optread = (fun () -> !Constrextern.print_projections); optwrite = (fun b -> Constrextern.print_projections := b) } @@ -1342,7 +1309,6 @@ let () = let () = declare_bool_option { optdepr = false; - optname = "notations printing"; optkey = ["Printing";"Notations"]; optread = (fun () -> not !Constrextern.print_no_symbol); optwrite = (fun b -> Constrextern.print_no_symbol := not b) } @@ -1350,7 +1316,6 @@ let () = let () = declare_bool_option { optdepr = false; - optname = "raw printing"; optkey = ["Printing";"All"]; optread = (fun () -> !Flags.raw_print); optwrite = (fun b -> Flags.raw_print := b) } @@ -1358,7 +1323,6 @@ let () = let () = declare_int_option { optdepr = false; - optname = "the level of inlining during functor application"; optkey = ["Inline";"Level"]; optread = (fun () -> Some (Flags.get_inline_level ())); optwrite = (fun o -> @@ -1368,7 +1332,6 @@ let () = let () = declare_bool_option { optdepr = false; - optname = "kernel term sharing"; optkey = ["Kernel"; "Term"; "Sharing"]; optread = (fun () -> (Global.typing_flags ()).Declarations.share_reduction); optwrite = Global.set_share_reduction } @@ -1376,7 +1339,6 @@ let () = let () = declare_bool_option { optdepr = false; - optname = "display compact goal contexts"; optkey = ["Printing";"Compact";"Contexts"]; optread = (fun () -> Printer.get_compact_context()); optwrite = (fun b -> Printer.set_compact_context b) } @@ -1384,7 +1346,6 @@ let () = let () = declare_int_option { optdepr = false; - optname = "the printing depth"; optkey = ["Printing";"Depth"]; optread = Topfmt.get_depth_boxes; optwrite = Topfmt.set_depth_boxes } @@ -1392,7 +1353,6 @@ let () = let () = declare_int_option { optdepr = false; - optname = "the printing width"; optkey = ["Printing";"Width"]; optread = Topfmt.get_margin; optwrite = Topfmt.set_margin } @@ -1400,7 +1360,6 @@ let () = let () = declare_bool_option { optdepr = false; - optname = "printing of universes"; optkey = ["Printing";"Universes"]; optread = (fun () -> !Constrextern.print_universes); optwrite = (fun b -> Constrextern.print_universes:=b) } @@ -1408,7 +1367,6 @@ let () = let () = declare_bool_option { optdepr = false; - optname = "dumping bytecode after compilation"; optkey = ["Dump";"Bytecode"]; optread = (fun () -> !Cbytegen.dump_bytecode); optwrite = (:=) Cbytegen.dump_bytecode } @@ -1416,7 +1374,6 @@ let () = let () = declare_bool_option { optdepr = false; - optname = "dumping VM lambda code after compilation"; optkey = ["Dump";"Lambda"]; optread = (fun () -> !Clambda.dump_lambda); optwrite = (:=) Clambda.dump_lambda } @@ -1424,7 +1381,6 @@ let () = let () = declare_bool_option { optdepr = false; - optname = "explicitly parsing implicit arguments"; optkey = ["Parsing";"Explicit"]; optread = (fun () -> !Constrintern.parsing_explicit); optwrite = (fun b -> Constrintern.parsing_explicit := b) } @@ -1432,7 +1388,6 @@ let () = let () = declare_string_option ~preprocess:CWarnings.normalize_flags_string { optdepr = false; - optname = "warnings display"; optkey = ["Warnings"]; optread = CWarnings.get_flags; optwrite = CWarnings.set_flags } @@ -1440,7 +1395,6 @@ let () = let () = declare_string_option { optdepr = false; - optname = "native_compute profiler output"; optkey = ["NativeCompute"; "Profile"; "Filename"]; optread = Nativenorm.get_profile_filename; optwrite = Nativenorm.set_profile_filename } @@ -1448,15 +1402,20 @@ let () = let () = declare_bool_option { optdepr = false; - optname = "enable native compute profiling"; optkey = ["NativeCompute"; "Profiling"]; optread = Nativenorm.get_profiling_enabled; optwrite = Nativenorm.set_profiling_enabled } +let () = + declare_bool_option + { optdepr = false; + optkey = ["NativeCompute"; "Timing"]; + optread = Nativenorm.get_timing_enabled; + optwrite = Nativenorm.set_timing_enabled } + let _ = declare_bool_option { optdepr = false; - optname = "guard checking"; optkey = ["Guard"; "Checking"]; optread = (fun () -> (Global.typing_flags ()).Declarations.check_guarded); optwrite = (fun b -> Global.set_check_guarded b) } @@ -1464,7 +1423,6 @@ let _ = let _ = declare_bool_option { optdepr = false; - optname = "positivity/productivity checking"; optkey = ["Positivity"; "Checking"]; optread = (fun () -> (Global.typing_flags ()).Declarations.check_positive); optwrite = (fun b -> Global.set_check_positive b) } @@ -1472,7 +1430,6 @@ let _ = let _ = declare_bool_option { optdepr = false; - optname = "universes checking"; optkey = ["Universe"; "Checking"]; optread = (fun () -> (Global.typing_flags ()).Declarations.check_universes); optwrite = (fun b -> Global.set_check_universes b) } @@ -1581,7 +1538,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 env sigma rc in + let sigma, c = 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 @@ -1787,7 +1744,6 @@ let search_output_name_only = ref false let () = declare_bool_option { optdepr = false; - optname = "output-name-only search"; optkey = ["Search";"Output";"Name";"Only"]; optread = (fun () -> !search_output_name_only); optwrite = (:=) search_output_name_only } diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index 1daa244986..8ead56dfdf 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -104,7 +104,6 @@ type coercion_flag = bool (* true = AddCoercion false = NoCoercion *) type instance_flag = bool option (* Some true = Backward instance; Some false = Forward instance, None = NoInstance *) type export_flag = bool (* true = Export; false = Import *) -type inductive_flag = Declarations.recursivity_kind type onlyparsing_flag = { onlyparsing : bool } (* Some v = Parse only; None = Print also. If v<>Current, it contains the name of the coq version @@ -165,7 +164,7 @@ type constructor_list_or_record_decl_expr = | Constructors of constructor_expr list | RecordDecl of lident option * (local_decl_expr * record_field_attr) list type inductive_expr = - ident_decl with_coercion * local_binder_expr list * constr_expr option * inductive_kind * + ident_decl with_coercion * local_binder_expr list * constr_expr option * constructor_list_or_record_decl_expr type one_inductive_expr = @@ -254,7 +253,7 @@ type vernac_one_argument_status = { name : Name.t; recarg_like : bool; notation_scope : string CAst.t option; - implicit_status : Impargs.implicit_kind; + implicit_status : Glob_term.binding_kind; } type vernac_argument_status = @@ -306,7 +305,7 @@ type nonrec vernac_expr = | VernacExactProof of constr_expr | VernacAssumption of (discharge * Decls.assumption_object_kind) * Declaremods.inline * (ident_decl list * constr_expr) with_coercion list - | VernacInductive of vernac_cumulative option * bool (* private *) * inductive_flag * (inductive_expr * decl_notation list) list + | VernacInductive of vernac_cumulative option * bool (* private *) * inductive_kind * (inductive_expr * decl_notation list) list | VernacFixpoint of discharge * fixpoint_expr list | VernacCoFixpoint of discharge * cofixpoint_expr list | VernacScheme of (lident option * scheme) list @@ -386,7 +385,7 @@ type nonrec vernac_expr = | VernacArguments of qualid or_by_notation * vernac_argument_status list (* Main arguments status list *) * - (Name.t * Impargs.implicit_kind) list list (* Extra implicit status lists *) * + (Name.t * Glob_term.binding_kind) list list (* Extra implicit status lists *) * arguments_modifier list | VernacReserve of simple_binder list | VernacGeneralizable of (lident list) option diff --git a/vernac/vernacinterp.ml b/vernac/vernacinterp.ml index c14fc78462..1ec09b6beb 100644 --- a/vernac/vernacinterp.ml +++ b/vernac/vernacinterp.ml @@ -65,7 +65,6 @@ let proof_mode_opt_name = ["Default";"Proof";"Mode"] let () = Goptions.declare_string_option Goptions.{ optdepr = false; - optname = "default proof mode" ; optkey = proof_mode_opt_name; optread = get_default_proof_mode_opt; optwrite = set_default_proof_mode_opt; @@ -249,7 +248,6 @@ let interp_qed_delayed_control ~proof ~info ~st ~control { CAst.loc; v=pe } = let () = let open Goptions in declare_int_option { optdepr = false; - optname = "the default timeout"; optkey = ["Default";"Timeout"]; optread = (fun () -> !default_timeout); optwrite = ((:=) default_timeout) } diff --git a/vernac/vernacstate.ml b/vernac/vernacstate.ml index c81a4abc1b..80b72225f0 100644 --- a/vernac/vernacstate.ml +++ b/vernac/vernacstate.ml @@ -124,7 +124,7 @@ module Proof_global = struct let () = CErrors.register_handler begin function | NoCurrentProof -> - CErrors.user_err Pp.(str "No focused proof (No proof-editing in progress).") + Pp.(str "No focused proof (No proof-editing in progress).") | _ -> raise CErrors.Unhandled end |