diff options
187 files changed, 2635 insertions, 1262 deletions
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 3a626796a6..b39e74ffee 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -62,6 +62,7 @@ before_script: # TODO figure out how to build doc for installed Coq .build-template: stage: stage-1 + interruptible: true artifacts: name: "$CI_JOB_NAME" paths: @@ -98,6 +99,7 @@ before_script: # Template for building Coq + stdlib, typical use: overload the switch .dune-template: stage: stage-1 + interruptible: true dependencies: [] script: - set -e @@ -117,6 +119,7 @@ before_script: .dune-ci-template: stage: stage-2 + interruptible: true needs: - build:edge+flambda:dune:dev dependencies: @@ -143,6 +146,7 @@ before_script: .doc-template: stage: stage-2 + interruptible: true dependencies: - not-a-real-job script: @@ -158,6 +162,7 @@ before_script: # set dependencies when using .test-suite-template: stage: stage-2 + interruptible: true dependencies: - not-a-real-job script: @@ -179,6 +184,7 @@ before_script: # set dependencies when using .validate-template: stage: stage-2 + interruptible: true dependencies: - not-a-real-job script: @@ -195,6 +201,7 @@ before_script: .ci-template: stage: stage-2 + interruptible: true script: - set -e - echo 'start:coq.test' @@ -218,6 +225,7 @@ before_script: .windows-template: stage: stage-1 + interruptible: true artifacts: name: "%CI_JOB_NAME%" paths: @@ -226,7 +234,7 @@ before_script: expire_in: 1 week dependencies: [] tags: - - windows + - windows-inria before_script: [] script: - call dev/ci/gitlab.bat @@ -320,6 +328,7 @@ lint: pkg:opam: stage: stage-1 + interruptible: true # OPAM will build out-of-tree so no point in importing artifacts dependencies: [] script: @@ -336,6 +345,7 @@ pkg:opam: .nix-template: image: nixorg/nix:latest # Minimal NixOS image which doesn't even contain git + interruptible: true stage: stage-1 variables: # By default we use coq.cachix.org as an extra substituter but this can be overridden @@ -622,13 +632,11 @@ 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 @@ -739,6 +747,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.ci b/Makefile.ci index 8315c16c64..10c3b027c3 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -38,6 +38,7 @@ CI_TARGETS= \ ci-paramcoq \ ci-perennial \ ci-quickchick \ + ci-reduction_effects \ ci-relation_algebra \ ci-rewriter \ ci-sf \ @@ -64,7 +65,7 @@ ci-math-classes: ci-bignums ci-corn: ci-math-classes -ci-fiat-crypto: ci-bedrock2 ci-coqprime ci-rewriter +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.doc b/Makefile.doc index 125a4b33d5..50c4acb416 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -129,6 +129,8 @@ doc/unreleased.rst: $(wildcard doc/changelog/00-title.rst doc/changelog/*/*.rst) # Standard library ###################################################################### +DOCLIBS=-R theories Coq -R plugins Coq -Q user-contrib/Ltac2 Ltac2 + ### Standard library (browsable html format) ifdef QUICK @@ -139,7 +141,7 @@ endif - rm -rf doc/stdlib/html $(MKDIR) doc/stdlib/html $(COQDOC) -q -d doc/stdlib/html --with-header doc/common/styles/html/$(HTMLSTYLE)/header.html --with-footer doc/common/styles/html/$(HTMLSTYLE)/footer.html --multi-index --html -g \ - -R theories Coq -R plugins Coq $(VFILES) + $(DOCLIBS) $(VFILES) mv doc/stdlib/html/index.html doc/stdlib/html/genindex.html doc/stdlib/index-list.html: doc/stdlib/index-list.html.template doc/stdlib/make-library-index @@ -178,12 +180,12 @@ doc/stdlib/FullLibrary.tex: doc/stdlib/Library.tex ifdef QUICK doc/stdlib/FullLibrary.coqdoc.tex: $(COQDOC) -q -boot --gallina --body-only --latex --stdout --utf8 \ - -R theories Coq -R plugins Coq $(VFILES) > $@ + $(DOCLIBS) $(VFILES) > $@ sed -i.tmp -e 's///g' $@ && rm $@.tmp else doc/stdlib/FullLibrary.coqdoc.tex: $(COQDOC) $(ALLVO) $(COQDOC) -q -boot --gallina --body-only --latex --stdout --utf8 \ - -R theories Coq -R plugins Coq $(VFILES) > $@ + $(DOCLIBS) $(VFILES) > $@ sed -i.tmp -e 's///g' $@ && rm $@.tmp endif diff --git a/Makefile.dune b/Makefile.dune index bafb40d55f..b433ed1b94 100644 --- a/Makefile.dune +++ b/Makefile.dune @@ -6,7 +6,7 @@ .PHONY: quickbyte quickopt quickide # Partial / quick developer targets .PHONY: refman-html stdlib-html apidoc # Documentation targets .PHONY: test-suite release # Accessory targets -.PHONY: ocheck ireport clean # Maintenance targets +.PHONY: fmt ocheck ireport clean # Maintenance targets # use DUNEOPT=--display=short for a more verbose build # DUNEOPT=--display=short @@ -36,6 +36,7 @@ help: @echo " - apidoc: build ML API documentation" @echo " - release: build Coq in release mode" @echo "" + @echo " - fmt: run ocamlformat on the codebase" @echo " - ocheck: build for all supported OCaml versions [requires OPAM]" @echo " - ireport: build with optimized flambda settings and emit an inline report" @echo " - clean: remove build directory and autogenerated files" @@ -100,6 +101,9 @@ apidoc: voboot release: voboot dune build $(DUNEOPT) -p coq +fmt: voboot + dune build @fmt + ocheck: voboot dune build $(DUNEOPT) @install --workspace=dev/dune-workspace.all 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/check.ml b/checker/check.ml index ffb2928d55..4ac5c56732 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -294,14 +294,22 @@ type intern_mode = Rec | Root | Dep (* Rec = standard, Root = -norec, Dep = depe (* Dependency graph *) let depgraph = ref LibraryMap.empty -let marshal_in_segment f ch = - try - let stop = input_binary_int ch in - let v = Analyze.instantiate (Analyze.parse_channel ch) in - let digest = Digest.input ch in +let marshal_in_segment ~validate ~value f ch = + if validate then + let v, stop, digest = + try + let stop = input_binary_int ch in + let v = Analyze.parse_channel ch in + let digest = Digest.input ch in + v, stop, digest + with _ -> + user_err (str "Corrupted file " ++ quote (str f)) + in + let () = Validate.validate ~debug:!Flags.debug value v in + let v = Analyze.instantiate v in Obj.obj v, stop, digest - with _ -> - user_err (str "Corrupted file " ++ quote (str f)) + else + System.marshal_in_segment f ch let skip_in_segment f ch = try @@ -312,30 +320,26 @@ let skip_in_segment f ch = with _ -> user_err (str "Corrupted file " ++ quote (str f)) -let marshal_or_skip ~intern_mode f ch = - if intern_mode <> Dep then - let v, pos, digest = marshal_in_segment f ch in +let marshal_or_skip ~validate ~value f ch = + if validate then + let v, pos, digest = marshal_in_segment ~validate ~value f ch in Some v, pos, digest else let pos, digest = skip_in_segment f ch in None, pos, digest let intern_from_file ~intern_mode (dir, f) = - let validate a b c = if intern_mode <> Dep then Validate.validate a b c in + let validate = intern_mode <> Dep in Flags.if_verbose chk_pp (str"[intern "++str f++str" ..."); let (sd,md,table,opaque_csts,digest) = try - let marshal_in_segment f ch = if intern_mode <> Dep - then marshal_in_segment f ch - else System.marshal_in_segment f ch - in let ch = System.with_magic_number_check raw_intern_library f in - let (sd:summary_disk), _, digest = marshal_in_segment f ch in - let (md:library_disk), _, digest = marshal_in_segment f ch in - let (opaque_csts:seg_univ option), _, udg = marshal_in_segment f ch in - let (tasks:'a option), _, _ = marshal_in_segment f ch in + let (sd:summary_disk), _, digest = marshal_in_segment ~validate ~value:Values.v_libsum f ch in + let (md:library_disk), _, digest = marshal_in_segment ~validate ~value:Values.v_lib f ch in + let (opaque_csts:seg_univ option), _, udg = marshal_in_segment ~validate ~value:Values.v_univopaques f ch in + let (tasks:'a option), _, _ = marshal_in_segment ~validate ~value:Values.(Opt Any) f ch in let (table:seg_proofs option), pos, checksum = - marshal_or_skip ~intern_mode f ch in + marshal_or_skip ~validate ~value:Values.v_opaquetable f ch in (* Verification of the final checksum *) let () = close_in ch in let ch = open_in_bin f in @@ -354,12 +358,7 @@ let intern_from_file ~intern_mode (dir, f) = user_err ~hdr:"intern_from_file" (str "The file "++str f++str " is still a .vio")) opaque_csts; - validate !Flags.debug Values.v_univopaques opaque_csts; end; - (* Verification of the unmarshalled values *) - validate !Flags.debug Values.v_libsum sd; - validate !Flags.debug Values.v_lib md; - validate !Flags.debug Values.(Opt v_opaquetable) table; Flags.if_verbose chk_pp (str" done]" ++ fnl ()); let digest = if opaque_csts <> None then Safe_typing.Dvivo (digest,udg) diff --git a/checker/checkInductive.ml b/checker/checkInductive.ml index 06ee4fcc7a..a2cf44389e 100644 --- a/checker/checkInductive.ml +++ b/checker/checkInductive.ml @@ -73,7 +73,7 @@ let check_arity env ar1 ar2 = match ar1, ar2 with List.equal (Option.equal Univ.Level.equal) ar.template_param_levels template_param_levels && 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 _), _ -> false + | (RegularArity _ | TemplateArity _), _ -> assert false let check_kelim k1 k2 = Sorts.family_leq k1 k2 @@ -139,16 +139,22 @@ let check_inductive env mind mb = let entry = to_entry mb in let { mind_packets; mind_record; mind_finite; mind_ntypes; mind_hyps; mind_nparams; mind_nparams_rec; mind_params_ctxt; - mind_universes; mind_variance; + mind_universes; mind_variance; mind_sec_variance; mind_private; mind_typing_flags; } = (* 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 - Indtypes.check_inductive env mind entry + 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; + check_template = mb_flags.check_template; + conv_oracle = mb_flags.conv_oracle; + } + env + in + Indtypes.check_inductive env ~sec_univs:None mind entry in let check = check mind in @@ -165,7 +171,9 @@ let check_inductive env mind mb = check "mind_params_ctxt" (Context.Rel.equal Constr.equal mb.mind_params_ctxt mind_params_ctxt); ignore mind_universes; (* Indtypes did the necessary checking *) - ignore mind_variance; (* Indtypes did the necessary checking *) + check "mind_variance" (Option.equal (Array.equal Univ.Variance.equal) + mb.mind_variance mind_variance); + check "mind_sec_variance" (Option.is_empty mind_sec_variance); ignore mind_private; (* passed through Indtypes *) ignore mind_typing_flags; diff --git a/checker/check_stat.ml b/checker/check_stat.ml index a67945ae94..d115744707 100644 --- a/checker/check_stat.ml +++ b/checker/check_stat.ml @@ -56,6 +56,9 @@ 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 pr_unsafe_template env = + let inds = fold_inductives (fun c cb acc -> if not cb.mind_typing_flags.check_template then MutInd.to_string c :: acc else acc) env [] in + pr_assumptions "Inductives using unchecked template polymorphism" inds let print_context env = if !output_context then begin @@ -67,7 +70,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()) ++ fnl() ++ + str "* " ++ hov 0 (pr_unsafe_template env))) end let stats env = diff --git a/checker/validate.ml b/checker/validate.ml index 070a112bb6..6ffc43394b 100644 --- a/checker/validate.ml +++ b/checker/validate.ml @@ -8,32 +8,39 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +open Analyze + (* This module defines validation functions to ensure an imported value (using input_value) has the correct structure. *) -let rec pr_obj_rec o = - if Obj.is_int o then - Format.print_int(Obj.magic o) - else if Obj.is_block o then - let t = Obj.tag o in - if t > Obj.no_scan_tag then - if t = Obj.string_tag then - Format.print_string ("\""^String.escaped(Obj.magic o)^"\"") - else - Format.print_string "?" - else - (let n = Obj.size o in - Format.print_string ("#"^string_of_int t^"("); - Format.open_hvbox 0; - for i = 0 to n-1 do - pr_obj_rec (Obj.field o i); - if i<>n-1 then (Format.print_string ","; Format.print_cut()) - done; - Format.close_box(); - Format.print_string ")") - else Format.print_string "?" - -let pr_obj o = pr_obj_rec o; Format.print_newline() +let rec pr_obj_rec mem o = match o with +| Int i -> + Format.print_int i +| Ptr p -> + let v = LargeArray.get mem p in + begin match v with + | Struct (tag, data) -> + let n = Array.length data in + Format.print_string ("#"^string_of_int tag^"("); + Format.open_hvbox 0; + for i = 0 to n-1 do + pr_obj_rec mem (Array.get data i); + if i<>n-1 then (Format.print_string ","; Format.print_cut()) + done; + Format.close_box(); + Format.print_string ")" + | String s -> + Format.print_string ("\""^String.escaped s^"\"") + | Int64 _ + | Float64 _ -> + Format.print_string "?" + end +| Atm tag -> + Format.print_string ("#"^string_of_int tag^"()"); +| Fun addr -> + Format.printf "fun@%x" addr + +let pr_obj mem o = pr_obj_rec mem o; Format.print_newline() (**************************************************************************) (* Obj low-level validators *) @@ -48,63 +55,115 @@ type error_context = error_frame list let mt_ec : error_context = [] let (/) (ctx:error_context) s : error_context = s::ctx -exception ValidObjError of string * error_context * Obj.t -let fail ctx o s = raise (ValidObjError(s,ctx,o)) +exception ValidObjError of string * error_context * data +let fail _mem ctx o s = raise (ValidObjError(s,ctx,o)) + +let is_block mem o = match o with +| Ptr _ | Atm _ -> true +| Fun _ | Int _ -> false + +let is_int _mem o = match o with +| Int _ -> true +| Fun _ | Ptr _ | Atm _ -> false + +let is_int64 mem o = match o with +| Int _ | Fun _ | Atm _ -> false +| Ptr p -> + match LargeArray.get mem p with + | Int64 _ -> true + | Float64 _ | Struct _ | String _ -> false + +let is_float64 mem o = match o with +| Int _ | Fun _ | Atm _ -> false +| Ptr p -> + match LargeArray.get mem p with + | Float64 _ -> true + | Int64 _ | Struct _ | String _ -> false + +let get_int _mem = function +| Int i -> i +| Fun _ | Ptr _ | Atm _ -> assert false + +let tag mem o = match o with +| Atm tag -> tag +| Fun _ -> Obj.out_of_heap_tag +| Int _ -> Obj.int_tag +| Ptr p -> + match LargeArray.get mem p with + | Struct (tag, _) -> tag + | String _ -> Obj.string_tag + | Float64 _ -> Obj.double_tag + | Int64 _ -> Obj.custom_tag + +let size mem o = match o with +| Atm _ -> 0 +| Fun _ | Int _ -> assert false +| Ptr p -> + match LargeArray.get mem p with + | Struct (tag, blk) -> Array.length blk + | String _ | Float64 _ | Int64 _ -> assert false + +let field mem o i = match o with +| Atm _ | Fun _ | Int _ -> assert false +| Ptr p -> + match LargeArray.get mem p with + | Struct (tag, blk) -> Array.get blk i + | String _ | Float64 _ | Int64 _ -> assert false (* Check that object o is a block with tag t *) -let val_tag t ctx o = - if Obj.is_block o && Obj.tag o = t then () - else fail ctx o ("expected tag "^string_of_int t) - -let val_block ctx o = - if Obj.is_block o then - (if Obj.tag o > Obj.no_scan_tag then - fail ctx o "block: found no scan tag") - else fail ctx o "expected block obj" - -let val_dyn ctx o = - let fail () = fail ctx o "expected a Dyn.t" in - if not (Obj.is_block o) then fail () - else if not (Obj.size o = 2) then fail () - else if not (Obj.tag (Obj.field o 0) = Obj.int_tag) then fail () +let val_tag t mem ctx o = + if is_block mem o && tag mem o = t then () + else fail mem ctx o ("expected tag "^string_of_int t) + +let val_block mem ctx o = + if is_block mem o then + (if tag mem o > Obj.no_scan_tag then + fail mem ctx o "block: found no scan tag") + else fail mem ctx o "expected block obj" + +let val_dyn mem ctx o = + let fail () = fail mem ctx o "expected a Dyn.t" in + if not (is_block mem o) then fail () + else if not (size mem o = 2) then fail () + else if not (tag mem (field mem o 0) = Obj.int_tag) then fail () else () open Values -let rec val_gen v ctx o = match v with - | Tuple (name,vs) -> val_tuple ~name vs ctx o - | Sum (name,cc,vv) -> val_sum name cc vv ctx o - | Array v -> val_array v ctx o - | List v0 -> val_sum "list" 1 [|[|Annot ("elem",v0);v|]|] ctx o - | Opt v -> val_sum "option" 1 [|[|v|]|] ctx o - | Int -> if not (Obj.is_int o) then fail ctx o "expected an int" +let rec val_gen v mem ctx o = match v with + | Tuple (name,vs) -> val_tuple ~name vs mem ctx o + | Sum (name,cc,vv) -> val_sum name cc vv mem ctx o + | Array v -> val_array v mem ctx o + | List v0 -> val_sum "list" 1 [|[|Annot ("elem",v0);v|]|] mem ctx o + | Opt v -> val_sum "option" 1 [|[|v|]|] mem ctx o + | Int -> if not (is_int mem o) then fail mem ctx o "expected an int" | String -> - (try val_tag Obj.string_tag ctx o - with Failure _ -> fail ctx o "expected a string") + (try val_tag Obj.string_tag mem ctx o + with Failure _ -> fail mem ctx o "expected a string") | Any -> () - | Fail s -> fail ctx o ("unexpected object " ^ s) - | Annot (s,v) -> val_gen v (ctx/CtxAnnot s) o - | Dyn -> val_dyn ctx o - | Proxy { contents = v } -> val_gen v ctx o - | Uint63 -> val_uint63 ctx o - | Float64 -> val_float64 ctx o + | Fail s -> fail mem ctx o ("unexpected object " ^ s) + | Annot (s,v) -> val_gen v mem (ctx/CtxAnnot s) o + | Dyn -> val_dyn mem ctx o + | Proxy { contents = v } -> val_gen v mem ctx o + | Int64 -> val_int64 mem ctx o + | Float64 -> val_float64 mem ctx o (* Check that an object is a tuple (or a record). vs is an array of value representation for each field. Its size corresponds to the expected size of the object. *) -and val_tuple ?name vs ctx o = +and val_tuple ?name vs mem ctx o = let ctx = match name with | Some n -> ctx/CtxType n | _ -> ctx in let n = Array.length vs in let val_fld i v = - val_gen v (ctx/(CtxField i)) (Obj.field o i) in - val_block ctx o; - if Obj.size o = n then Array.iteri val_fld vs + val_gen v mem (ctx/(CtxField i)) (field mem o i) in + val_block mem ctx o; + if size mem o = n then Array.iteri val_fld vs else - fail ctx o - ("tuple size: found "^string_of_int (Obj.size o)^ + fail mem ctx o + ("tuple size: found "^string_of_int (size mem o)^ ", expected "^string_of_int n) (* Check that the object is either a constant constructor of tag < cc, @@ -113,35 +172,35 @@ and val_tuple ?name vs ctx o = The size of vv corresponds to the number of non-constant constructors, and the size of vv.(i) is the expected arity of the i-th non-constant constructor. *) -and val_sum name cc vv ctx o = +and val_sum name cc vv mem ctx o = let ctx = ctx/CtxType name in - if Obj.is_block o then - (val_block ctx o; + if is_block mem o then + (val_block mem ctx o; let n = Array.length vv in - let i = Obj.tag o in + let i = tag mem o in let ctx' = if n=1 then ctx else ctx/CtxTag i in - if i < n then val_tuple vv.(i) ctx' o - else fail ctx' o ("sum: unexpected tag")) - else if Obj.is_int o then - let (n:int) = Obj.magic o in + if i < n then val_tuple vv.(i) mem ctx' o + else fail mem ctx' o ("sum: unexpected tag")) + else if is_int mem o then + let (n:int) = get_int mem o in (if n<0 || n>=cc then - fail ctx o ("bad constant constructor "^string_of_int n)) - else fail ctx o "not a sum" + fail mem ctx o ("bad constant constructor "^string_of_int n)) + else fail mem ctx o "not a sum" (* Check the o is an array of values satisfying f. *) -and val_array v ctx o = - val_block (ctx/CtxType "array") o; - for i = 0 to Obj.size o - 1 do - val_gen v ctx (Obj.field o i) +and val_array v mem ctx o = + val_block mem (ctx/CtxType "array") o; + for i = 0 to size mem o - 1 do + val_gen v mem ctx (field mem o i) done -and val_uint63 ctx o = - if not (Uint63.is_uint63 o) then - fail ctx o "not a 63-bit unsigned integer" +and val_int64 mem ctx o = + if not (is_int64 mem o) then + fail mem ctx o "not a 63-bit unsigned integer" -and val_float64 ctx o = - if not (Float64.is_float64 o) then - fail ctx o "not a 64-bit float" +and val_float64 mem ctx o = + if not (is_float64 mem o) then + fail mem ctx o "not a 64-bit float" let print_frame = function | CtxType t -> t @@ -149,12 +208,11 @@ let print_frame = function | CtxField i -> Printf.sprintf "fld=%i" i | CtxTag i -> Printf.sprintf "tag=%i" i -let validate debug v x = - let o = Obj.repr x in - try val_gen v mt_ec o +let validate ~debug v (o, mem) = + try val_gen v mem mt_ec o with ValidObjError(msg,ctx,obj) -> (if debug then let ctx = List.rev_map print_frame ctx in print_endline ("Context: "^String.concat"/"ctx); - pr_obj obj); + pr_obj mem obj); failwith ("Validation failed: "^msg^" (in "^(print_frame (List.hd ctx))^")") diff --git a/checker/validate.mli b/checker/validate.mli index fbcea3121b..584ea6ed95 100644 --- a/checker/validate.mli +++ b/checker/validate.mli @@ -8,4 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -val validate : bool -> Values.value -> 'a -> unit +open Analyze + +val validate : debug:bool -> Values.value -> data * obj LargeArray.t -> unit diff --git a/checker/values.ml b/checker/values.ml index 56321a27ff..fff166f27b 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -34,7 +34,7 @@ type value = | Dyn | Proxy of value ref - | Uint63 + | Int64 | Float64 let fix (f : value -> value) : value = @@ -129,6 +129,9 @@ let v_cast = v_enum "cast_kind" 4 let v_proj_repr = v_tuple "projection_repr" [|v_ind;Int;Int;v_id|] let v_proj = v_tuple "projection" [|v_proj_repr; v_bool|] +let v_uint63 = + if Sys.word_size == 64 then Int else Int64 + let rec v_constr = Sum ("constr",0,[| [|Int|]; (* Rel *) @@ -148,7 +151,7 @@ let rec v_constr = [|v_fix|]; (* Fix *) [|v_cofix|]; (* CoFix *) [|v_proj;v_constr|]; (* Proj *) - [|Uint63|]; (* Int *) + [|v_uint63|]; (* Int *) [|Float64|] (* Int *) |]) @@ -299,6 +302,7 @@ let v_ind_pack = v_tuple "mutual_inductive_body" v_rctxt; v_univs; (* universes *) Opt (Array v_variance); + Opt (Array v_variance); Opt v_bool; v_typing_flags|] diff --git a/checker/values.mli b/checker/values.mli index ec3b91d5dd..15d307ee29 100644 --- a/checker/values.mli +++ b/checker/values.mli @@ -38,7 +38,7 @@ type value = | Proxy of value ref (** Same as the inner value, used to define recursive types *) - | Uint63 + | Int64 | Float64 (** NB: List and Opt have their own constructors to make it easy to diff --git a/checker/votour.ml b/checker/votour.ml index 9adcc874ac..452809f7bb 100644 --- a/checker/votour.ml +++ b/checker/votour.ml @@ -157,7 +157,7 @@ let rec get_name ?(extra=false) = function |Annot (s,v) -> s^"/"^get_name ~extra v |Dyn -> "<dynamic>" | Proxy v -> get_name ~extra !v - | Uint63 -> "Uint63" + | Int64 -> "Int64" | Float64 -> "Float64" (** For tuples, its quite handy to display the inner 1st string (if any). @@ -263,7 +263,7 @@ let rec get_children v o pos = match v with end |Fail s -> raise Forbidden | Proxy v -> get_children !v o pos - | Uint63 -> raise Exit + | Int64 -> raise Exit | Float64 -> raise Exit let get_children v o pos = 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,8 +28,7 @@ depends: [ ] build: [ - [ "./configure" "-prefix" prefix "-native-compiler" "no" ] - [ "dune" "build" "@vodeps" ] - [ "dune" "exec" "coq_dune" "_build/default/.vfiles.d" ] + [ "./configure" "-prefix" prefix ] + [ "make" "-f" "Makefile.dune" "voboot" ] [ "dune" "build" "-p" name "-j" jobs ] ] diff --git a/dev/build/windows/MakeCoq_MinGW.bat b/dev/build/windows/MakeCoq_MinGW.bat index c75acb0560..577ce35aae 100755 --- a/dev/build/windows/MakeCoq_MinGW.bat +++ b/dev/build/windows/MakeCoq_MinGW.bat @@ -420,6 +420,7 @@ copy "%BATCHDIR%\configure_profile.sh" "%CYGWIN_INSTALLDIR_WFMT%\var\tmp" || GOT ECHO ========== BUILD COQ ==========
MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build"
+RMDIR /S /Q "%CYGWIN_INSTALLDIR_WFMT%\build\patches"
MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build\patches"
COPY "%BATCHDIR%\makecoq_mingw.sh" "%CYGWIN_INSTALLDIR_WFMT%\build" || GOTO ErrorExit
diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index f04de0ce6c..7342bc72e7 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -97,8 +97,11 @@ ######################################################################## # Coquelicot ######################################################################## -: "${coquelicot_CI_REF:=master}" -: "${coquelicot_CI_GITURL:=https://gitlab.inria.fr/coquelicot/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_ARCHIVEURL:=${coquelicot_CI_GITURL}/-/archive}" ######################################################################## @@ -256,6 +259,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 index 2af4b58201..9ce5da9f50 100755 --- a/dev/ci/ci-fiat-crypto-legacy.sh +++ b/dev/ci/ci-fiat-crypto-legacy.sh @@ -6,8 +6,8 @@ ci_dir="$(dirname "$0")" 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" +fiat_crypto_legacy_CI_TARGETS1="print-old-pipeline-lite-hardcoded old-pipeline-lite-hardcoded lite-display-hardcoded" +fiat_crypto_legacy_CI_TARGETS2="print-old-pipeline-nobigmem-hardcoded old-pipeline-nobigmem-hardcoded nonautogenerated-specific nonautogenerated-specific-display" ( cd "${CI_BUILD_DIR}/fiat_crypto_legacy" && git submodule update --init --recursive && \ ./etc/ci/remove_autogenerated.sh && \ 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-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-sf.sh b/dev/ci/ci-sf.sh index 2b1d2298f2..b9d6215e60 100755 --- a/dev/ci/ci-sf.sh +++ b/dev/ci/ci-sf.sh @@ -4,7 +4,10 @@ ci_dir="$(dirname "$0")" . "${ci_dir}/ci-common.sh" CIRCLE_SF_TOKEN=00127070c10f5f09574b050e4f08e924764680d2 -data=$(wget https://circleci.com/api/v1.1/project/gh/DeepSpec/sfdev/latest/artifacts?circle-token=${CIRCLE_SF_TOKEN} -O -) + +# "latest" is disabled due to lack of build credits upstream, thus artifacts fail +# data=$(wget https://circleci.com/api/v1.1/project/gh/DeepSpec/sfdev/latest/artifacts?circle-token=${CIRCLE_SF_TOKEN} -O -) +data=$(wget https://circleci.com/api/v1.1/project/gh/DeepSpec/sfdev/1411/artifacts?circle-token=${CIRCLE_SF_TOKEN} -O -) mkdir -p "${CI_BUILD_DIR}" && cd "${CI_BUILD_DIR}" diff --git a/dev/ci/user-overlays/11368-trailing-implicit-error.sh b/dev/ci/user-overlays/11368-trailing-implicit-error.sh new file mode 100644 index 0000000000..a125337dd9 --- /dev/null +++ b/dev/ci/user-overlays/11368-trailing-implicit-error.sh @@ -0,0 +1,33 @@ +if [ "$CI_PULL_REQUEST" = "11368" ] || [ "$CI_BRANCH" = "trailing_implicit_error" ]; then + + mathcomp_CI_REF=non_maximal_implicit + mathcomp_CI_GITURL=https://github.com/SimonBoulier/math-comp + + oddorder_CI_REF=non_maximal_implicit + oddorder_CI_GITURL=https://github.com/SimonBoulier/odd-order + + stdlib2_CI_REF=non_maximal_implicit + stdlib2_CI_GITURL=https://github.com/SimonBoulier/stdlib2 + + coq_dpdgraph_CI_REF=non_maximal_implicit + coq_dpdgraph_CI_GITURL=https://github.com/SimonBoulier/coq-dpdgraph + + vst_CI_REF=non_maximal_implicit + vst_CI_GITURL=https://github.com/SimonBoulier/VST + + equations_CI_REF=non_maximal_implicit + equations_CI_GITURL=https://github.com/SimonBoulier/Coq-Equations + + mtac2_CI_REF=non_maximal_implicit + mtac2_CI_GITURL=https://github.com/SimonBoulier/Mtac2 + + relation_algebra_CI_REF=non_maximal_implicit + relation_algebra_CI_GITURL=https://github.com/SimonBoulier/relation-algebra + + fiat_parsers_CI_REF=non_maximal_implicit + fiat_parsers_CI_GITURL=https://github.com/SimonBoulier/fiat + + Corn_CI_REF=non_maximal_implicit + Corn_CI_GITURL=https://github.com/SimonBoulier/corn + +fi diff --git a/dev/doc/build-system.dune.md b/dev/doc/build-system.dune.md index 37c6e2f619..cd35064b18 100644 --- a/dev/doc/build-system.dune.md +++ b/dev/doc/build-system.dune.md @@ -108,24 +108,44 @@ automatically. You can use `ocamldebug` with Dune; after a build, do: ``` -dune exec -- dev/dune-dbg /path/to/foo.v +dune exec -- dev/dune-dbg coqc foo.v (ocd) source dune_db ``` -or +to start `coqc.byte foo.v`, other targets are `{checker,coqide,coqtop}`: ``` -dune exec -- dev/dune-dbg checker Foo +dune exec -- dev/dune-dbg checker foo.vo (ocd) source dune_db ``` -for the checker. Unfortunately, dependency handling here is not fully -refined, so you need to build enough of Coq once to use this target -[it will then correctly compute the deps and rebuild if you call the -script again] This will be fixed in the future. +Unfortunately, dependency handling here is not fully refined, so you +need to build enough of Coq once to use this target [it will then +correctly compute the deps and rebuild if you call the script again] +This will be fixed in the future. For running in emacs, use `coqdev-ocamldebug` from `coqdev.el`. +**Note**: If you are using OCaml >= 4.08 you need to use + +``` +(ocd) source dune_db_408 +``` + +or + +``` +(ocd) source dune_db_409 +``` + +depending on your OCaml version. This is due to several factors: + +- OCaml >= 4.08 doesn't allow doubly-linking modules, however `source` + is not re entrant and seems to doubly-load in the default setup, see + https://github.com/coq/coq/issues/8952 +- OCaml >= 4.09 comes with `dynlink` already linked in so we need to + modify the list of modules loaded. + ## Dropping from coqtop: After doing `make -f Makefile.dune voboot`, the following commands should work: diff --git a/dev/doc/changes.md b/dev/doc/changes.md index 04b20c6889..3bc92e6aee 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 diff --git a/dev/doc/critical-bugs b/dev/doc/critical-bugs index 2d187f7bae..3260040248 100644 --- a/dev/doc/critical-bugs +++ b/dev/doc/critical-bugs @@ -158,7 +158,7 @@ Universes component: universe polymorphism, asynchronous proofs summary: universe constraints erroneously discarded when forcing an asynchronous proof containing delayed monomorphic constraints inside a universe polymorphic section introduced: between 8.4 and 8.5 by merging the asynchronous proofs feature branch and universe polymorphism one - impacted released: V8.5-V8.10 + impacted released versions: V8.5-V8.10 impacted development branches: none impacted coqchk versions: immune fixed in: PR#10664 @@ -167,6 +167,19 @@ Universes GH issue number: none risk: unlikely to be triggered in interactive mode, not present in batch mode (i.e. coqc) + component: algebraic universes + summary: Set+2 was incorrectly simplified to Set+1 + introduced: V8.10 (with the SProp commit 75508769762372043387c67a9abe94e8f940e80a) + impacted released versions: V8.10.0 V8.10.1 V8.10.2 + impacted coqchk versions: same + fixed in: PR#11422 + found by: Gilbert + exploit: see PR (custom application of Hurkens to get around the refreshing at elaboration) + GH issue number: see PR + risk: unlikely to be triggered through the vernacular (the system "refreshes" algebraic + universes such that +2 increments do not appear), mild risk from plugins which manipulate + algebraic universes. + Primitive projections component: primitive projections, guard condition diff --git a/dev/doc/release-process.md b/dev/doc/release-process.md index 1c486b024d..ba68501e04 100644 --- a/dev/doc/release-process.md +++ b/dev/doc/release-process.md @@ -75,7 +75,8 @@ in time. - [ ] Pin the versions of libraries and plugins in `dev/ci/ci-basic-overlays.sh` to use commit hashes or tag (or, if it exists, a branch dedicated to compatibility with the corresponding - Coq branch). + Coq branch). You can use the `dev/tools/pin-ci.sh` script to do this + semi-automatically. - [ ] Remove all remaining unmerged feature PRs from the beta milestone. - [ ] Start a new project to track PR backporting. The project should have a "Request X.X+beta1 inclusion" column for the PRs that were diff --git a/dev/doc/xml-protocol.md b/dev/doc/xml-protocol.md index 0fc0a413ba..fca7b77fc2 100644 --- a/dev/doc/xml-protocol.md +++ b/dev/doc/xml-protocol.md @@ -1,12 +1,11 @@ # Coq XML Protocol This document is based on documentation originally written by CJ Bell -for his [vscoq](https://github.com/siegebell/vscoq/) project. +for his [vscoq](https://github.com/coq-community/vscoq/) project. Here, the aim is to provide a "hands on" description of the XML protocol that coqtop and IDEs use to communicate. The protocol first appeared -with Coq 8.5, and is used by CoqIDE. It will also be used in upcoming -versions of Proof General. +with Coq 8.5, and is used by CoqIDE, [vscoq](https://github.com/coq-community/vscoq/), and other user interfaces. A somewhat out-of-date description of the async state machine is [documented here](https://github.com/ejgallego/jscoq/blob/v8.10/etc/notes/coq-notes.md). @@ -13,6 +13,8 @@ ../checker/coqchk.bc ../topbin/coqc_bin.bc ../ide/coqide_main.bc - ; This is not enough as the call to `ocamlfind` will fail :/ + %{lib:coq.plugins.ltac:ltac_plugin.cma} + ; This is not enough, the call to `ocamlfind` may fail if the + ; META file is not yet in place :/ top_printers.cma) (action (copy dune-dbg.in dune-dbg))) diff --git a/dev/dune-dbg.in b/dev/dune-dbg.in index 1382f4d1b6..498f167eb1 100755 --- a/dev/dune-dbg.in +++ b/dev/dune-dbg.in @@ -7,11 +7,21 @@ case $1 in exe=_build/default/checker/coqchk.bc ;; coqide) + shift exe=_build/default/ide/coqide_main.bc ;; - *) + coqc) + shift exe=_build/default/topbin/coqc_bin.bc ;; + coqtop) + shift + exe=_build/default/topbin/coqtop_byte_bin.bc + ;; + *) + echo "First argument must be one of {coqc,coqtop,checker,coqide}" + exit 1 + ;; esac emacs="${INSIDE_EMACS:+-emacs}" diff --git a/dev/dune_db_408 b/dev/dune_db_408 new file mode 100644 index 0000000000..3bf13da62d --- /dev/null +++ b/dev/dune_db_408 @@ -0,0 +1,25 @@ +load_printer threads.cma +load_printer str.cma +load_printer config.cma +load_printer clib.cma +load_printer dynlink.cma +load_printer lib.cma +load_printer gramlib.cma +load_printer byterun.cma +load_printer kernel.cma +load_printer library.cma +load_printer engine.cma +load_printer pretyping.cma +load_printer interp.cma +load_printer proofs.cma +load_printer parsing.cma +load_printer printing.cma +load_printer tactics.cma +load_printer vernac.cma +load_printer stm.cma +load_printer toplevel.cma + +load_printer ltac_plugin.cma +load_printer top_printers.cma + +source top_printers.dbg diff --git a/dev/dune_db_409 b/dev/dune_db_409 new file mode 100644 index 0000000000..1267fd5393 --- /dev/null +++ b/dev/dune_db_409 @@ -0,0 +1,24 @@ +load_printer threads.cma +load_printer str.cma +load_printer config.cma +load_printer clib.cma +load_printer lib.cma +load_printer gramlib.cma +load_printer byterun.cma +load_printer kernel.cma +load_printer library.cma +load_printer engine.cma +load_printer pretyping.cma +load_printer interp.cma +load_printer proofs.cma +load_printer parsing.cma +load_printer printing.cma +load_printer tactics.cma +load_printer vernac.cma +load_printer stm.cma +load_printer toplevel.cma + +load_printer ltac_plugin.cma +load_printer top_printers.cma + +source top_printers.dbg diff --git a/dev/lint-repository.sh b/dev/lint-repository.sh index 224601bbce..553696410c 100755 --- a/dev/lint-repository.sh +++ b/dev/lint-repository.sh @@ -33,6 +33,6 @@ echo Checking overlays dev/tools/check-overlays.sh || CODE=1 echo Checking ocamlformat -dune build @fmt || CODE=1 +make -f Makefile.dune fmt || CODE=1 exit $CODE diff --git a/dev/tools/pin-ci.sh b/dev/tools/pin-ci.sh new file mode 100755 index 0000000000..dbf54d7f0a --- /dev/null +++ b/dev/tools/pin-ci.sh @@ -0,0 +1,46 @@ +#!/usr/bin/env bash + +# Use this script to pin the commit used by the developments tracked by the CI + +OVERLAYS="./dev/ci/ci-basic-overlay.sh" + +process_development() { + local DEV=$1 + local REPO_VAR="${DEV}_CI_GITURL" + local REPO=${!REPO_VAR} + local BRANCH_VAR="${DEV}_CI_REF" + local BRANCH=${!BRANCH_VAR} + if [[ -z "$BRANCH" ]] + then + echo "$DEV has no branch set, skipping" + return 0 + fi + if [[ $BRANCH =~ ^[a-f0-9]{40}$ ]] + then + echo "$DEV is already set to hash $BRANCH, skipping" + return 0 + fi + echo "Resolving $DEV as $BRANCH from $REPO" + local HASH=$(git ls-remote --heads $REPO $BRANCH | cut -f 1) + if [[ -z "$HASH" ]] + then + echo "Could not resolve reference $BRANCH for $DEV (something went wrong), skipping" + return 0 + fi + read -p "Expand $DEV from $BRANCH to $HASH? [y/N] " -n 1 -r + echo + if [[ $REPLY =~ ^[Yy]$ ]]; then + # use -i.bak to be compatible with MacOS; see, e.g., https://stackoverflow.com/a/7573438/377022 + sed -i.bak -e "s/$BRANCH_VAR:=$BRANCH/$BRANCH_VAR:=$HASH/" $OVERLAYS + fi +} + +# Execute the script to set the overlay variables +. $OVERLAYS + +# Find all variables declared in the base overlay of the form *_CI_GITURL +for REPO_VAR in $(compgen -A variable | grep _CI_GITURL) +do + DEV=${REPO_VAR%_CI_GITURL} + process_development $DEV +done 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/01-kernel/11081-native-cleanup.rst b/doc/changelog/01-kernel/11081-native-cleanup.rst deleted file mode 100644 index b3e3a78b96..0000000000 --- a/doc/changelog/01-kernel/11081-native-cleanup.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Changed:** the native compilation (:tacn:`native_compute`) now - creates a directory to contain temporary files instead of putting - them in the root of the system temporary directory. (`#11081 - <https://github.com/coq/coq/pull/11081>`_, by Gaëtan Gilbert). diff --git a/doc/changelog/01-kernel/11361-fix-11360-discharge-template-param-var.rst b/doc/changelog/01-kernel/11361-fix-11360-discharge-template-param-var.rst deleted file mode 100644 index 8c84648aa7..0000000000 --- a/doc/changelog/01-kernel/11361-fix-11360-discharge-template-param-var.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Fixed:** `#11360 <https://github.com/issues/11360>`_ - Broken section closing when a template polymorphic inductive type depends on - a section variable through its parameters (`#11361 - <https://github.com/coq/coq/pull/11361>`_, by Gaëtan Gilbert). diff --git a/doc/changelog/02-specification-language/10657-minim-toset-flex.rst b/doc/changelog/02-specification-language/10657-minim-toset-flex.rst deleted file mode 100644 index 8983e162fb..0000000000 --- a/doc/changelog/02-specification-language/10657-minim-toset-flex.rst +++ /dev/null @@ -1,3 +0,0 @@ -- Changed heuristics for universe minimization to :g:`Set`: only - minimize flexible universes (`#10657 <https://github.com/coq/coq/pull/10657>`_, - by Gaëtan Gilbert with help from Maxime Dénès and Matthieu Sozeau). diff --git a/doc/changelog/02-specification-language/11233-master+fix11231-missing-variable-pattern-matching-decompilation.rst b/doc/changelog/02-specification-language/11233-master+fix11231-missing-variable-pattern-matching-decompilation.rst deleted file mode 100644 index 941469d698..0000000000 --- a/doc/changelog/02-specification-language/11233-master+fix11231-missing-variable-pattern-matching-decompilation.rst +++ /dev/null @@ -1,6 +0,0 @@ -- **Fixed:** - A dependency was missing when looking for default clauses in the - algorithm for printing pattern matching clauses (`#11233 - <https://github.com/coq/coq/pull/11233>`_, by Hugo Herbelin, fixing - `#11231 <https://github.com/coq/coq/pull/11231>`_, reported by Barry - Jay). diff --git a/doc/changelog/02-specification-language/11368-trailing_implicit_error.rst b/doc/changelog/02-specification-language/11368-trailing_implicit_error.rst new file mode 100644 index 0000000000..a7ffde31fc --- /dev/null +++ b/doc/changelog/02-specification-language/11368-trailing_implicit_error.rst @@ -0,0 +1,6 @@ +- **Changed:** + The warning raised when a trailing implicit is declared to be non maximally + inserted (with the command cmd:`Arguments <Arguments (implicits)>`) has been turned into an error. + This was deprecated since Coq 8.10. + (`#11368 <https://github.com/coq/coq/pull/11368>`_, + by SimonBoulier). diff --git a/doc/changelog/03-notations/11276-master+fix10750.rst b/doc/changelog/03-notations/11276-master+fix10750.rst deleted file mode 100644 index a1b8594f5f..0000000000 --- a/doc/changelog/03-notations/11276-master+fix10750.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Fixed:** - :cmd:`Print Visibility` was failing in the presence of only-printing notations - (`#11276 <https://github.com/coq/coq/pull/11276>`_, - by Hugo Herbelin, fixing `#10750 <https://github.com/coq/coq/pull/10750>`_). diff --git a/doc/changelog/03-notations/11311-custom-entries-recursive.rst b/doc/changelog/03-notations/11311-custom-entries-recursive.rst deleted file mode 100644 index ae9888512d..0000000000 --- a/doc/changelog/03-notations/11311-custom-entries-recursive.rst +++ /dev/null @@ -1,5 +0,0 @@ -- **Fixed:** - Recursive notations with custom entries were incorrectly parsing `constr` - instead of custom grammars (`#11311 <https://github.com/coq/coq/pull/11311>`_ - by Maxime Dénès, fixes `#9532 <https://github.com/coq/coq/pull/9532>`_, - `#9490 <https://github.com/coq/coq/pull/9490>`_). diff --git a/doc/changelog/04-tactics/10762-notypeclasses-refine.rst b/doc/changelog/04-tactics/10762-notypeclasses-refine.rst deleted file mode 100644 index 2fef75dc7f..0000000000 --- a/doc/changelog/04-tactics/10762-notypeclasses-refine.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Changed:** - The tactics :tacn:`eapply`, :tacn:`refine` and its variants no - longer allows shelved goals to be solved by typeclass resolution. - (`#10762 <https://github.com/coq/coq/pull/10762>`_, by Matthieu Sozeau). 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/11203-fix-time-printing.rst b/doc/changelog/04-tactics/11203-fix-time-printing.rst deleted file mode 100644 index cdfd2b228e..0000000000 --- a/doc/changelog/04-tactics/11203-fix-time-printing.rst +++ /dev/null @@ -1,4 +0,0 @@ -- The optional string argument to :tacn:`time` is now properly quoted - under :cmd:`Print Ltac` (`#11203 - <https://github.com/coq/coq/pull/11203>`_, fixes `#10971 - <https://github.com/coq/coq/issues/10971>`_, by Jason Gross) diff --git a/doc/changelog/04-tactics/11263-micromega-fix.rst b/doc/changelog/04-tactics/11263-micromega-fix.rst deleted file mode 100644 index ebfb6c19b1..0000000000 --- a/doc/changelog/04-tactics/11263-micromega-fix.rst +++ /dev/null @@ -1,6 +0,0 @@ -- **Fixed** - Efficiency regression introduced by PR `#9725 <https://github.com/coq/coq/pull/9725>`_. - (`#11263 <https://github.com/coq/coq/pull/11263>`_, - fixes `#11063 <https://github.com/coq/coq/issues/11063>`_, - and `#11242 <https://github.com/coq/coq/issues/11242>`_, - and `#11270 <https://github.com/coq/coq/issues/11270>`_, by Frédéric Besson). diff --git a/doc/changelog/04-tactics/11337-omega-with-depr.rst b/doc/changelog/04-tactics/11337-omega-with-depr.rst deleted file mode 100644 index 25e929e030..0000000000 --- a/doc/changelog/04-tactics/11337-omega-with-depr.rst +++ /dev/null @@ -1,6 +0,0 @@ -- **Deprecated:** - The undocumented ``omega with`` tactic variant has been deprecated, - using ``lia`` is the recommended replacement, tho the old semantics - of ``omega with *`` can be recovered with ``zify; omega`` - (`#11337 <https://github.com/coq/coq/pull/11337>`_, - by Emilio Jesus Gallego Arias). diff --git a/doc/changelog/04-tactics/11362-micromega-fix-11191.rst b/doc/changelog/04-tactics/11362-micromega-fix-11191.rst new file mode 100644 index 0000000000..5ecd46bced --- /dev/null +++ b/doc/changelog/04-tactics/11362-micromega-fix-11191.rst @@ -0,0 +1,5 @@ +- **Fixed:** + Regression of ``lia`` due to more powerful ``zify`` + (`#11362 <https://github.com/coq/coq/pull/11362>`_, + fixes `#11191 <https://github.com/coq/coq/issues/11191>`_, + by Frédéric Besson). diff --git a/doc/changelog/04-tactics/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/11241-master+bug-cofix-with-8.10.rst b/doc/changelog/05-tactic-language/11241-master+bug-cofix-with-8.10.rst deleted file mode 100644 index 462ba4a7b1..0000000000 --- a/doc/changelog/05-tactic-language/11241-master+bug-cofix-with-8.10.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Fixed:** - Syntax of tactic `cofix ... with ...` was broken from Coq 8.10. - (`#11241 <https://github.com/coq/coq/pull/11241>`_, - by Hugo Herbelin). 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/11255-master+fix11254-coqtop-version.rst b/doc/changelog/08-tools/11255-master+fix11254-coqtop-version.rst deleted file mode 100644 index ecc134748d..0000000000 --- a/doc/changelog/08-tools/11255-master+fix11254-coqtop-version.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Fixed:** - ``coqtop --version`` was broken when called in the middle of an installation process - (`#11255 <https://github.com/coq/coq/pull/11255>`_, by Hugo Herbelin, fixing - `#11254 <https://github.com/coq/coq/pull/11254>`_). diff --git a/doc/changelog/08-tools/11280-bugfix-11195-vos-vio-interaction.rst b/doc/changelog/08-tools/11280-bugfix-11195-vos-vio-interaction.rst deleted file mode 100644 index 97f456036d..0000000000 --- a/doc/changelog/08-tools/11280-bugfix-11195-vos-vio-interaction.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Deprecated:** - The ``-quick`` command is renamed to ``-vio``, for consistency with the new ``-vos`` and ``-vok`` flags. Usage of ``-quick`` is now deprecated. - (`#11280 <https://github.com/coq/coq/pull/11280>`_, - by charguer). diff --git a/doc/changelog/08-tools/11357-master.rst b/doc/changelog/08-tools/11357-master.rst deleted file mode 100644 index 599db5b1da..0000000000 --- a/doc/changelog/08-tools/11357-master.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Fixed:** - ``coq_makefile`` does not break when using the ``CAMLPKGS`` variable - together with an unpacked (``mllib``) plugin. (`#11357 - <https://github.com/coq/coq/pull/11357>`_, by Gaëtan Gilbert). diff --git a/doc/changelog/08-tools/11394-fix-coqdoc-annotations.rst b/doc/changelog/08-tools/11394-fix-coqdoc-annotations.rst deleted file mode 100644 index 10952c6b2c..0000000000 --- a/doc/changelog/08-tools/11394-fix-coqdoc-annotations.rst +++ /dev/null @@ -1,5 +0,0 @@ -- **Fixed:** - ``coqdoc`` with option ``-g`` (Gallina only) now correctly prints - commands with attributes (`#11394 <https://github.com/coq/coq/pull/11394>`_, - fixes `#11353 <https://github.com/coq/coq/issues/11353>`_, - by Karl Palmskog). diff --git a/doc/changelog/09-coqide/11400-gtk-ide-completion.rst b/doc/changelog/09-coqide/11400-gtk-ide-completion.rst deleted file mode 100644 index 2dc3992b9c..0000000000 --- a/doc/changelog/09-coqide/11400-gtk-ide-completion.rst +++ /dev/null @@ -1,5 +0,0 @@ -- **Changed:** - CoqIDE now uses the GtkSourceView native implementation of - the autocomplete mechanism. - (`#11400 <https://github.com/coq/coq/pull/11400>`_, - 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/11-infrastructure-and-dependencies/11227-date.rst b/doc/changelog/11-infrastructure-and-dependencies/11227-date.rst deleted file mode 100644 index 5c08e2b0ea..0000000000 --- a/doc/changelog/11-infrastructure-and-dependencies/11227-date.rst +++ /dev/null @@ -1,5 +0,0 @@ -- **Added:** - Build date can now be overriden by setting the `SOURCE_DATE_EPOCH` - environment variable - (`#11227 <https://github.com/coq/coq/pull/11227>`_, - by Bernhard M. Wiedemann). diff --git a/doc/sphinx/addendum/micromega.rst b/doc/sphinx/addendum/micromega.rst index cc19c8b6a9..b0197c500c 100644 --- a/doc/sphinx/addendum/micromega.rst +++ b/doc/sphinx/addendum/micromega.rst @@ -35,6 +35,12 @@ 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. +.. 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/addendum/universe-polymorphism.rst b/doc/sphinx/addendum/universe-polymorphism.rst index 7adb25cbd6..f9cc25959c 100644 --- a/doc/sphinx/addendum/universe-polymorphism.rst +++ b/doc/sphinx/addendum/universe-polymorphism.rst @@ -529,8 +529,8 @@ sections, except in the following ways: Polymorphic Universe i. Fail Constraint i = i. - This includes constraints implictly declared by commands such as - :cmd:`Variable`, which may as a such need to be used with universe + This includes constraints implicitly declared by commands such as + :cmd:`Variable`, which may need to be used with universe polymorphism activated (locally by attribute or globally by option): .. coqtop:: all diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 21000889d3..6d9979a704 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -55,23 +55,23 @@ this version of Coq, it should soon be the case and we already recommend users to switch to :tacn:`lia` in new proof scripts (see also the warning message in the :ref:`corresponding chapter <omega>`). -The ``dev/doc/critical-bugs`` file documents the known critical bugs of |Coq| -and affected releases. See the `Changes in 8.11+beta1`_ section for the -detailed list of changes, including potentially breaking changes marked with -**Changed**. +The ``dev/doc/critical-bugs`` file documents the known critical bugs +of |Coq| and affected releases. See the `Changes in 8.11+beta1`_ +section and following sections for the detailed list of changes, +including potentially breaking changes marked with **Changed**. + +Coq's documentation is available at https://coq.github.io/doc/v8.11/api (documentation of +the ML API), https://coq.github.io/doc/v8.11/refman (reference +manual), and https://coq.github.io/doc/v8.11/stdlib (documentation of +the standard library). Maxime Dénès, Emilio Jesús Gallego Arias, Gaëtan Gilbert, Michael -Soegtrop, Théo Zimmermann worked on maintaining and improving the +Soegtrop and Théo Zimmermann worked on maintaining and improving the continuous integration system and package building infrastructure. -Coq's documentation is available at https://coq.github.io/doc/V8.11+beta1/api (documentation of -the ML API), https://coq.github.io/doc/V8.11+beta1/refman (reference -manual), and https://coq.github.io/doc/V8.11+beta1/stdlib (documentation of -the standard library). - The OPAM repository for |Coq| packages has been maintained by -Karl Palmskog, Matthieu Sozeau, Enrico Tassi with contributions -from many users. A list of packages is available at +Guillaume Claret, Karl Palmskog, Matthieu Sozeau and Enrico Tassi with +contributions from many users. A list of packages is available at https://coq.inria.fr/opam/www/. The 61 contributors to this version are Michael D. Adams, Guillaume @@ -514,6 +514,133 @@ Changes in 8.11+beta1 (`#10471 <https://github.com/coq/coq/pull/10471>`_, by Emilio Jesús Gallego Arias). +Changes in 8.11.0 +~~~~~~~~~~~~~~~~~ + +**Kernel** + +- **Changed:** the native compilation (:tacn:`native_compute`) now + creates a directory to contain temporary files instead of putting + them in the root of the system temporary directory (`#11081 + <https://github.com/coq/coq/pull/11081>`_, by Gaëtan Gilbert). +- **Fixed:** `#11360 <https://github.com/issues/11360>`_. + Broken section closing when a template polymorphic inductive type depends on + a section variable through its parameters (`#11361 + <https://github.com/coq/coq/pull/11361>`_, by Gaëtan Gilbert). +- **Fixed:** The type of :g:`Set+1` would be computed to be itself, + leading to a proof of False (`#11422 + <https://github.com/coq/coq/pull/11422>`_, by Gaëtan Gilbert). + +**Specification language, type inference** + +- **Changed:** Heuristics for universe minimization to :g:`Set`: only + minimize flexible universes (`#10657 <https://github.com/coq/coq/pull/10657>`_, + by Gaëtan Gilbert with help from Maxime Dénès and Matthieu Sozeau). +- **Fixed:** + A dependency was missing when looking for default clauses in the + algorithm for printing pattern matching clauses (`#11233 + <https://github.com/coq/coq/pull/11233>`_, by Hugo Herbelin, fixing + `#11231 <https://github.com/coq/coq/pull/11231>`_, reported by Barry + Jay). + +**Notations** + +- **Fixed:** + :cmd:`Print Visibility` was failing in the presence of only-printing notations + (`#11276 <https://github.com/coq/coq/pull/11276>`_, + by Hugo Herbelin, fixing `#10750 <https://github.com/coq/coq/pull/10750>`_). +- **Fixed:** + Recursive notations with custom entries were incorrectly parsing `constr` + instead of custom grammars (`#11311 <https://github.com/coq/coq/pull/11311>`_ + by Maxime Dénès, fixes `#9532 <https://github.com/coq/coq/pull/9532>`_, + `#9490 <https://github.com/coq/coq/pull/9490>`_). + +**Tactics** + +- **Changed:** + The tactics :tacn:`eapply`, :tacn:`refine` and variants no + longer allow shelved goals to be solved by typeclass resolution + (`#10762 <https://github.com/coq/coq/pull/10762>`_, by Matthieu Sozeau). +- **Fixed:** The optional string argument to :tacn:`time` is now + properly quoted under :cmd:`Print Ltac` (`#11203 + <https://github.com/coq/coq/pull/11203>`_, fixes `#10971 + <https://github.com/coq/coq/issues/10971>`_, by Jason Gross) +- **Fixed:** + Efficiency regression of :tacn:`lia` introduced in 8.10 + by PR `#9725 <https://github.com/coq/coq/pull/9725>`_ + (`#11263 <https://github.com/coq/coq/pull/11263>`_, + fixes `#11063 <https://github.com/coq/coq/issues/11063>`_, + and `#11242 <https://github.com/coq/coq/issues/11242>`_, + and `#11270 <https://github.com/coq/coq/issues/11270>`_, by Frédéric Besson). +- **Deprecated:** + The undocumented ``omega with`` tactic variant has been deprecated. + Using :tacn:`lia` is the recommended replacement, though the old semantics + of ``omega with *`` can be recovered with ``zify; omega`` + (`#11337 <https://github.com/coq/coq/pull/11337>`_, + by Emilio Jesus Gallego Arias). +- **Fixed** + For compatibility reasons, in 8.11, :tacn:`zify` does not support :g:`Z.pow_pos` by default. + It can be enabled by explicitly loading the module :g:`ZifyPow` + (`#11430 <https://github.com/coq/coq/pull/11430>`_ by Frédéric Besson + fixes `#11191 <https://github.com/coq/coq/issues/11191>`_). + +**Tactic language** + +- **Fixed:** + Syntax of tactic `cofix ... with ...` was broken since Coq 8.10 + (`#11241 <https://github.com/coq/coq/pull/11241>`_, + by Hugo Herbelin). + +**Commands and options** + +- **Deprecated:** The `-load-ml-source` and `-load-ml-object` command + line options have been deprecated; their use was very limited, you + can achieve the same by adding object files in the linking step or + by using a plugin (`#11428 + <https://github.com/coq/coq/pull/11428>`_, by Emilio Jesus Gallego + Arias). + +**Tools** + +- **Fixed:** + ``coqtop --version`` was broken when called in the middle of an installation process + (`#11255 <https://github.com/coq/coq/pull/11255>`_, by Hugo Herbelin, fixing + `#11254 <https://github.com/coq/coq/pull/11254>`_). +- **Deprecated:** The ``-quick`` command is renamed to ``-vio``, for + consistency with the new ``-vos`` and ``-vok`` flags. Usage of + ``-quick`` is now deprecated (`#11280 + <https://github.com/coq/coq/pull/11280>`_, by Arthur Charguéraud). +- **Fixed:** + ``coq_makefile`` does not break when using the ``CAMLPKGS`` variable + together with an unpacked (``mllib``) plugin (`#11357 + <https://github.com/coq/coq/pull/11357>`_, by Gaëtan Gilbert). +- **Fixed:** + ``coqdoc`` with option ``-g`` (Gallina only) now correctly prints + commands with attributes (`#11394 <https://github.com/coq/coq/pull/11394>`_, + fixes `#11353 <https://github.com/coq/coq/issues/11353>`_, + by Karl Palmskog). + +**CoqIDE** + +- **Changed:** CoqIDE now uses the GtkSourceView native implementation + of the autocomplete mechanism (`#11400 + <https://github.com/coq/coq/pull/11400>`_, by Pierre-Marie Pédrot). + +**Standard library** + +- **Removed:** Export of module :g:`RList` in :g:`Ranalysis` and + :g:`Ranalysis_reg`. Module :g:`RList` is still there but must be + imported explicitly where required (`#11396 + <https://github.com/coq/coq/pull/11396>`_, by Michael Soegtrop). + +**Infrastructure and dependencies** + +- **Added:** + Build date can now be overridden by setting the `SOURCE_DATE_EPOCH` + environment variable + (`#11227 <https://github.com/coq/coq/pull/11227>`_, + by Bernhard M. Wiedemann). + Version 8.10 ------------ diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index bdfdffeaad..510e271951 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -1728,11 +1728,11 @@ Declaring Implicit Arguments To know which are the implicit arguments of an object, use the command :cmd:`Print Implicit` (see :ref:`displaying-implicit-args`). -.. warn:: Argument number @num is a trailing implicit so must be maximal. +.. exn:: Argument @ident is a trailing implicit, so it can't be declared non maximal. Please use %{ %} instead of [ ]. For instance in - .. coqtop:: all warn + .. coqtop:: all fail Arguments prod _ [_]. 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/dune b/doc/stdlib/dune index 7fe2493fbf..828caecabc 100644 --- a/doc/stdlib/dune +++ b/doc/stdlib/dune @@ -5,7 +5,8 @@ (deps make-library-index index-list.html.template hidden-files (source_tree %{project_root}/theories) - (source_tree %{project_root}/plugins)) + (source_tree %{project_root}/plugins) + (source_tree %{project_root}/user-contrib)) (action (chdir %{project_root} ; On windows run will fail @@ -17,6 +18,7 @@ ; This will be replaced soon by `theories/**/*.v` soon, thanks to rgrinberg (source_tree %{project_root}/theories) (source_tree %{project_root}/plugins) + (source_tree %{project_root}/user-contrib) (:header %{project_root}/doc/common/styles/html/coqremote/header.html) (:footer %{project_root}/doc/common/styles/html/coqremote/footer.html) ; For .glob files, should be gone when Coq Dune is smarter. @@ -24,7 +26,7 @@ (action (progn (run mkdir -p html) - (bash "%{bin:coqdoc} -q -d html --with-header %{header} --with-footer %{footer} --multi-index --html -g -R %{project_root}/theories Coq -R %{project_root}/plugins Coq $(find %{project_root}/theories %{project_root}/plugins -name *.v)") + (bash "%{bin:coqdoc} -q -d html --with-header %{header} --with-footer %{footer} --multi-index --html -g -R %{project_root}/theories Coq -R %{project_root}/plugins Coq -Q %{project_root}/user-contrib/Ltac2 Ltac2 $(find %{project_root}/theories %{project_root}/plugins %{project_root}/user-contrib -name *.v)") (run mv html/index.html html/genindex.html) (with-stdout-to _index.html diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index ac611926b3..5e13214a1a 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -626,6 +626,31 @@ through the <tt>Require Import</tt> command.</p> plugins/ssr/ssrfun.v </dd> + <dt> <b>Ltac2</b>: + The Ltac2 tactic programming language + </dt> + <dd> + user-contrib/Ltac2/Ltac2.v + user-contrib/Ltac2/Array.v + user-contrib/Ltac2/Bool.v + user-contrib/Ltac2/Char.v + user-contrib/Ltac2/Constr.v + user-contrib/Ltac2/Control.v + user-contrib/Ltac2/Env.v + user-contrib/Ltac2/Fresh.v + user-contrib/Ltac2/Ident.v + user-contrib/Ltac2/Init.v + user-contrib/Ltac2/Int.v + user-contrib/Ltac2/List.v + user-contrib/Ltac2/Ltac1.v + user-contrib/Ltac2/Message.v + user-contrib/Ltac2/Notations.v + user-contrib/Ltac2/Option.v + user-contrib/Ltac2/Pattern.v + user-contrib/Ltac2/Std.v + user-contrib/Ltac2/String.v + </dd> + <dt> <b>Unicode</b>: Unicode-based notations </dt> diff --git a/doc/stdlib/make-library-index b/doc/stdlib/make-library-index index bea6f24098..732f15b78a 100755 --- a/doc/stdlib/make-library-index +++ b/doc/stdlib/make-library-index @@ -1,4 +1,4 @@ -#!/bin/sh +#!/usr/bin/env bash # Instantiate links to library files in index template @@ -8,9 +8,14 @@ HIDDEN=$2 cp -f $FILE.template tmp echo -n "Building file index-list.prehtml... " -LIBDIRS=`find theories/* plugins/* -type d ! -name .coq-native` +LIBDIRS=`find theories/* plugins/* user-contrib/* -type d ! -name .coq-native` for k in $LIBDIRS; do + if [[ $k =~ "user-contrib" ]]; then + BASE_PREFIX="" + else + BASE_PREFIX="Coq." + fi d=`basename $k` ls $k | grep -q \.v'$' if [ $? = 0 ]; then @@ -26,7 +31,7 @@ for k in $LIBDIRS; do echo Error: $FILE and $HIDDEN both mention $k/$b.v; exit 1 else p=`echo $k | sed 's:^[^/]*/::' | sed 's:/:.:g'` - sed -e "s:$k/$b.v:<a href=\"Coq.$p.$b.html\">$b</a>:g" tmp > tmp2 + sed -e "s:$k/$b.v:<a href=\"$BASE_PREFIX$p.$b.html\">$b</a>:g" tmp > tmp2 mv -f tmp2 tmp fi else 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() diff --git a/engine/evd.ml b/engine/evd.ml index 8e7d942c37..70f58163fd 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) diff --git a/engine/evd.mli b/engine/evd.mli index 8843adc853..82e1003a65 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 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/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/ide/coqide.ml b/ide/coqide.ml index a519577c2c..ccf6d40b2b 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -995,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..." @@ -1361,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 3793c4be21..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'>\ diff --git a/interp/constrextern.ml b/interp/constrextern.ml index cc0c1e4602..c55e17e7a3 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -281,6 +281,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 +561,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 +580,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 +607,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 +620,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 +682,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 +916,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 +1145,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 +1211,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..f4ae5bf676 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -1643,7 +1643,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 diff --git a/interp/impargs.ml b/interp/impargs.ml index df28b32f81..e2c732809a 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -646,11 +646,9 @@ 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 -(* TODO: either turn these warnings on and document them, or handle these cases sensibly *) -let warn_set_maximal_deprecated = - CWarnings.create ~name:"set-maximal-deprecated" ~category:"deprecated" - (fun i -> strbrk ("Argument number " ^ string_of_int i ^ " is a trailing implicit so must be maximal")) +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 @@ -662,7 +660,7 @@ let compute_implicit_statuses autoimps l = | Name id :: autoimps, Implicit :: manualimps -> let imps' = aux (i+1) (autoimps, manualimps) in let max = set_maximality imps' false in - if max then warn_set_maximal_deprecated i; + if max then msg_trailing_implicit id; Some (ExplByName id, Manual, (max, true)) :: imps' | Anonymous :: _, (Implicit | MaximallyImplicit) :: _ -> user_err ~hdr:"set_implicits" diff --git a/kernel/cooking.ml b/kernel/cooking.ml index 261a3510d6..cebbfe4986 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -144,11 +144,11 @@ let abstract_context hyps = in Context.Named.fold_outside fold hyps ~init:([], []) -let abstract_constant_type t (hyps, subst) = +let abstract_as_type t (hyps, subst) = let t = Vars.subst_vars subst t in List.fold_left (fun c d -> mkProd_wo_LetIn d c) t hyps -let abstract_constant_body c (hyps, subst) = +let abstract_as_body c (hyps, subst) = let c = Vars.subst_vars subst c in it_mkLambda_or_LetIn c hyps @@ -192,8 +192,7 @@ let discharge_abstract_universe_context subst abs_ctx auctx = let auctx = Univ.subst_univs_level_abstract_universe_context substf auctx in subst, (AUContext.union abs_ctx auctx) -let lift_univs cb subst auctx0 = - match cb.const_universes with +let lift_univs subst auctx0 = function | Monomorphic ctx -> assert (AUContext.is_empty auctx0); subst, (Monomorphic ctx) @@ -219,7 +218,7 @@ let cook_constr { Opaqueproof.modlist ; abstract } (c, priv) = let expmod = expmod_constr_subst cache modlist usubst in let hyps = Context.Named.map expmod abstract in let hyps = abstract_context hyps in - let c = abstract_constant_body (expmod c) hyps in + let c = abstract_as_body (expmod c) hyps in (c, priv) let cook_constr infos c = @@ -230,11 +229,11 @@ let cook_constant { from = cb; info } = let { Opaqueproof.modlist; abstract } = info in let cache = RefTable.create 13 in let abstract, usubst, abs_ctx = abstract in - let usubst, univs = lift_univs cb usubst abs_ctx in + let usubst, univs = lift_univs usubst abs_ctx cb.const_universes in let expmod = expmod_constr_subst cache modlist usubst in let hyps0 = Context.Named.map expmod abstract in let hyps = abstract_context hyps0 in - let map c = abstract_constant_body (expmod c) hyps in + let map c = abstract_as_body (expmod c) hyps in let body = match cb.const_body with | Undef _ as x -> x | Def cs -> Def (Mod_subst.from_val (map (Mod_subst.force_constr cs))) @@ -243,7 +242,7 @@ let cook_constant { from = cb; info } = | Primitive _ -> CErrors.anomaly (Pp.str "Primitives cannot be cooked") in let const_hyps = Id.Set.diff (Context.Named.to_vars cb.const_hyps) (Context.Named.to_vars hyps0) in - let typ = abstract_constant_type (expmod cb.const_type) hyps in + let typ = abstract_as_type (expmod cb.const_type) hyps in { cook_body = body; cook_type = typ; @@ -259,104 +258,160 @@ let cook_constant { from = cb; info } = (********************************) (* Discharging mutual inductive *) -(* Replace - - Var(y1)..Var(yq):C1..Cq |- Ij:Bj - Var(y1)..Var(yq):C1..Cq; I1..Ip:B1..Bp |- ci : Ti - - by - - |- Ij: (y1..yq:C1..Cq)Bj - I1..Ip:(B1 y1..yq)..(Bp y1..yq) |- ci : (y1..yq:C1..Cq)Ti[Ij:=(Ij y1..yq)] -*) - -let it_mkNamedProd_wo_LetIn b d = - List.fold_left (fun c d -> mkNamedProd_wo_LetIn d c) b d - -let abstract_inductive decls nparamdecls inds = - let open Entries in - let ntyp = List.length inds in - let ndecls = Context.Named.length decls in - let args = Context.Named.to_instance mkVar (List.rev decls) in - let args = Array.of_list args in - let subs = List.init ntyp (fun k -> lift ndecls (mkApp(mkRel (k+1),args))) in - let inds' = - List.map - (function (tname,arity,template,cnames,lc) -> - let lc' = List.map (Vars.substl subs) lc in - let lc'' = List.map (fun b -> it_mkNamedProd_wo_LetIn b decls) lc' in - let arity' = it_mkNamedProd_wo_LetIn arity decls in - (tname,arity',template,cnames,lc'')) - inds in - let nparamdecls' = nparamdecls + Array.length args in -(* To be sure to be the same as before, should probably be moved to cook_inductive *) - let params' = let (_,arity,_,_,_) = List.hd inds' in - let (params,_) = decompose_prod_n_assum nparamdecls' arity in - params +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 = + (* Dealing with substitutions between contexts is too annoying, so + we reify [ctx] into a big [forall] term and work on that. *) + let t = it_mkProd_or_LetIn mkProp ctx in + let t = Vars.subst_vars subst t in + let t = it_mkProd_wo_LetIn t section_decls in + let ctx, t = decompose_prod_assum t in + assert (Constr.equal t mkProp); + ctx + +let abstract_lc ~ntypes expmod (newparams,subst) c = + let args = Array.rev_of_list (CList.map_filter (fun d -> + if RelDecl.is_local_def d then None + else match RelDecl.get_name d with + | Anonymous -> assert false + | Name id -> Some (mkVar id)) + newparams) in - let ind'' = - List.map - (fun (a,arity,template,c,lc) -> - let _, short_arity = decompose_prod_n_assum nparamdecls' arity in - let shortlc = - List.map (fun c -> snd (decompose_prod_n_assum nparamdecls' c)) lc in - { mind_entry_typename = a; - mind_entry_arity = short_arity; - mind_entry_template = template; - mind_entry_consnames = c; - mind_entry_lc = shortlc }) - inds' - in (params',ind'') - -let refresh_polymorphic_type_of_inductive (_,mip) = - match mip.mind_arity with - | RegularArity s -> s.mind_user_arity, false - | TemplateArity ar -> - let ctx = List.rev mip.mind_arity_ctxt in - mkArity (List.rev ctx, Sorts.sort_of_univ ar.template_level), true + let diff = List.length newparams in + let subs = List.init ntypes (fun k -> + lift diff (mkApp (mkRel (k+1), args))) + in + let c = Vars.substl subs c in + let c = Vars.subst_vars subst (expmod c) in + let c = it_mkProd_wo_LetIn c newparams in + c + +let abstract_projection ~params expmod hyps t = + let t = it_mkProd_or_LetIn t params in + let t = mkArrowR mkProp t in (* dummy type standing in for the inductive *) + let t = abstract_as_type (expmod t) hyps in + 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 + (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} -> + let sec_levels = CList.map_filter (fun d -> + if RelDecl.is_local_assum d then Some (template_level_of_var ~template_check d) + else None) + section_decls + in + let levels = List.rev_append sec_levels levels in + TemplateArity {template_param_levels=levels;template_level} + in + let mind_arity_ctxt = + let ctx = Context.Rel.map expmod mip.mind_arity_ctxt in + abstract_rel_ctx hyps ctx + in + let mind_user_lc = + Array.map (abstract_lc ~ntypes expmod hyps) + mip.mind_user_lc + in + let mind_nf_lc = Array.map (fun (ctx,t) -> + let lc = it_mkProd_or_LetIn t ctx in + let lc = abstract_lc ~ntypes expmod hyps lc in + decompose_prod_assum lc) + mip.mind_nf_lc + in + { mind_typename = mip.mind_typename; + mind_arity_ctxt; + mind_arity; + mind_consnames = mip.mind_consnames; + mind_user_lc; + mind_nrealargs = mip.mind_nrealargs; + mind_nrealdecls = mip.mind_nrealdecls; + mind_kelim = mip.mind_kelim; + mind_nf_lc; + mind_consnrealargs = mip.mind_consnrealargs; + mind_consnrealdecls = mip.mind_consnrealdecls; + mind_recargs = mip.mind_recargs; (* TODO is this correct? checker should tell us. *) + mind_relevance = mip.mind_relevance; + mind_nb_constant = mip.mind_nb_constant; + mind_nb_args = mip.mind_nb_args; + mind_reloc_tbl = mip.mind_reloc_tbl; + } let cook_inductive { Opaqueproof.modlist; abstract } mib = - let open Entries in let (section_decls, subst, abs_uctx) = abstract in - let nparamdecls = Context.Rel.length mib.mind_params_ctxt in - let subst, ind_univs = - match mib.mind_universes with - | Monomorphic ctx -> Univ.empty_level_subst, Monomorphic_entry ctx - | Polymorphic auctx -> - let subst, auctx = discharge_abstract_universe_context subst abs_uctx auctx in - let subst = Univ.make_instance_subst subst in - let nas = Univ.AUContext.names auctx in - let auctx = Univ.AUContext.repr auctx in - subst, Polymorphic_entry (nas, auctx) - in + let subst, mind_universes = lift_univs subst abs_uctx mib.mind_universes in let cache = RefTable.create 13 in - let discharge c = Vars.subst_univs_level_constr subst (expmod_constr cache modlist c) in - let inds = - Array.map_to_list - (fun mip -> - let ty, template = refresh_polymorphic_type_of_inductive (mib,mip) in - let arity = discharge ty in - let lc = Array.map discharge mip.mind_user_lc in - (mip.mind_typename, - arity, template, - Array.to_list mip.mind_consnames, - Array.to_list lc)) - mib.mind_packets in - let section_decls' = Context.Named.map discharge section_decls in - let (params',inds') = abstract_inductive section_decls' nparamdecls inds in - let record = match mib.mind_record with - | PrimRecord info -> - Some (Some (Array.map (fun (x,_,_,_) -> x) info)) - | FakeRecord -> Some None - | NotRecord -> None + let expmod = expmod_constr_subst cache modlist subst in + let section_decls = Context.Named.map expmod section_decls in + 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) + mib.mind_packets in - { mind_entry_record = record; - mind_entry_finite = mib.mind_finite; - mind_entry_params = params'; - mind_entry_inds = inds'; - mind_entry_private = mib.mind_private; - mind_entry_cumulative = Option.has_some mib.mind_variance; - mind_entry_universes = ind_univs + let mind_record = match mib.mind_record with + | NotRecord -> NotRecord + | FakeRecord -> FakeRecord + | PrimRecord data -> + let data = Array.map (fun (id,projs,relevances,tys) -> + let tys = Array.map (abstract_projection ~params:mib.mind_params_ctxt expmod hyps) tys in + (id,projs,relevances,tys)) + data + in + PrimRecord data + in + let mind_hyps = + List.filter (fun d -> not (Id.Set.mem (NamedDecl.get_id d) removed_vars)) + mib.mind_hyps + in + let mind_variance, mind_sec_variance = + match mib.mind_variance, mib.mind_sec_variance with + | None, None -> None, None + | None, Some _ | Some _, None -> assert false + | Some variance, Some sec_variance -> + let sec_variance, newvariance = + Array.chop (Array.length sec_variance - AUContext.size abs_uctx) + sec_variance + in + Some (Array.append newvariance variance), Some sec_variance + in + { + mind_packets; + mind_record; + mind_finite = mib.mind_finite; + mind_ntypes = mib.mind_ntypes; + mind_hyps; + mind_nparams = mib.mind_nparams + nnewparams; + mind_nparams_rec = mib.mind_nparams_rec + nnewparams; + mind_params_ctxt; + mind_universes; + mind_variance; + mind_sec_variance; + mind_private = mib.mind_private; + mind_typing_flags = mib.mind_typing_flags; } let expmod_constr modlist c = expmod_constr (RefTable.create 13) modlist c diff --git a/kernel/cooking.mli b/kernel/cooking.mli index 83a8b9edfc..c2d47735ec 100644 --- a/kernel/cooking.mli +++ b/kernel/cooking.mli @@ -31,7 +31,7 @@ val cook_constr : Opaqueproof.cooking_info list -> (constr * unit Opaqueproof.delayed_universes) -> (constr * unit Opaqueproof.delayed_universes) val cook_inductive : - Opaqueproof.cooking_info -> mutual_inductive_body -> Entries.mutual_inductive_entry + Opaqueproof.cooking_info -> mutual_inductive_body -> mutual_inductive_body (** {6 Utility functions used in module [Discharge]. } *) diff --git a/kernel/declarations.ml b/kernel/declarations.ml index 9fd10b32e6..0b6e59bd5e 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -223,6 +223,11 @@ type mutual_inductive_body = { mind_variance : Univ.Variance.t array option; (** Variance info, [None] when non-cumulative. *) + mind_sec_variance : Univ.Variance.t array option; + (** Variance info for section polymorphic universes. [None] + outside sections. The final variance once all sections are + discharged is [mind_sec_variance ++ mind_variance]. *) + mind_private : bool option; (** allow pattern-matching: Some true ok, Some false blocked *) mind_typing_flags : typing_flags; (** typing flags at the time of the inductive creation *) diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 35185b6a5e..27e3f84464 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -248,6 +248,7 @@ let subst_mind_body sub mib = mind_packets = Array.Smart.map (subst_mind_packet sub) mib.mind_packets ; mind_universes = mib.mind_universes; mind_variance = mib.mind_variance; + mind_sec_variance = mib.mind_sec_variance; mind_private = mib.mind_private; mind_typing_flags = mib.mind_typing_flags; } 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 b19472dc99..591cd050a5 100644 --- a/kernel/indTyping.ml +++ b/kernel/indTyping.ml @@ -276,7 +276,7 @@ let abstract_packets ~template_check univs usubst params ((arity,lc),(indices,sp let kelim = allowed_sorts univ_info in (arity,lc), (indices,splayed_lc), kelim -let typecheck_inductive env (mie:mutual_inductive_entry) = +let typecheck_inductive env ~sec_univs (mie:mutual_inductive_entry) = let () = match mie.mind_entry_inds with | [] -> CErrors.anomaly Pp.(str "empty inductive types declaration.") | _ -> () @@ -335,8 +335,19 @@ let typecheck_inductive env (mie:mutual_inductive_entry) = data, Some None in - (* TODO pass only the needed bits *) - let variance = InferCumulativity.infer_inductive env mie in + let variance = if not mie.mind_entry_cumulative then None + else match mie.mind_entry_universes with + | Monomorphic_entry _ -> + CErrors.user_err Pp.(str "Inductive cannot be both monomorphic and universe cumulative.") + | Polymorphic_entry (_,uctx) -> + let univs = Instance.to_array @@ UContext.instance uctx in + let univs = match sec_univs with + | None -> univs + | Some sec_univs -> Array.append sec_univs univs + in + let variances = InferCumulativity.infer_inductive ~env_params univs mie.mind_entry_inds in + Some variances + in (* Abstract universes *) let usubst, univs = Declareops.abstract_universes mie.mind_entry_universes in diff --git a/kernel/indTyping.mli b/kernel/indTyping.mli index 5c04e860a2..8dea8f046d 100644 --- a/kernel/indTyping.mli +++ b/kernel/indTyping.mli @@ -17,6 +17,7 @@ open Declarations - environment with inductives + parameters in rel context - abstracted universes - checked variance info + (variance for section universes is at the beginning of the array) - record entry (checked to be OK) - parameters - for each inductive, @@ -24,9 +25,11 @@ open Declarations * (indices * splayed constructor types) (both without params) * top allowed elimination *) -val typecheck_inductive : env -> mutual_inductive_entry -> - env - * universes * Univ.Variance.t array option +val typecheck_inductive : env -> sec_univs:Univ.Level.t array option + -> mutual_inductive_entry + -> env + * universes + * Univ.Variance.t array option * Names.Id.t array option option * Constr.rel_context * ((inductive_arity * Constr.types array) * diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 0d900c2ec9..3771454db5 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -466,7 +466,8 @@ let compute_projections (kn, i as ind) mib = Array.of_list (List.rev rs), Array.of_list (List.rev pbs) -let build_inductive env names prv univs variance paramsctxt kn isrecord isfinite inds nmr recargs = +let build_inductive env ~sec_univs names prv univs variance + paramsctxt kn isrecord isfinite inds nmr recargs = let ntypes = Array.length inds in (* Compute the set of used section variables *) let hyps = used_section_variables env paramsctxt inds in @@ -517,6 +518,15 @@ let build_inductive env names prv univs variance paramsctxt kn isrecord isfinite mind_reloc_tbl = rtbl; } in let packets = Array.map3 build_one_packet names inds recargs in + let variance, sec_variance = match variance with + | None -> None, None + | Some variance -> match sec_univs with + | None -> Some variance, None + | Some sec_univs -> + let nsec = Array.length sec_univs in + Some (Array.sub variance nsec (Array.length variance - nsec)), + Some (Array.sub variance 0 nsec) + in let mib = (* Build the mutual inductive *) { mind_record = NotRecord; @@ -529,6 +539,7 @@ let build_inductive env names prv univs variance paramsctxt kn isrecord isfinite mind_packets = packets; mind_universes = univs; mind_variance = variance; + mind_sec_variance = sec_variance; mind_private = prv; mind_typing_flags = Environ.typing_flags env; } @@ -549,9 +560,11 @@ let build_inductive env names prv univs variance paramsctxt kn isrecord isfinite (************************************************************************) (************************************************************************) -let check_inductive env kn mie = +let check_inductive env ~sec_univs kn mie = (* First type-check the inductive definition *) - let (env_ar_par, univs, variance, record, paramsctxt, inds) = IndTyping.typecheck_inductive env mie in + let (env_ar_par, univs, variance, record, paramsctxt, inds) = + IndTyping.typecheck_inductive env ~sec_univs mie + in (* Then check positivity conditions *) let chkpos = (Environ.typing_flags env).check_positive in let names = Array.map_of_list (fun entry -> entry.mind_entry_typename, entry.mind_entry_consnames) @@ -562,6 +575,6 @@ let check_inductive env kn mie = (Array.map (fun ((_,lc),(indices,_),_) -> Context.Rel.nhyps indices,lc) inds) in (* Build the inductive packets *) - build_inductive env names mie.mind_entry_private univs variance + build_inductive env ~sec_univs names mie.mind_entry_private univs variance paramsctxt kn record mie.mind_entry_finite inds nmr recargs diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli index 240ba4e2bb..9b54e8b878 100644 --- a/kernel/indtypes.mli +++ b/kernel/indtypes.mli @@ -14,4 +14,5 @@ open Environ open Entries (** Check an inductive. *) -val check_inductive : env -> MutInd.t -> mutual_inductive_entry -> mutual_inductive_body +val check_inductive : env -> sec_univs:Univ.Level.t array option + -> MutInd.t -> mutual_inductive_entry -> mutual_inductive_body diff --git a/kernel/inferCumulativity.ml b/kernel/inferCumulativity.ml index 77abe6b410..211c909241 100644 --- a/kernel/inferCumulativity.ml +++ b/kernel/inferCumulativity.ml @@ -188,15 +188,12 @@ let infer_arity_constructor is_arity env variances arcn = open Entries -let infer_inductive_core env params entries uctx = - let uarray = Instance.to_array @@ UContext.instance uctx in - if Array.is_empty uarray then raise TrivialVariance; - let env = Environ.push_context uctx env in +let infer_inductive_core env univs entries = + if Array.is_empty univs then raise TrivialVariance; let variances = Array.fold_left (fun variances u -> LMap.add u IrrelevantI variances) - LMap.empty uarray + LMap.empty univs in - let env, _ = Typeops.check_context env params in let variances = List.fold_left (fun variances entry -> let variances = infer_arity_constructor true env variances entry.mind_entry_arity @@ -210,17 +207,8 @@ let infer_inductive_core env params entries uctx = | exception Not_found -> Invariant | IrrelevantI -> Irrelevant | CovariantI -> Covariant) - uarray - -let infer_inductive env mie = - let open Entries in - let params = mie.mind_entry_params in - let entries = mie.mind_entry_inds in - if not mie.mind_entry_cumulative then None - else - let uctx = match mie.mind_entry_universes with - | Monomorphic_entry _ -> assert false - | Polymorphic_entry (_,uctx) -> uctx - in - try Some (infer_inductive_core env params entries uctx) - with TrivialVariance -> Some (Array.make (UContext.size uctx) Invariant) + univs + +let infer_inductive ~env_params univs entries = + try infer_inductive_core env_params univs entries + with TrivialVariance -> Array.make (Array.length univs) Invariant diff --git a/kernel/inferCumulativity.mli b/kernel/inferCumulativity.mli index 2bddfe21e2..a8f593c7f9 100644 --- a/kernel/inferCumulativity.mli +++ b/kernel/inferCumulativity.mli @@ -8,5 +8,14 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -val infer_inductive : Environ.env -> Entries.mutual_inductive_entry -> - Univ.Variance.t array option +val infer_inductive + : env_params:Environ.env + (** Environment containing the polymorphic universes and the + parameters. *) + -> Univ.Level.t array + (** Universes whose cumulativity we want to infer. *) + -> Entries.one_inductive_entry list + (** The inductive block data we want to infer cumulativity for. + NB: we ignore the template bool and the names, only the terms + are used. *) + -> Univ.Variance.t array diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index ee101400d6..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 @@ -908,14 +910,19 @@ let check_mind mie lab = (* The label and the first inductive type name should match *) assert (Id.equal (Label.to_id lab) oie.mind_entry_typename) +let add_checked_mind kn mib senv = + let mib = + match mib.mind_hyps with [] -> Declareops.hcons_mind mib | _ -> mib + in + add_field (MutInd.label kn,SFBmind mib) (I kn) senv + let add_mind l mie senv = let () = check_mind mie l in let kn = MutInd.make2 senv.modpath l in - let mib = Indtypes.check_inductive senv.env kn mie in - let mib = - match mib.mind_hyps with [] -> Declareops.hcons_mind mib | _ -> mib + let sec_univs = Option.map Section.all_poly_univs senv.sections in - kn, add_field (l,SFBmind mib) (I kn) senv + let mib = Indtypes.check_inductive senv.env ~sec_univs kn mie in + kn, add_checked_mind kn mib senv (** Insertion of module types *) @@ -1014,9 +1021,8 @@ let close_section senv = add_constant_aux senv (kn, cb) | `Inductive (ind, mib) -> let info = cooking_info (Section.segment_of_inductive env0 ind sections0) in - let mie = Cooking.cook_inductive info mib in - let _, senv = add_mind (MutInd.label ind) mie senv in - senv + let mib = Cooking.cook_inductive info mib in + add_checked_mind ind mib senv in List.fold_left fold senv redo 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/section.ml b/kernel/section.ml index 603ef5d006..6fa0543b23 100644 --- a/kernel/section.ml +++ b/kernel/section.ml @@ -28,6 +28,8 @@ type 'a t = { sec_mono_universes : ContextSet.t; sec_poly_universes : Name.t array * UContext.t; (** Universes local to the section *) + all_poly_univs : Univ.Level.t array; + (** All polymorphic universes, including from previous sections. *) has_poly_univs : bool; (** Are there polymorphic universes or constraints, including in previous sections. *) sec_entries : section_entry list; @@ -41,6 +43,8 @@ let rec depth sec = 1 + match sec.sec_prev with None -> 0 | Some prev -> depth p let has_poly_univs sec = sec.has_poly_univs +let all_poly_univs sec = sec.all_poly_univs + let find_emap e (cmap, imap) = match e with | SecDefinition con -> Cmap.find con cmap | SecInductive ind -> Mindmap.find ind imap @@ -57,7 +61,10 @@ let push_context (nas, ctx) sec = else let (snas, sctx) = sec.sec_poly_universes in let sec_poly_universes = (Array.append snas nas, UContext.union sctx ctx) in - { sec with sec_poly_universes; has_poly_univs = true } + let all_poly_univs = + Array.append sec.all_poly_univs (Instance.to_array @@ UContext.instance ctx) + in + { sec with sec_poly_universes; all_poly_univs; has_poly_univs = true } let rec is_polymorphic_univ u sec = let (_, uctx) = sec.sec_poly_universes in @@ -81,6 +88,7 @@ let open_section ~custom sec_prev = sec_context = 0; sec_mono_universes = ContextSet.empty; sec_poly_universes = ([||], UContext.empty); + all_poly_univs = Option.cata (fun sec -> sec.all_poly_univs) [| |] sec_prev; has_poly_univs = Option.cata has_poly_univs false sec_prev; sec_entries = []; sec_data = (Cmap.empty, Mindmap.empty); diff --git a/kernel/section.mli b/kernel/section.mli index fbd3d8254e..37d0dab317 100644 --- a/kernel/section.mli +++ b/kernel/section.mli @@ -57,6 +57,14 @@ val push_inductive : poly:bool -> MutInd.t -> 'a t -> 'a t (** {6 Retrieving section data} *) +val all_poly_univs : 'a t -> Univ.Level.t array +(** Returns all polymorphic universes, including those from previous + sections. Earlier sections are earlier in the array. + + NB: even if the array is empty there may be polymorphic + constraints about monomorphic universes, which prevent declaring + monomorphic globals. *) + type abstr_info = private { abstr_ctx : Constr.named_context; (** Section variables of this prefix *) 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 0029ff96d5..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) @@ -345,8 +348,8 @@ struct (Level.is_prop u && not (Level.is_sprop v)) else false - let successor (u,n) = - if Level.is_small u then type1 + let successor (u,n as e) = + if is_small e then type1 else (u, n + 1) let addn k (u,n as x) = @@ -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)) @@ -755,6 +755,10 @@ struct | Invariant, _ | _, Invariant -> Invariant | Covariant, Covariant -> Covariant + let equal a b = match a,b with + | Irrelevant, Irrelevant | Covariant, Covariant | Invariant, Invariant -> true + | (Irrelevant | Covariant | Invariant), _ -> false + let check_subtype x y = match x, y with | (Irrelevant | Covariant | Invariant), Irrelevant -> true | Irrelevant, Covariant -> false @@ -921,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' @@ -1104,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' @@ -1146,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 ccb5c80cbf..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 @@ -263,6 +266,8 @@ sig val pr : t -> Pp.t + val equal : t -> t -> bool + end (** {6 Universe instances} *) @@ -320,7 +325,7 @@ val in_punivs : 'a -> 'a puniverses val eq_puniverses : ('a -> 'a -> bool) -> 'a puniverses -> 'a puniverses -> bool (** A vector of universe levels with universe Constraint.t, - representiong local universe variables and associated Constraint.t *) + representing local universe variables and associated Constraint.t *) module UContext : sig 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.mli b/library/global.mli index a38fde41a5..b6bd69c17c 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 diff --git a/library/globnames.ml b/library/globnames.ml index acb05f9ac0..63cb2c69bd 100644 --- a/library/globnames.ml +++ b/library/globnames.ml @@ -123,7 +123,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..d61cdd2b64 100644 --- a/library/globnames.mli +++ b/library/globnames.mli @@ -59,7 +59,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/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/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/micromega/ZifyInst.v b/plugins/micromega/ZifyInst.v index 97f6fe0613..edfb5a2a94 100644 --- a/plugins/micromega/ZifyInst.v +++ b/plugins/micromega/ZifyInst.v @@ -523,3 +523,22 @@ Instance SatProdPos : Saturate Z.mul := SatOk := Z.mul_pos_pos |}. Add Saturate SatProdPos. + +Lemma pow_pos_strict : + forall a b, + 0 < a -> 0 < b -> 0 < a ^ b. +Proof. + intros. + apply Z.pow_pos_nonneg; auto. + apply Z.lt_le_incl;auto. +Qed. + + +Instance SatPowPos : Saturate Z.pow := + {| + PArg1 := fun x => 0 < x; + PArg2 := fun y => 0 < y; + PRes := fun r => 0 < r; + SatOk := pow_pos_strict + |}. +Add Saturate SatPowPos. diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index cb15274736..61234145e1 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -395,50 +395,40 @@ let saturate_by_linear_equalities sys = output_sys sys output_sys sys'; sys' -(* let saturate_linear_equality_non_linear sys0 = - let (l,_) = extract_all (is_substitution false) sys0 in - let rec elim l acc = - match l with - | [] -> acc - | (v,pc)::l' -> - let nc = saturate (non_linear_pivot sys0 pc v) (sys0@acc) in - elim l' (nc@acc) in - elim l [] - *) - -let bounded_vars (sys : WithProof.t list) = - let l = fst (extract_all (fun ((p, o), prf) -> LinPoly.is_variable p) sys) in - List.fold_left (fun acc (i, wp) -> IMap.add i wp acc) IMap.empty l - -let rec power n p = if n = 1 then p else WithProof.product p (power (n - 1) p) - -let bound_monomial mp m = - if Monomial.is_var m || Monomial.is_const m then None - else - try - Some - (Monomial.fold - (fun v i acc -> - let wp = IMap.find v mp in - WithProof.product (power i wp) acc) - m (WithProof.const (Int 1))) - with Not_found -> None - let bound_monomials (sys : WithProof.t list) = - let mp = bounded_vars sys in - let m = + let l = + extract_all + (fun ((p, o), _) -> + match LinPoly.get_bound p with + | None -> None + | Some Vect.Bound.{cst; var; coeff} -> + Some (Monomial.degree (LinPoly.MonT.retrieve var))) + sys + in + let deg = + List.fold_left (fun acc ((p, o), _) -> max acc (LinPoly.degree p)) 0 sys + in + let vars = List.fold_left - (fun acc ((p, _), _) -> - Vect.fold - (fun acc v _ -> - let m = LinPoly.MonT.retrieve v in - match bound_monomial mp m with - | None -> acc - | Some r -> IMap.add v r acc) - acc p) - IMap.empty sys + (fun acc ((p, o), _) -> ISet.union (LinPoly.monomials p) acc) + ISet.empty sys + in + let bounds = + saturate_bin + (fun (i1, w1) (i2, w2) -> + if i1 + i2 > deg then None + else + match WithProof.mul_bound w1 w2 with + | None -> None + | Some b -> Some (i1 + i2, b)) + (fst l) + in + let has_mon (_, ((p, o), _)) = + match LinPoly.get_bound p with + | None -> false + | Some Vect.Bound.{cst; var; coeff} -> ISet.mem var vars in - IMap.fold (fun _ e acc -> e :: acc) m [] + List.map snd (List.filter has_mon bounds) @ snd l let develop_constraints prfdepth n_spec sys = LinPoly.MonT.clear (); diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 92a2222cfa..cdadde8621 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -2416,6 +2416,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/mutils.ml b/plugins/micromega/mutils.ml index 03f042647c..160b492d3d 100644 --- a/plugins/micromega/mutils.ml +++ b/plugins/micromega/mutils.ml @@ -140,6 +140,25 @@ let saturate p f sys = Printexc.print_backtrace stdout; raise x +let saturate_bin (f : 'a -> 'a -> 'a option) (l : 'a list) = + let rec map_with acc e l = + match l with + | [] -> acc + | e' :: l' -> ( + match f e e' with + | None -> map_with acc e l' + | Some r -> map_with (r :: acc) e l' ) + in + let rec map2_with acc l' = + match l' with [] -> acc | e' :: l' -> map2_with (map_with acc e' l) l' + in + let rec iterate acc l' = + match map2_with [] l' with + | [] -> List.rev_append l' acc + | res -> iterate (List.rev_append l' acc) res + in + iterate [] l + open Num open Big_int diff --git a/plugins/micromega/mutils.mli b/plugins/micromega/mutils.mli index ef8d154b13..5dcaf3be44 100644 --- a/plugins/micromega/mutils.mli +++ b/plugins/micromega/mutils.mli @@ -116,6 +116,7 @@ val simplify : ('a -> 'a option) -> 'a list -> 'a list option val saturate : ('a -> 'b option) -> ('b * 'a -> 'a -> 'a option) -> 'a list -> 'a list +val saturate_bin : ('a -> 'a -> 'a option) -> 'a list -> 'a list val generate : ('a -> 'b option) -> 'a list -> 'b list val app_funs : ('a -> 'b option) list -> 'a -> 'b option val command : string -> string array -> 'a -> 'b diff --git a/plugins/micromega/polynomial.ml b/plugins/micromega/polynomial.ml index a4f9b60b14..b20213979b 100644 --- a/plugins/micromega/polynomial.ml +++ b/plugins/micromega/polynomial.ml @@ -379,6 +379,8 @@ module LinPoly = struct else acc) [] l + let get_bound p = Vect.Bound.of_vect p + let min_list (l : int list) = match l with [] -> None | e :: l -> Some (List.fold_left min e l) @@ -892,8 +894,9 @@ module WithProof = struct if Vect.is_null r && n >/ Int 0 then ((LinPoly.product p p1, o1), ProofFormat.mul_cst_proof n prf1) else ( - Printf.printf "mult_error %a [*] %a\n" LinPoly.pp p output - ((p1, o1), prf1); + if debug then + Printf.printf "mult_error %a [*] %a\n" LinPoly.pp p output + ((p1, o1), prf1); raise InvalidProof ) let cutting_plane ((p, o), prf) = @@ -1027,6 +1030,31 @@ module WithProof = struct else None in saturate select gen sys0 + + open Vect.Bound + + let mul_bound w1 w2 = + let (p1, o1), prf1 = w1 in + let (p2, o2), prf2 = w2 in + match (LinPoly.get_bound p1, LinPoly.get_bound p2) with + | None, _ | _, None -> None + | ( Some {cst = c1; var = v1; coeff = c1'} + , Some {cst = c2; var = v2; coeff = c2'} ) -> ( + let good_coeff b o = + match o with + | Eq -> Some (minus_num b) + | _ -> if b <=/ Int 0 then Some (minus_num b) else None + in + match (good_coeff c1 o2, good_coeff c2 o1) with + | None, _ | _, None -> None + | Some c1, Some c2 -> + let ext_mult c w = + if c =/ Int 0 then zero else mult (LinPoly.constant c) w + in + Some + (addition + (addition (product w1 w2) (ext_mult c1 w2)) + (ext_mult c2 w1)) ) end (* Local Variables: *) diff --git a/plugins/micromega/polynomial.mli b/plugins/micromega/polynomial.mli index 7e905ac69b..4b56b037e0 100644 --- a/plugins/micromega/polynomial.mli +++ b/plugins/micromega/polynomial.mli @@ -224,6 +224,8 @@ module LinPoly : sig p is linear in x i.e x does not occur in b and a is a constant such that [pred a] *) + val get_bound : t -> Vect.Bound.t option + val product : t -> t -> t (** [product p q] @return the product of the polynomial [p*q] *) @@ -372,4 +374,5 @@ module WithProof : sig val saturate_subst : bool -> t list -> t list val is_substitution : bool -> t -> var option + val mul_bound : t -> t -> t option 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/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/detyping.ml b/pretyping/detyping.ml index 037006bc47..b042437a22 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -696,7 +696,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/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/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/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..61e8741973 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) @@ -204,8 +204,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..4c539684e3 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -2362,7 +2362,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 () diff --git a/tactics/declare.ml b/tactics/declare.ml index da4de3df77..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,12 +363,14 @@ 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 = - (* Constr raisonne sur les noms courts *) + (* Variables are distinguished by only short names *) if Decls.variable_exists name then raise (AlreadyDeclared (None, name)); @@ -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/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/pfedit.ml b/tactics/pfedit.ml index 3c9803432a..a4a06873b8 100644 --- a/tactics/pfedit.ml +++ b/tactics/pfedit.ml @@ -27,7 +27,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/test-suite/bugs/closed/bug_11421.v b/test-suite/bugs/closed/bug_11421.v new file mode 100644 index 0000000000..8ddf05c888 --- /dev/null +++ b/test-suite/bugs/closed/bug_11421.v @@ -0,0 +1 @@ +Fail Definition plus1_plus1 : Type@{Set+1} := Type@{Set+1}. diff --git a/test-suite/bugs/closed/bug_2729.v b/test-suite/bugs/closed/bug_2729.v index ff08bdc6bb..52cc34beb3 100644 --- a/test-suite/bugs/closed/bug_2729.v +++ b/test-suite/bugs/closed/bug_2729.v @@ -82,7 +82,7 @@ Inductive SequenceBase (pu : PatchUniverse) (p : pu_type from mid) (qs : SequenceBase pu mid to), SequenceBase pu from to. -Arguments Nil [pu cxt]. +Arguments Nil {pu cxt}. Arguments Cons [pu from mid to]. Program Fixpoint insertBase {pu : PatchUniverse} 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/complexity/injection.v b/test-suite/complexity/injection.v index 298a07c1c4..7022987096 100644 --- a/test-suite/complexity/injection.v +++ b/test-suite/complexity/injection.v @@ -47,7 +47,7 @@ Parameter mkJoinmap : forall (key: Type) (t: Type) (j: joinable t), joinmap key j. Parameter ADMIT: forall p: Prop, p. -Arguments ADMIT [p]. +Arguments ADMIT {p}. Module Share. Parameter jb : joinable bool. diff --git a/test-suite/failure/Template.v b/test-suite/failure/Template.v index 75b2a56169..fbd9c8bcba 100644 --- a/test-suite/failure/Template.v +++ b/test-suite/failure/Template.v @@ -1,4 +1,4 @@ -(* + Module TestUnsetTemplateCheck. Unset Template Check. @@ -15,18 +15,14 @@ Module TestUnsetTemplateCheck. (* 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 -*) + (* test discharge puts things in the right order (by using the + checker on the result) *) + Section S. + + Variables (A:Type) (a:A). + Inductive bb (B:Type) := BB : forall a', a = a' -> B -> bb B. + End S. + End TestUnsetTemplateCheck. -*) diff --git a/test-suite/micromega/bug_11191a.v b/test-suite/micromega/bug_11191a.v new file mode 100644 index 0000000000..57c1d7d52f --- /dev/null +++ b/test-suite/micromega/bug_11191a.v @@ -0,0 +1,6 @@ +Require Import ZArith Lia. + +Goal forall p n, (0 < Z.pos (p ^ n))%Z. + intros. + lia. +Qed. diff --git a/test-suite/micromega/bug_11191b.v b/test-suite/micromega/bug_11191b.v new file mode 100644 index 0000000000..007470c5b3 --- /dev/null +++ b/test-suite/micromega/bug_11191b.v @@ -0,0 +1,6 @@ +Require Import ZArith Lia. + +Goal forall p, (0 < Z.pos (p ^ 2))%Z. + intros. + lia. +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/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/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/prerequisite/ssr_mini_mathcomp.v b/test-suite/prerequisite/ssr_mini_mathcomp.v index d293dc0533..048fb3b027 100644 --- a/test-suite/prerequisite/ssr_mini_mathcomp.v +++ b/test-suite/prerequisite/ssr_mini_mathcomp.v @@ -65,7 +65,7 @@ Proof. by []. Qed. Lemma eqP T : Equality.axiom (@eq_op T). Proof. by case: T => ? []. Qed. -Arguments eqP [T x y]. +Arguments eqP {T x y}. Delimit Scope eq_scope with EQ. Open Scope eq_scope. @@ -345,7 +345,7 @@ Proof. by []. Qed. End SubEqType. -Arguments val_eqP [T P sT x y]. +Arguments val_eqP {T P sT x y}. Prenex Implicits val_eqP. Notation "[ 'eqMixin' 'of' T 'by' <: ]" := (SubEqMixin _ : Equality.class_of T) @@ -386,7 +386,7 @@ Qed. Canonical nat_eqMixin := EqMixin eqnP. Canonical nat_eqType := Eval hnf in EqType nat nat_eqMixin. -Arguments eqnP [x y]. +Arguments eqnP {x y}. Prenex Implicits eqnP. Coercion nat_of_bool (b : bool) := if b then 1 else 0. diff --git a/test-suite/success/Inductive.v b/test-suite/success/Inductive.v index c2130995fc..4b2d4457bf 100644 --- a/test-suite/success/Inductive.v +++ b/test-suite/success/Inductive.v @@ -71,7 +71,7 @@ CoInductive LList (A : Set) : Set := | LNil : LList A | LCons : A -> LList A -> LList A. -Arguments LNil [A]. +Arguments LNil {A}. Inductive Finite (A : Set) : LList A -> Prop := | Finite_LNil : Finite LNil @@ -204,3 +204,19 @@ End NonRecLetIn. Fail Inductive foo (T : Type) : let T := Type in T := { r : forall x : T, x = x }. + +Module Discharge. + (* discharge test *) + Section S. + Let x := Prop. + Inductive foo : x := bla : foo. + End S. + Check bla:foo. + + Section S. + Variables (A:Type). + (* ensure params are scanned for needed section variables even with template arity *) + #[universes(template)] Inductive bar (d:A) := . + End S. + Check @bar nat 0. +End Discharge. diff --git a/test-suite/success/Inversion.v b/test-suite/success/Inversion.v index 1dbeaf3e1f..8297f54641 100644 --- a/test-suite/success/Inversion.v +++ b/test-suite/success/Inversion.v @@ -31,7 +31,7 @@ Inductive in_extension (I : Set) (r : rule I) : extension I -> Type := | in_first : forall e, in_extension r (add_rule r e) | in_rest : forall e r', in_extension r e -> in_extension r (add_rule r' e). -Arguments NL [I]. +Arguments NL {I}. Inductive super_extension (I : Set) (e : extension I) : extension I -> Type := 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/RecTutorial.v b/test-suite/success/RecTutorial.v index 4fac798f76..15672eab7c 100644 --- a/test-suite/success/RecTutorial.v +++ b/test-suite/success/RecTutorial.v @@ -994,7 +994,7 @@ Qed. Arguments Vector.cons [A] _ [n]. -Arguments Vector.nil [A]. +Arguments Vector.nil {A}. Arguments Vector.hd [A n]. Arguments Vector.tl [A n]. @@ -1161,7 +1161,7 @@ infiniteproof map_iterate'. Qed. -Arguments LNil [A]. +Arguments LNil {A}. Lemma Lnil_not_Lcons : forall (A:Set)(a:A)(l:LList A), LNil <> (LCons a l). 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/theories/Reals/Ranalysis.v b/theories/Reals/Ranalysis.v index 28d1c2c97f..332d3b14e4 100644 --- a/theories/Reals/Ranalysis.v +++ b/theories/Reals/Ranalysis.v @@ -24,7 +24,6 @@ Require Export Rsqrt_def. Require Export R_sqrt. Require Export Rtrigo_calc. Require Export Rgeom. -Require Export RList. Require Export Sqrt_reg. Require Export Ranalysis4. Require Export Rpower. diff --git a/theories/Reals/Ranalysis_reg.v b/theories/Reals/Ranalysis_reg.v index cb6d57be84..e6b3f2e37b 100644 --- a/theories/Reals/Ranalysis_reg.v +++ b/theories/Reals/Ranalysis_reg.v @@ -24,7 +24,6 @@ Require Export Rsqrt_def. Require Export R_sqrt. Require Export Rtrigo_calc. Require Export Rgeom. -Require Export RList. Require Export Sqrt_reg. Require Export Ranalysis4. Require Export Rpower. diff --git a/theories/Reals/RiemannInt.v b/theories/Reals/RiemannInt.v index a848a59d48..0337b12cad 100644 --- a/theories/Reals/RiemannInt.v +++ b/theories/Reals/RiemannInt.v @@ -15,6 +15,7 @@ Require Import Ranalysis_reg. Require Import Rbase. Require Import RiemannInt_SF. Require Import Max. +Require Import RList. Local Open Scope R_scope. Set Implicit Arguments. diff --git a/theories/Reals/RiemannInt_SF.v b/theories/Reals/RiemannInt_SF.v index 6da0fe3966..c8ec4782d9 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 RList. Local Open Scope R_scope. Set Implicit Arguments. 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 5326ce6114..74d9c113d6 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -395,12 +395,6 @@ let parse_args ~help ~init arglist : t * string list = |"-inputstate"|"-is" -> set_inputstate oval (next ()) - |"-load-ml-object" -> - Mltop.dir_ml_load (next ()); oval - - |"-load-ml-source" -> - Mltop.dir_ml_use (next ()); oval - |"-load-vernac-object" -> add_vo_require oval (next ()) None None @@ -503,7 +497,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 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..977cae6254 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -469,6 +469,16 @@ let rec vernac_loop ~state = (* 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 diff --git a/toplevel/usage.ml b/toplevel/usage.ml index b17ca71f4c..051638d53c 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\".)\ 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/vernac/classes.ml b/vernac/classes.ml index c9b5144299..77bc4e4f8a 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) 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/declareUniv.ml b/vernac/declareUniv.ml index 69ba9d76ec..def2fdad2a 100644 --- a/vernac/declareUniv.ml +++ b/vernac/declareUniv.ml @@ -72,7 +72,7 @@ let declare_univ_binders gr pl = CErrors.anomaly ~label:"declare_univ_binders" Pp.(str "declare_univ_binders on variable " ++ Id.print id ++ str".") | ConstructRef _ -> CErrors.anomaly ~label:"declare_univ_binders" - Pp.(str "declare_univ_binders on an constructor reference") + Pp.(str "declare_univ_binders on a constructor reference") in let univs = Id.Map.fold (fun id univ univs -> match Univ.Level.name univ with diff --git a/vernac/himsg.ml b/vernac/himsg.ml index ba7ae5069b..eb39564fed 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -1364,7 +1364,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/metasyntax.ml b/vernac/metasyntax.ml index 222e9eb825..05e23164b1 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -1346,7 +1346,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..2bac35b08f 100644 --- a/vernac/mltop.ml +++ b/vernac/mltop.ml @@ -56,7 +56,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 +93,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 +122,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 +246,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 *) 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/prettyp.ml b/vernac/prettyp.ml index b999ce9f3f..2cd1cf7c65 100644 --- a/vernac/prettyp.ml +++ b/vernac/prettyp.ml @@ -670,25 +670,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 +787,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 +821,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/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..d011fb2e77 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -1453,6 +1453,14 @@ let () = optread = Nativenorm.get_profiling_enabled; optwrite = Nativenorm.set_profiling_enabled } +let () = + declare_bool_option + { optdepr = false; + optname = "enable native compute timing"; + optkey = ["NativeCompute"; "Timing"]; + optread = Nativenorm.get_timing_enabled; + optwrite = Nativenorm.set_timing_enabled } + let _ = declare_bool_option { optdepr = false; 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 |