diff options
255 files changed, 5033 insertions, 3425 deletions
diff --git a/.circleci/config.yml b/.circleci/config.yml deleted file mode 100644 index adab42c622..0000000000 --- a/.circleci/config.yml +++ /dev/null @@ -1,202 +0,0 @@ -# This file used to contain configuration to also build documentation and CoqIDE, -# run the test-suite and the validate targets, -# including with 32-bits architecture or bleeding-edge compiler. - -defaults: - params: ¶ms - # Following parameters are used in Coq CircleCI Job (using yaml - # reference syntax) - working_directory: ~/coq - docker: - - image: $CI_REGISTRY_IMAGE:$CACHEKEY - - environment: &envvars - CACHEKEY: "bionic_coq-V2018-07-11-V2" - CI_REGISTRY_IMAGE: registry.gitlab.com/coq/coq - -version: 2 - -before_script: &before_script - name: Setup OPAM Switch - command: | - echo export TERM=xterm >> ~/.profile - source ~/.profile - echo . ~/.profile >> $BASH_ENV - printenv | sort - opam switch "$COMPILER" - opam config list - opam list - -.build-template: &build-template - <<: *params - steps: - - checkout - - run: *before_script - - run: &build-clean - name: Clean - command: | - make clean # ensure that `make clean` works on a fresh clone - - run: &build-configure - name: Configure - command: | - ./configure -local -native-compiler ${NATIVE_COMP} -coqide no - - run: &build-build - name: Build - command: | - make -j ${NJOBS} byte - make -j ${NJOBS} - make test-suite/misc/universes/all_stdlib.v - - persist_to_workspace: - root: &workspace ~/ - paths: - - coq/ - - environment: - <<: *envvars - NATIVE_COMP: "yes" - -.ci-template: &ci-template - <<: *params - steps: - - run: *before_script - - attach_workspace: &attach_workspace - at: *workspace - - - run: - name: Test - command: | - dev/ci/ci-wrapper.sh ${CIRCLE_JOB} - - persist_to_workspace: - root: *workspace - paths: - - coq/ - environment: *envvars - -# Defines individual jobs, see the workflows section below for job orchestration -jobs: - - # Build and prepare test environment - build: *build-template - - bignums: - <<: *ci-template - - color: - <<: *ci-template - - compcert: - <<: *ci-template - - coq-dpdgraph: - <<: *ci-template - - coquelicot: - <<: *ci-template - - cross-crypto: - <<: *ci-template - - elpi: - <<: *ci-template - - equations: - <<: *ci-template - - geocoq: - <<: *ci-template - - fcsl-pcm: - <<: *ci-template - - fiat-crypto: - <<: *ci-template - - fiat-parsers: - <<: *ci-template - - flocq: - <<: *ci-template - - math-classes: - <<: *ci-template - - corn: - <<: *ci-template - - formal-topology: - <<: *ci-template - - hott: - <<: *ci-template - - iris-lambda-rust: - <<: *ci-template - - ltac2: - <<: *ci-template - - math-comp: - <<: *ci-template - - mtac2: - <<: *ci-template - - pidetop: - <<: *ci-template - - sf: - <<: *ci-template - - unimath: - <<: *ci-template - - vst: - <<: *ci-template - -workflows: - version: 2 - - # Run on each push - main: - jobs: - - build - - - bignums: &req-main - requires: - - build - - color: - requires: - - build - - bignums - # - compcert: *req-main - # - coq-dpdgraph: *req-main - # - coquelicot: *req-main - # - cross-crypto: *req-main - # - elpi: *req-main - # - equations: *req-main - # - geocoq: *req-main - # - fcsl-pcm: *req-main - # - fiat-crypto: *req-main - # - fiat-parsers: *req-main - # - flocq: *req-main - - math-classes: - requires: - - build - - bignums - # - mtac2: *req-main - - corn: - requires: - - build - - math-classes - - formal-topology: - requires: - - build - - corn - # - hott: *req-main - # - iris-lambda-rust: *req-main - # - ltac2: *req-main - # - math-comp: *req-main - # - pidetop: *req-main - # - sf: *req-main - # - unimath: *req-main - # - vst: *req-main diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index bbd2d349c1..20d49e675f 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -9,7 +9,6 @@ ########## CI infrastructure ########## /dev/ci/ @coq/ci-maintainers -/.circleci/ @coq/ci-maintainers /.travis.yml @coq/ci-maintainers /.gitlab-ci.yml @coq/ci-maintainers @@ -135,9 +134,6 @@ /plugins/firstorder/ @PierreCorbineau # Secondary maintainer @herbelin -/plugins/fourier/ @herbelin -# Secondary maintainer @gares - /plugins/funind/ @forestjulien # Secondary maintainer @Matafou @@ -306,7 +302,7 @@ /configure* @ejgallego -/META.coq @ejgallego +/META.coq.in @ejgallego /dev/build/windows @MSoegtropIMC # Secondary maintainer @maximedenes diff --git a/.gitignore b/.gitignore index 14ec71b935..0e41d6a778 100644 --- a/.gitignore +++ b/.gitignore @@ -179,3 +179,7 @@ test-suite/.nra.cache plugins/ssr/ssrparser.ml plugins/ssr/ssrvernac.ml + +# ocaml dev files +.merlin +META.coq diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index be19a93a37..c2ca6ebaa4 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -200,7 +200,7 @@ build:edge+flambda: variables: OPAM_SWITCH: edge OPAM_VARIANT: "+flambda" - COQ_EXTRA_CONF: "-native-compiler no -coqide opt -flambda-opts " + COQ_EXTRA_CONF: "-native-compiler yes -coqide opt -flambda-opts " COQ_EXTRA_CONF_QUOTE: "-O3 -unbox-closures" windows64: diff --git a/.travis.yml b/.travis.yml index 53fbe5821a..f8b047ea18 100644 --- a/.travis.yml +++ b/.travis.yml @@ -65,7 +65,7 @@ matrix: - TEST_TARGET="validate" COMPILER="4.02.3+32bit" TW="travis_wait" - if: NOT (type = pull_request) env: - - TEST_TARGET="validate" COMPILER="${COMPILER_BE}+flambda" CAMLP5_VER="${CAMLP5_VER_BE}" NATIVE_COMP="no" EXTRA_CONF="-flambda-opts -O3" FINDLIB_VER="${FINDLIB_VER_BE}" + - TEST_TARGET="validate" COMPILER="${COMPILER_BE}+flambda" CAMLP5_VER="${CAMLP5_VER_BE}" EXTRA_CONF="-flambda-opts -O3" FINDLIB_VER="${FINDLIB_VER_BE}" - if: NOT (type = pull_request) env: - TEST_TARGET="ci-coq-dpdgraph" EXTRA_OPAM="ocamlgraph" @@ -154,7 +154,6 @@ matrix: - COMPILER="${COMPILER_BE}+flambda" - FINDLIB_VER="${FINDLIB_VER_BE}" - CAMLP5_VER="${CAMLP5_VER_BE}" - - NATIVE_COMP="no" - EXTRA_CONF="-coqide opt -with-doc yes -flambda-opts -O3" - EXTRA_OPAM="${LABLGTK_BE} ounit" before_install: *sphinx-install @@ -13,7 +13,7 @@ Tactics - The undocumented "nameless" forms `fix N`, `cofix` that were deprecated in 8.8 have been removed from LTAC's syntax; please use - `fix ident N/cofix ident` to explicitely name the (co)fixpoint + `fix ident N/cofix ident` to explicitly name the (co)fixpoint hypothesis to be introduced. - Introduction tactics "intro"/"intros" on a goal which is an @@ -39,6 +39,18 @@ Tactics still be used if you really want to ignore universe constraints. - Tactics and tactic notations now understand the `deprecated` attribute. +- The `fourier` tactic has been removed. Please now use `lra` instead. You + may need to add `Require Import Lra` to your developments. For compatibility, + we now define `fourier` as a deprecated alias of `lra`. + +Standard Library + +- Added `Ascii.eqb` and `String.eqb` and the `=?` notation for them, + and proved some lemmas about them. Note that this might cause + incompatibilities if you have, e.g., string_scope and Z_scope both + open with string_scope on top, and expect `=?` to refer to `Z.eqb`. + Solution: wrap `_ =? _` in `(_ =? _)%Z` (or whichever scope you + want). Tools @@ -72,6 +84,10 @@ Vernacular Commands overwritting the opacity set of the hint database. - Added generic syntax for “attributes”, as in: `#[local] Lemma foo : bar.` +- The `Set SsrHave NoTCResolution` command no longer has special global + scope. If you want the previous behavior, use `Global Set SsrHave + NoTCResolution`. +- Multiple sections with the same name are allowed. Coq binaries and process model @@ -99,12 +115,25 @@ SSReflect In particular rule 3 lets one write {x}/v even if v uses the variable x: indeed the view is executed before the renaming. -- An empty clear switch is now accepted in intro patterns before a +- An empty clear switch is now accepted in intro patterns before a view application whenever the view is a variable. One can now write {}/v to mean {v}/v. Remark that {}/x is very similar to the idiom {}e for the rewrite tactic (the equation e is used for rewriting and then discarded). +Standard Library + +- There are now conversions between [string] and [positive], [Z], + [nat], and [N] in binary, octal, and hex. + +Display diffs between proof steps + +- coqtop and coqide can now highlight the differences between proof steps + in color. This can be enabled from the command line or the + "Set Diffs on|off|removed" command. Please see the documentation for + details. Showing diffs in Proof General requires small changes to PG + (under discussion). + Changes from 8.8.0 to 8.8.1 =========================== @@ -37,8 +37,6 @@ plugins/extraction developed by Pierre Letouzey (LRI, 2000-2004, PPS, 2005-now) plugins/firstorder developed by Pierre Corbineau (LRI, 2003-2008) -plugins/fourier - developed by Loïc Pottier (INRIA-Lemme, 2001) plugins/funind developed by Pierre Courtieu (INRIA-Lemme, 2003-2004, CNAM, 2006-now), Julien Forest (INRIA-Everest, 2006, CNAM, 2007-2008, ENSIIE, 2008-now) diff --git a/META.coq b/META.coq.in index a7c8da1638..b2924e3241 100644 --- a/META.coq +++ b/META.coq.in @@ -349,18 +349,6 @@ package "plugins" ( archive(native) = "newring_plugin.cmx" ) - package "fourier" ( - - description = "Coq fourier plugin" - version = "8.9" - - requires = "coq.plugins.ltac" - directory = "fourier" - - archive(byte) = "fourier_plugin.cmo" - archive(native) = "fourier_plugin.cmx" - ) - package "extraction" ( description = "Coq extraction plugin" @@ -80,7 +80,9 @@ export MLPACKFILES := $(call find, '*.mlpack') export ML4FILES := $(call find, '*.ml4') export MLGFILES := $(call find, '*.mlg') export CFILES := $(call findindir, 'kernel/byterun', '*.c') -export MERLINFILES := $(call find, '.merlin') + +export MERLININFILES := $(call find, '.merlin.in') +export MERLINFILES := $(MERLININFILES:.in=) # NB: The lists of currently existing .ml and .mli files will change # before and after a build or a make clean. Hence we do not export @@ -175,7 +177,7 @@ Makefile $(wildcard Makefile.*) config/Makefile : ; .PHONY: clean cleankeepvo objclean cruftclean indepclean docclean archclean optclean clean-ide ml4clean depclean cleanconfig distclean voclean timingclean devdocclean alienclean -clean: objclean cruftclean depclean docclean devdocclean +clean: objclean cruftclean depclean docclean devdocclean camldevfilesclean cleankeepvo: indepclean clean-ide optclean cruftclean depclean docclean devdocclean @@ -185,6 +187,9 @@ cruftclean: ml4clean find . -name '*~' -o -name '*.annot' | xargs rm -f rm -f gmon.out core +camldevfilesclean: + rm -f $(MERLINFILES) META.coq + indepclean: rm -f $(GENFILES) rm -f $(COQTOPBYTE) $(CHICKENBYTE) $(TOPBYTE) diff --git a/Makefile.build b/Makefile.build index c100eda400..05633cecc8 100644 --- a/Makefile.build +++ b/Makefile.build @@ -64,7 +64,7 @@ AFTER ?= # build the different subsystems: -world: coq coqide documentation revision +world: camldevfiles coq coqide documentation revision coq: coqlib coqbinaries tools diff --git a/Makefile.common b/Makefile.common index 727cb1e69b..772561bd70 100644 --- a/Makefile.common +++ b/Makefile.common @@ -96,7 +96,7 @@ CORESRCDIRS:=\ PLUGINDIRS:=\ omega romega micromega quote \ - setoid_ring extraction fourier \ + setoid_ring extraction \ cc funind firstorder derive \ rtauto nsatz syntax btauto \ ssrmatching ltac ssr @@ -134,7 +134,6 @@ MICROMEGACMO:=plugins/micromega/micromega_plugin.cmo QUOTECMO:=plugins/quote/quote_plugin.cmo RINGCMO:=plugins/setoid_ring/newring_plugin.cmo NSATZCMO:=plugins/nsatz/nsatz_plugin.cmo -FOURIERCMO:=plugins/fourier/fourier_plugin.cmo EXTRACTIONCMO:=plugins/extraction/extraction_plugin.cmo FUNINDCMO:=plugins/funind/recdef_plugin.cmo FOCMO:=plugins/firstorder/ground_plugin.cmo @@ -155,7 +154,7 @@ SSRCMO:=plugins/ssr/ssreflect_plugin.cmo PLUGINSCMO:=$(LTACCMO) $(OMEGACMO) $(ROMEGACMO) $(MICROMEGACMO) \ $(QUOTECMO) $(RINGCMO) \ - $(FOURIERCMO) $(EXTRACTIONCMO) \ + $(EXTRACTIONCMO) \ $(CCCMO) $(FOCMO) $(RTAUTOCMO) $(BTAUTOCMO) \ $(FUNINDCMO) $(NSATZCMO) $(NATSYNTAXCMO) $(OTHERSYNTAXCMO) \ $(DERIVECMO) $(SSRMATCHINGCMO) $(SSRCMO) diff --git a/Makefile.dev b/Makefile.dev index 8f7d21694a..ea1a3d40a2 100644 --- a/Makefile.dev +++ b/Makefile.dev @@ -15,7 +15,7 @@ # Debug printers in dev/ ######################### -.PHONY: devel printers +.PHONY: devel printers camldevfiles DEBUGPRINTERS:=dev/top_printers.cmo dev/vm_printers.cmo dev/checker_printers.cmo @@ -85,13 +85,27 @@ endif # But these partial targets could be quite handy for quick builds # of specific components of Coq. +########################################################################### +# OCaml dev files +########################################################################### +camldevfiles: $(MERLINFILES) META.coq + +.merlin: .merlin.in + cp -a "$<" "$@" + +%/.merlin: %/.merlin.in + cp -a "$<" "$@" + +META.coq: META.coq.in + cp -a "$<" "$@" + ############################### ### 1) general-purpose targets ############################### coqlight: theories-light tools coqbinaries -states: theories/Init/Prelude.vo +states: camldevfiles theories/Init/Prelude.vo miniopt: $(COQTOPEXE) pluginsopt minibyte: $(COQTOPBYTE) pluginsbyte @@ -174,7 +188,6 @@ MICROMEGAVO:=$(filter plugins/micromega/%, $(PLUGINSVO)) QUOTEVO:=$(filter plugins/quote/%, $(PLUGINSVO)) RINGVO:=$(filter plugins/setoid_ring/%, $(PLUGINSVO)) NSATZVO:=$(filter plugins/nsatz/%, $(PLUGINSVO)) -FOURIERVO:=$(filter plugins/fourier/%, $(PLUGINSVO)) FUNINDVO:=$(filter plugins/funind/%, $(PLUGINSVO)) BTAUTOVO:=$(filter plugins/btauto/%, $(PLUGINSVO)) RTAUTOVO:=$(filter plugins/rtauto/%, $(PLUGINSVO)) @@ -188,7 +201,6 @@ micromega: $(MICROMEGAVO) $(MICROMEGACMO) $(CSDPCERT) setoid_ring: $(RINGVO) $(RINGCMO) nsatz: $(NSATZVO) $(NSATZCMO) extraction: $(EXTRACTIONCMO) $(EXTRACTIONVO) -fourier: $(FOURIERVO) $(FOURIERCMO) funind: $(FUNINDCMO) $(FUNINDVO) cc: $(CCVO) $(CCCMO) rtauto: $(RTAUTOVO) $(RTAUTOCMO) @@ -196,7 +208,7 @@ btauto: $(BTAUTOVO) $(BTAUTOCMO) ltac: $(LTACVO) $(LTACCMO) .PHONY: omega micromega setoid_ring nsatz extraction -.PHONY: fourier funind cc rtauto btauto ltac +.PHONY: funind cc rtauto btauto ltac # For emacs: # Local Variables: @@ -3,7 +3,6 @@ [](https://gitlab.com/coq/coq/commits/master) [](https://travis-ci.org/coq/coq/builds) [](https://ci.appveyor.com/project/coq/coq/branch/master) -[](https://circleci.com/gh/coq/workflows/coq/tree/master) [](https://gitter.im/coq/coq) [](https://doi.org/10.5281/zenodo.1003420) diff --git a/checker/cic.mli b/checker/cic.mli index 4846a9af8c..df747692a4 100644 --- a/checker/cic.mli +++ b/checker/cic.mli @@ -202,16 +202,6 @@ type inline = int option (** A constant can have no body (axiom/parameter), or a transparent body, or an opaque one *) -(** Projections are a particular kind of constant: - always transparent. *) - -type projection_body = { - proj_ind : inductive; - proj_npars : int; - proj_arg : int; - proj_type : constr; (* Type under params *) -} - type constant_def = | Undef of inline | Def of constr_substituted @@ -254,7 +244,7 @@ type wf_paths = recarg Rtree.t type record_info = | NotRecord | FakeRecord -| PrimRecord of (Id.t * Constant.t array * projection_body array) array +| PrimRecord of (Id.t * Label.t array * constr array) array type regular_inductive_arity = { mind_user_arity : constr; diff --git a/checker/closure.ml b/checker/closure.ml index 2dcc1a9840..5706011607 100644 --- a/checker/closure.ml +++ b/checker/closure.ml @@ -273,7 +273,7 @@ let update v1 (no,t) = type stack_member = | Zapp of fconstr array | ZcaseT of case_info * constr * constr array * fconstr subs - | Zproj of int * int * Projection.t + | Zproj of Projection.Repr.t | Zfix of fconstr * stack | Zshift of int | Zupdate of fconstr @@ -497,8 +497,8 @@ let rec zip m stk = | ZcaseT(ci,p,br,e)::s -> let t = FCaseT(ci, p, m, br, e) in zip {norm=neutr m.norm; term=t} s - | Zproj (i,j,cst) :: s -> - zip {norm=neutr m.norm; term=FProj (cst,m)} s + | Zproj p :: s -> + zip {norm=neutr m.norm; term=FProj (Projection.make p true,m)} s | Zfix(fx,par)::s -> zip fx (par @ append_stack [|m|] s) | Zshift(n)::s -> @@ -618,21 +618,25 @@ let drop_parameters depth n argstk = let eta_expand_ind_stack env ind m s (f, s') = let mib = lookup_mind (fst ind) env in - match mib.mind_record with - | PrimRecord info when mib.mind_finite <> CoFinite -> - let (_, projs, pbs) = info.(snd ind) in - (* (Construct, pars1 .. parsm :: arg1...argn :: []) ~= (f, s') -> - arg1..argn ~= (proj1 t...projn t) where t = zip (f,s') *) - let pars = mib.mind_nparams in - let right = fapp_stack (f, s') in - let (depth, args, s) = strip_update_shift_app m s in - (** Try to drop the params, might fail on partially applied constructors. *) - let argss = try_drop_parameters depth pars args in - let hstack = - Array.map (fun p -> { norm = Red; (* right can't be a constructor though *) - term = FProj (Projection.make p false, right) }) projs in - argss, [Zapp hstack] - | _ -> raise Not_found (* disallow eta-exp for non-primitive records *) + (* disallow eta-exp for non-primitive records *) + if not (mib.mind_finite == BiFinite) then raise Not_found; + match Declarations.inductive_make_projections ind mib with + | Some projs -> + (* (Construct, pars1 .. parsm :: arg1...argn :: []) ~= (f, s') -> + arg1..argn ~= (proj1 t...projn t) where t = zip (f,s') *) + let pars = mib.mind_nparams in + let right = fapp_stack (f, s') in + let (depth, args, s) = strip_update_shift_app m s in + (** Try to drop the params, might fail on partially applied constructors. *) + let argss = try_drop_parameters depth pars args in + let hstack = + Array.map (fun p -> + { norm = Red; (* right can't be a constructor though *) + term = FProj (Projection.make p false, right) }) + projs + in + argss, [Zapp hstack] + | None -> raise Not_found (* disallow eta-exp for non-primitive records *) let rec project_nth_arg n argstk = match argstk with @@ -669,8 +673,7 @@ let contract_fix_vect fix = (subs_cons(Array.init nfix make_body, env), thisbody) let unfold_projection env p = - let pb = lookup_projection p env in - Zproj (pb.proj_npars, pb.proj_arg, p) + Zproj (Projection.repr p) (*********************************************************************) (* A machine that inspects the head of a term until it finds an @@ -748,9 +751,9 @@ let rec knr info m stk = let stk' = par @ append_stack [|rarg|] s in let (fxe,fxbd) = contract_fix_vect fx.term in knit info fxe fxbd stk' - | (depth, args, Zproj (n, m, cst)::s) -> - let rargs = drop_parameters depth n args in - let rarg = project_nth_arg m rargs in + | (depth, args, Zproj p::s) -> + let rargs = drop_parameters depth (Projection.Repr.npars p) args in + let rarg = project_nth_arg (Projection.Repr.arg p) rargs in kni info rarg s | (_,args,s) -> (m,args@s)) | FCoFix _ when red_set info.i_flags fIOTA -> diff --git a/checker/closure.mli b/checker/closure.mli index 49b07f730d..cec785699d 100644 --- a/checker/closure.mli +++ b/checker/closure.mli @@ -103,7 +103,7 @@ type fterm = type stack_member = | Zapp of fconstr array | ZcaseT of case_info * constr * constr array * fconstr subs - | Zproj of int * int * Projection.t + | Zproj of Projection.Repr.t | Zfix of fconstr * stack | Zshift of int | Zupdate of fconstr diff --git a/checker/declarations.ml b/checker/declarations.ml index a744a02279..0540227ccb 100644 --- a/checker/declarations.ml +++ b/checker/declarations.ml @@ -214,11 +214,7 @@ let rec map_kn f f' c = match c with | Const (kn, u) -> (try snd (f' kn u) with No_subst -> c) | Proj (p,t) -> - let p' = - Projection.map (fun kn -> - try fst (f' kn Univ.Instance.empty) - with No_subst -> kn) p - in + let p' = Projection.map f p in let t' = func t in if p' == p && t' == t then c else Proj (p', t') @@ -495,6 +491,16 @@ let eq_recarg r1 r2 = match r1, r2 with let eq_wf_paths = Rtree.equal eq_recarg +let inductive_make_projections ind mib = + match mib.mind_record with + | NotRecord | FakeRecord -> None + | PrimRecord infos -> + let projs = Array.mapi (fun proj_arg lab -> + Names.Projection.Repr.make ind ~proj_npars:mib.mind_nparams ~proj_arg lab) + (pi2 infos.(snd ind)) + in + Some projs + (**********************************************************************) (* Representation of mutual inductive types in the kernel *) (* diff --git a/checker/declarations.mli b/checker/declarations.mli index 7458b3e0b0..ce852644ef 100644 --- a/checker/declarations.mli +++ b/checker/declarations.mli @@ -25,6 +25,9 @@ val dest_subterms : wf_paths -> wf_paths list array val eq_recarg : recarg -> recarg -> bool val eq_wf_paths : wf_paths -> wf_paths -> bool +val inductive_make_projections : Names.inductive -> mutual_inductive_body -> + Names.Projection.Repr.t array option + (* Modules *) val empty_delta_resolver : delta_resolver diff --git a/checker/environ.ml b/checker/environ.ml index ba1eb0ddb4..74cf237763 100644 --- a/checker/environ.ml +++ b/checker/environ.ml @@ -7,7 +7,6 @@ open Declarations type globals = { env_constants : constant_body Cmap_env.t; - env_projections : projection_body Cmap_env.t; env_inductives : mutual_inductive_body Mindmap_env.t; env_inductives_eq : KerName.t KNmap.t; env_modules : module_body MPmap.t; @@ -35,7 +34,6 @@ let empty_oracle = { let empty_env = { env_globals = { env_constants = Cmap_env.empty; - env_projections = Cmap_env.empty; env_inductives = Mindmap_env.empty; env_inductives_eq = KNmap.empty; env_modules = MPmap.empty; @@ -166,9 +164,6 @@ let evaluable_constant cst env = try let _ = constant_value env (cst, Univ.Instance.empty) in true with Not_found | NotEvaluableConst _ -> false -let lookup_projection p env = - Cmap_env.find (Projection.constant p) env.env_globals.env_projections - (* Mutual Inductives *) let scrape_mind env kn= try @@ -191,14 +186,6 @@ let add_mind kn mib env = Printf.ksprintf anomaly ("Inductive %s is already defined.") (MutInd.to_string kn); let new_inds = Mindmap_env.add kn mib env.env_globals.env_inductives in - let new_projections = match mib.mind_record with - | NotRecord | FakeRecord -> env.env_globals.env_projections - | PrimRecord projs -> - Array.fold_left (fun accu (id, kns, pbs) -> - Array.fold_left2 (fun accu kn pb -> - Cmap_env.add kn pb accu) accu kns pbs) - env.env_globals.env_projections projs - in let kn1,kn2 = MutInd.user kn, MutInd.canonical kn in let new_inds_eq = if KerName.equal kn1 kn2 then env.env_globals.env_inductives_eq @@ -207,10 +194,22 @@ let add_mind kn mib env = let new_globals = { env.env_globals with env_inductives = new_inds; - env_projections = new_projections; env_inductives_eq = new_inds_eq} in { env with env_globals = new_globals } +let lookup_projection p env = + let mind,i = Projection.inductive p in + let mib = lookup_mind mind env in + match mib.mind_record with + | NotRecord | FakeRecord -> CErrors.anomaly ~label:"lookup_projection" Pp.(str "not a projection") + | PrimRecord infos -> + let _,labs,typs = infos.(i) in + let parg = Projection.arg p in + if not (Label.equal labs.(parg) (Projection.label p)) + then CErrors.anomaly ~label:"lookup_projection" Pp.(str "incorrect label on projection") + else if not (Int.equal mib.mind_nparams (Projection.npars p)) + then CErrors.anomaly ~label:"lookup_projection" Pp.(str "incorrect param number on projection") + else typs.(parg) (* Modules *) diff --git a/checker/environ.mli b/checker/environ.mli index acb29d7d2d..af1b2a6228 100644 --- a/checker/environ.mli +++ b/checker/environ.mli @@ -5,7 +5,6 @@ open Cic type globals = { env_constants : constant_body Cmap_env.t; - env_projections : projection_body Cmap_env.t; env_inductives : mutual_inductive_body Mindmap_env.t; env_inductives_eq : KerName.t KNmap.t; env_modules : module_body MPmap.t; @@ -58,7 +57,8 @@ exception NotEvaluableConst of const_evaluation_result val constant_value : env -> Constant.t puniverses -> constr val evaluable_constant : Constant.t -> env -> bool -val lookup_projection : Projection.t -> env -> projection_body +(** NB: here in the checker we check the inferred info (npars, label) *) +val lookup_projection : Projection.t -> env -> constr (* Inductives *) val mind_equiv : env -> inductive -> inductive -> bool diff --git a/checker/reduction.ml b/checker/reduction.ml index 16c7012138..d36c0ef2c9 100644 --- a/checker/reduction.ml +++ b/checker/reduction.ml @@ -43,7 +43,7 @@ let compare_stack_shape stk1 stk2 = | (_, (Zupdate _|Zshift _)::s2) -> compare_rec bal stk1 s2 | (Zapp l1::s1, _) -> compare_rec (bal+Array.length l1) s1 stk2 | (_, Zapp l2::s2) -> compare_rec (bal-Array.length l2) stk1 s2 - | (Zproj (n1,m1,p1)::s1, Zproj (n2,m2,p2)::s2) -> + | (Zproj p1::s1, Zproj p2::s2) -> Int.equal bal 0 && compare_rec 0 s1 s2 | ((ZcaseT(c1,_,_,_))::s1, (ZcaseT(c2,_,_,_))::s2) -> @@ -55,7 +55,7 @@ let compare_stack_shape stk1 stk2 = type lft_constr_stack_elt = Zlapp of (lift * fconstr) array - | Zlproj of Names.Projection.t * lift + | Zlproj of Names.Projection.Repr.t * lift | Zlfix of (lift * fconstr) * lft_constr_stack | Zlcase of case_info * lift * fconstr * fconstr array and lft_constr_stack = lft_constr_stack_elt list @@ -74,8 +74,8 @@ let pure_stack lfts stk = | (Zshift n,(l,pstk)) -> (el_shft n l, pstk) | (Zapp a, (l,pstk)) -> (l,zlapp (Array.map (fun t -> (l,t)) a) pstk) - | (Zproj (n,m,c), (l,pstk)) -> - (l, Zlproj (c,l)::pstk) + | (Zproj p, (l,pstk)) -> + (l, Zlproj (p,l)::pstk) | (Zfix(fx,a),(l,pstk)) -> let (lfx,pa) = pure_rec l a in (l, Zlfix((lfx,fx),pa)::pstk) @@ -133,7 +133,7 @@ let convert_universes univ u u' = if Univ.Instance.check_eq univ u u' then () else raise NotConvertible -let compare_stacks f fmind lft1 stk1 lft2 stk2 = +let compare_stacks f fmind fproj lft1 stk1 lft2 stk2 = let rec cmp_rec pstk1 pstk2 = match (pstk1,pstk2) with | (z1::s1, z2::s2) -> @@ -143,10 +143,8 @@ let compare_stacks f fmind lft1 stk1 lft2 stk2 = | (Zlfix(fx1,a1),Zlfix(fx2,a2)) -> f fx1 fx2; cmp_rec a1 a2 | (Zlproj (c1,l1),Zlproj (c2,l2)) -> - if not (Names.Constant.UserOrd.equal - (Names.Projection.constant c1) - (Names.Projection.constant c2)) then - raise NotConvertible + if not (fproj c1 c2) then + raise NotConvertible | (Zlcase(ci1,l1,p1,br1),Zlcase(ci2,l2,p2,br2)) -> if not (fmind ci1.ci_ind ci2.ci_ind) then raise NotConvertible; @@ -257,7 +255,7 @@ let rec no_case_available = function | Zupdate _ :: stk -> no_case_available stk | Zshift _ :: stk -> no_case_available stk | Zapp _ :: stk -> no_case_available stk - | Zproj (_,_,_) :: _ -> false + | Zproj _ :: _ -> false | ZcaseT _ :: _ -> false | Zfix _ :: _ -> true @@ -300,6 +298,10 @@ let eq_table_key univ = Constant.UserOrd.equal c1 c2 && Univ.Instance.check_eq univ u1 u2) +let proj_equiv_infos infos p1 p2 = + Int.equal (Projection.Repr.arg p1) (Projection.Repr.arg p2) && + mind_equiv (infos_env infos) (Projection.Repr.inductive p1) (Projection.Repr.inductive p2) + (* Conversion between [lft1]term1 and [lft2]term2 *) let rec ccnv univ cv_pb infos lft1 lft2 term1 term2 = eqappr univ cv_pb infos (lft1, (term1,[])) (lft2, (term2,[])) @@ -523,7 +525,7 @@ and eqappr univ cv_pb infos (lft1,st1) (lft2,st2) = and convert_stacks univ infos lft1 lft2 stk1 stk2 = compare_stacks (fun (l1,t1) (l2,t2) -> ccnv univ CONV infos l1 l2 t1 t2) - (mind_equiv_infos infos) + (mind_equiv_infos infos) (proj_equiv_infos infos) lft1 stk1 lft2 stk2 and convert_vect univ infos lft1 lft2 v1 v2 = diff --git a/checker/subtyping.ml b/checker/subtyping.ml index 3f7f844704..0916d98ddf 100644 --- a/checker/subtyping.ml +++ b/checker/subtyping.ml @@ -12,7 +12,6 @@ open Util open Names open Cic -open Term open Declarations open Environ open Reduction @@ -123,14 +122,6 @@ let check_inductive env mp1 l info1 mib2 spec2 subst1 subst2= env, Univ.make_abstract_instance auctx' | _ -> error () in - let eq_projection_body p1 p2 = - let check eq f = if not (eq (f p1) (f p2)) then error () in - check eq_ind (fun x -> x.proj_ind); - check (==) (fun x -> x.proj_npars); - check (==) (fun x -> x.proj_arg); - check (eq_constr) (fun x -> x.proj_type); - true - in let check_inductive_type t1 t2 = check_conv conv_leq env t1 t2 in let check_packet p1 p2 = @@ -188,9 +179,9 @@ let check_inductive env mp1 l info1 mib2 spec2 subst1 subst2= | FakeRecord, FakeRecord -> true | PrimRecord info1, PrimRecord info2 -> let check (id1, p1, pb1) (id2, p2, pb2) = - Id.equal id1 id2 && - Array.for_all2 Constant.UserOrd.equal p1 p2 && - Array.for_all2 eq_projection_body pb1 pb2 + (* we don't care about the id, the types are inferred from the inductive + (ie checked before now) *) + Array.for_all2 Label.equal p1 p2 in Array.equal check info1 info2 | _, _ -> false diff --git a/checker/typeops.ml b/checker/typeops.ml index 19ede4b9a2..138fe8bc95 100644 --- a/checker/typeops.ml +++ b/checker/typeops.ml @@ -198,14 +198,13 @@ let judge_of_case env ci pj (c,cj) lfj = (* Projection. *) let judge_of_projection env p c ct = - let pb = lookup_projection p env in + let pty = lookup_projection p env in let (ind,u), args = try find_rectype env ct with Not_found -> error_case_not_inductive env (c, ct) in - assert(eq_ind pb.proj_ind ind); - let ty = subst_instance_constr u pb.proj_type in - substl (c :: List.rev args) ty + let ty = subst_instance_constr u pty in + substl (c :: List.rev args) ty (* Fixpoints. *) diff --git a/checker/values.ml b/checker/values.ml index 88cdb644db..e68cd18b87 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -15,7 +15,7 @@ To ensure this file is up-to-date, 'make' now compares the md5 of cic.mli with a copy we maintain here: -MD5 c395aa2dbfc18794b3b7192f3dc5b2e5 checker/cic.mli +MD5 064cd8d9651d37aebf77fb638b889cad checker/cic.mli *) @@ -135,7 +135,9 @@ let v_caseinfo = v_tuple "case_info" [|v_ind;Int;Array Int;Array Int;v_cprint|] let v_cast = v_enum "cast_kind" 4 -let v_proj = v_tuple "projection" [|v_cst; v_bool|] + +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 rec v_constr = Sum ("constr",0,[| @@ -223,10 +225,6 @@ let v_cst_def = v_sum "constant_def" 0 [|[|Opt Int|]; [|v_cstr_subst|]; [|v_lazy_constr|]|] -let v_projbody = - v_tuple "projection_body" - [|v_ind;Int;Int;v_constr|] - let v_typing_flags = v_tuple "typing_flags" [|v_bool; v_bool; v_oracle|] @@ -277,7 +275,7 @@ let v_finite = v_enum "recursivity_kind" 3 let v_record_info = v_sum "record_info" 2 - [| [| Array (v_tuple "record" [| v_id; Array v_cst; Array v_projbody |]) |] |] + [| [| Array (v_tuple "record" [| v_id; Array v_id; Array v_constr |]) |] |] let v_ind_pack_univs = v_sum "abstract_inductive_universes" 0 diff --git a/clib/cArray.ml b/clib/cArray.ml index fc87a74cf6..d509c55b9a 100644 --- a/clib/cArray.ml +++ b/clib/cArray.ml @@ -59,6 +59,7 @@ sig ('a -> 'b -> 'c -> 'd) -> 'a array -> 'b array -> 'c array -> 'd array val map_left : ('a -> 'b) -> 'a array -> 'b array val iter2 : ('a -> 'b -> unit) -> 'a array -> 'b array -> unit + val iter2_i : (int -> 'a -> 'b -> unit) -> 'a array -> 'b array -> unit val fold_left_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array val fold_right_map : ('a -> 'c -> 'b * 'c) -> 'a array -> 'c -> 'b array * 'c val fold_left2_map : ('a -> 'b -> 'c -> 'a * 'd) -> 'a -> 'b array -> 'c array -> 'a * 'd array @@ -407,6 +408,12 @@ let iter2 f v1 v2 = let () = if not (Int.equal len2 len1) then invalid_arg "Array.iter2" in for i = 0 to len1 - 1 do f (uget v1 i) (uget v2 i) done +let iter2_i f v1 v2 = + let len1 = Array.length v1 in + let len2 = Array.length v2 in + 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 fold_right_map f v e = diff --git a/clib/cArray.mli b/clib/cArray.mli index 8bf33f82f9..5c7e09eeac 100644 --- a/clib/cArray.mli +++ b/clib/cArray.mli @@ -101,6 +101,9 @@ sig val iter2 : ('a -> 'b -> unit) -> 'a array -> 'b array -> unit (** Iter on two arrays. Raise [Invalid_argument "Array.iter2"] if sizes differ. *) + val iter2_i : (int -> 'a -> 'b -> unit) -> 'a array -> 'b array -> unit + (** Iter on two arrays. Raise [Invalid_argument "Array.iter2_i"] if sizes differ. *) + val fold_left_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array (** [fold_left_map f e_0 [|l_1...l_n|] = e_n,[|k_1...k_n|]] where [(e_i,k_i)=f e_{i-1} l_i]; see also [Smart.fold_left_map] *) diff --git a/clib/clib.mllib b/clib/clib.mllib index afece4074c..5a2c9a9ce9 100644 --- a/clib/clib.mllib +++ b/clib/clib.mllib @@ -37,3 +37,5 @@ Backtrace IStream Terminal Monad + +Diff2 diff --git a/clib/diff2.ml b/clib/diff2.ml new file mode 100644 index 0000000000..42c4733fed --- /dev/null +++ b/clib/diff2.ml @@ -0,0 +1,158 @@ +(* copied from https://github.com/leque/ocaml-diff.git and renamed from "diff.ml" *) + +(* + * Copyright (C) 2016 OOHASHI Daichi + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN + * THE SOFTWARE. + *) + +type 'a common = + [ `Common of int * int * 'a ] + +type 'a edit = + [ `Added of int * 'a + | `Removed of int * 'a + | 'a common + ] + +module type SeqType = sig + type t + type elem + val get : t -> int -> elem + val length : t -> int +end + +module type S = sig + type t + type elem + + val lcs : + ?equal:(elem -> elem -> bool) -> + t -> t -> elem common list + + val diff : + ?equal:(elem -> elem -> bool) -> + t -> t -> elem edit list + + val fold_left : + ?equal:(elem -> elem -> bool) -> + f:('a -> elem edit -> 'a) -> + init:'a -> + t -> t -> 'a + + val iter : + ?equal:(elem -> elem -> bool) -> + f:(elem edit -> unit) -> + t -> t -> unit +end + +module Make(M : SeqType) : (S with type t = M.t and type elem = M.elem) = struct + type t = M.t + type elem = M.elem + + let lcs ?(equal = (=)) a b = + let n = M.length a in + let m = M.length b in + let mn = m + n in + let sz = 2 * mn + 1 in + let vd = Array.make sz 0 in + let vl = Array.make sz 0 in + let vr = Array.make sz [] in + let get v i = Array.get v (i + mn) in + let set v i x = Array.set v (i + mn) x in + let finish () = + let rec loop i maxl r = + if i > mn then + List.rev r + else if get vl i > maxl then + loop (i + 1) (get vl i) (get vr i) + else + loop (i + 1) maxl r + in loop (- mn) 0 [] + in + if mn = 0 then + [] + else + (* For d <- 0 to mn Do *) + let rec dloop d = + assert (d <= mn); + (* For k <- -d to d in steps of 2 Do *) + let rec kloop k = + if k > d then + dloop @@ d + 1 + else + let x, l, r = + if k = -d || (k <> d && get vd (k - 1) < get vd (k + 1)) then + get vd (k + 1), get vl (k + 1), get vr (k + 1) + else + get vd (k - 1) + 1, get vl (k - 1), get vr (k - 1) + in + let x, y, l, r = + let rec xyloop x y l r = + if x < n && y < m && equal (M.get a x) (M.get b y) then + xyloop (x + 1) (y + 1) (l + 1) (`Common(x, y, M.get a x) :: r) + else + x, y, l, r + in xyloop x (x - k) l r + in + set vd k x; + set vl k l; + set vr k r; + if x >= n && y >= m then + (* Stop *) + finish () + else + kloop @@ k + 2 + in kloop @@ -d + in dloop 0 + + let fold_left ?(equal = (=)) ~f ~init a b = + let ff x y = f y x in + let fold_map f g x from to_ init = + let rec loop i init = + if i >= to_ then + init + else + loop (i + 1) (f (g i @@ M.get x i) init) + in loop from init + in + let added i x = `Added (i, x) in + let removed i x = `Removed (i, x) in + let rec loop cs apos bpos init = + match cs with + | [] -> + init + |> fold_map ff removed a apos (M.length a) + |> fold_map ff added b bpos (M.length b) + | `Common (aoff, boff, _) as e :: rest -> + init + |> fold_map ff removed a apos aoff + |> fold_map ff added b bpos boff + |> ff e + |> loop rest (aoff + 1) (boff + 1) + in loop (lcs ~equal a b) 0 0 init + + let diff ?(equal = (=)) a b = + fold_left ~equal ~f:(fun xs x -> x::xs) ~init:[] a b + + let iter ?(equal = (=)) ~f a b = + fold_left a b + ~equal + ~f:(fun () x -> f x) + ~init:() +end diff --git a/clib/diff2.mli b/clib/diff2.mli new file mode 100644 index 0000000000..a085f4ffe8 --- /dev/null +++ b/clib/diff2.mli @@ -0,0 +1,101 @@ +(* copied from https://github.com/leque/ocaml-diff.git and renamed from "diff.mli" *) +(** + An implementation of Eugene Myers' O(ND) Difference Algorithm\[1\]. + This implementation is a port of util.lcs module of + {{:http://practical-scheme.net/gauche} Gauche Scheme interpreter}. + + - \[1\] Eugene Myers, An O(ND) Difference Algorithm and Its Variations, Algorithmica Vol. 1 No. 2, pp. 251-266, 1986. + *) + +type 'a common = [ + `Common of int * int * 'a + ] +(** an element of lcs of seq1 and seq2 *) + +type 'a edit = + [ `Removed of int * 'a + | `Added of int * 'a + | 'a common + ] +(** an element of diff of seq1 and seq2. *) + +module type SeqType = sig + type t + (** The type of the sequence. *) + + type elem + (** The type of the elements of the sequence. *) + + val get : t -> int -> elem + (** [get t n] returns [n]-th element of the sequence [t]. *) + + val length : t -> int + (** [length t] returns the length of the sequence [t]. *) +end +(** Input signature of {!Diff.Make}. *) + +module type S = sig + type t + (** The type of input sequence. *) + + type elem + (** The type of the elements of result / input sequence. *) + + val lcs : + ?equal:(elem -> elem -> bool) -> + t -> t -> elem common list + (** + [lcs ~equal seq1 seq2] computes the LCS (longest common sequence) of + [seq1] and [seq2]. + Elements of [seq1] and [seq2] are compared with [equal]. + [equal] defaults to [Pervasives.(=)]. + + Elements of lcs are [`Common (pos1, pos2, e)] + where [e] is an element, [pos1] is a position in [seq1], + and [pos2] is a position in [seq2]. + *) + + val diff : + ?equal:(elem -> elem -> bool) -> + t -> t -> elem edit list + (** + [diff ~equal seq1 seq2] computes the diff of [seq1] and [seq2]. + Elements of [seq1] and [seq2] are compared with [equal]. + + Elements only in [seq1] are represented as [`Removed (pos, e)] + where [e] is an element, and [pos] is a position in [seq1]; + those only in [seq2] are represented as [`Added (pos, e)] + where [e] is an element, and [pos] is a position in [seq2]; + those common in [seq1] and [seq2] are represented as + [`Common (pos1, pos2, e)] + where [e] is an element, [pos1] is a position in [seq1], + and [pos2] is a position in [seq2]. + *) + + val fold_left : + ?equal:(elem -> elem -> bool) -> + f:('a -> elem edit -> 'a) -> + init:'a -> + t -> t -> 'a + (** + [fold_left ~equal ~f ~init seq1 seq2] is same as + [diff ~equal seq1 seq2 |> ListLabels.fold_left ~f ~init], + but does not create an intermediate list. + *) + + val iter : + ?equal:(elem -> elem -> bool) -> + f:(elem edit -> unit) -> + t -> t -> unit + (** + [iter ~equal ~f seq1 seq2] is same as + [diff ~equal seq1 seq2 |> ListLabels.iter ~f], + but does not create an intermediate list. + *) +end +(** Output signature of {!Diff.Make}. *) + +module Make : + functor (M : SeqType) -> (S with type t = M.t and type elem = M.elem) +(** Functor building an implementation of the diff structure + given a sequence type. *) diff --git a/clib/terminal.ml b/clib/terminal.ml index 1d9468137b..d243d6599e 100644 --- a/clib/terminal.ml +++ b/clib/terminal.ml @@ -59,6 +59,19 @@ let default = { suffix = None; } +let reset = "\027[0m" + +let reset_style = { + fg_color = Some `DEFAULT; + bg_color = Some `DEFAULT; + bold = Some false; + italic = Some false; + underline = Some false; + negative = Some false; + prefix = None; + suffix = None; +} + let make ?fg_color ?bg_color ?bold ?italic ?underline ?negative ?style ?prefix ?suffix () = let st = match style with | None -> default @@ -87,6 +100,25 @@ let merge s1 s2 = suffix = set s1.suffix s2.suffix; } +let diff s1 s2 = + let diff_op o1 o2 reset_val = match o1 with + | None -> o2 + | Some _ -> + match o2 with + | None -> reset_val + | Some _ -> if o1 = o2 then None else o2 in + + { + fg_color = diff_op s1.fg_color s2.fg_color reset_style.fg_color; + bg_color = diff_op s1.bg_color s2.bg_color reset_style.bg_color; + bold = diff_op s1.bold s2.bold reset_style.bold; + italic = diff_op s1.italic s2.italic reset_style.italic; + underline = diff_op s1.underline s2.underline reset_style.underline; + negative = diff_op s1.negative s2.negative reset_style.negative; + prefix = diff_op s1.prefix s2.prefix reset_style.prefix; + suffix = diff_op s1.suffix s2.suffix reset_style.suffix; + } + let base_color = function | `DEFAULT -> 9 | `BLACK -> 0 @@ -167,20 +199,8 @@ let repr st = let eval st = let tags = repr st in let tags = List.map string_of_int tags in - Printf.sprintf "\027[%sm" (String.concat ";" tags) - -let reset = "\027[0m" - -let reset_style = { - fg_color = Some `DEFAULT; - bg_color = Some `DEFAULT; - bold = Some false; - italic = Some false; - underline = Some false; - negative = Some false; - prefix = None; - suffix = None; -} + if List.length tags = 0 then "" else + Printf.sprintf "\027[%sm" (String.concat ";" tags) let has_style t = Unix.isatty t && Sys.os_type = "Unix" diff --git a/clib/terminal.mli b/clib/terminal.mli index dbf8d4640c..bc30b0016f 100644 --- a/clib/terminal.mli +++ b/clib/terminal.mli @@ -51,6 +51,9 @@ val make : ?fg_color:color -> ?bg_color:color -> val merge : style -> style -> style (** [merge s1 s2] returns [s1] with all defined values of [s2] overwritten. *) +val diff : style -> style -> style +(** [diff s1 s2] returns the differences between [s1] and [s2]. *) + val repr : style -> int list (** Generate the ANSI code representing the given style. *) @@ -60,6 +63,9 @@ val eval : style -> string val reset : string (** This escape sequence resets all attributes. *) +val reset_style : style +(** The default style *) + val has_style : Unix.file_descr -> bool (** Whether an output file descriptor handles styles. Very heuristic, only checks it is a terminal. *) diff --git a/configure.ml b/configure.ml index c08e8dfcc2..7fd900d995 100644 --- a/configure.ml +++ b/configure.ml @@ -475,6 +475,7 @@ let coq_bin_annot_flag = if !prefs.bin_annot then "-bin-annot" else "" (* This variable can be overriden only for debug purposes, use with care. *) let coq_safe_string = "-safe-string" +let coq_strict_sequence = "-strict-sequence" let cflags = "-Wall -Wno-unused -g -O2" @@ -661,7 +662,7 @@ let coq_warn_error = (* Flags used to compile Coq and plugins (via coq_makefile) *) let caml_flags = - Printf.sprintf "-thread -rectypes %s %s %s %s" coq_warnings coq_annot_flag coq_bin_annot_flag coq_safe_string + Printf.sprintf "-thread -rectypes %s %s %s %s %s" coq_warnings coq_annot_flag coq_bin_annot_flag coq_safe_string coq_strict_sequence (* Flags used to compile Coq but _not_ plugins (via coq_makefile) *) let coq_caml_flags = diff --git a/coqpp/coqpp_main.ml b/coqpp/coqpp_main.ml index e76a1e9ed8..fd425ef4ff 100644 --- a/coqpp/coqpp_main.ml +++ b/coqpp/coqpp_main.ml @@ -326,10 +326,14 @@ let print_ast fmt ext = end +let declare_plugin fmt name = + fprintf fmt "let %s = \"%s\"@\n" plugin_name name; + fprintf fmt "let _ = Mltop.add_known_module %s@\n" plugin_name + let pr_ast fmt = function | Code s -> fprintf fmt "%s@\n" s.code | Comment s -> fprintf fmt "%s@\n" s -| DeclarePlugin name -> fprintf fmt "let %s = \"%s\"@\n" plugin_name name +| DeclarePlugin name -> declare_plugin fmt name | GramExt gram -> fprintf fmt "%a@\n" GramExt.print_ast gram | VernacExt -> fprintf fmt "VERNACEXT@\n" | TacticExt tac -> fprintf fmt "%a@\n" TacticExt.print_ast tac diff --git a/dev/ci/README.md b/dev/ci/README.md index 45176581cd..43d680af61 100644 --- a/dev/ci/README.md +++ b/dev/ci/README.md @@ -75,9 +75,6 @@ We are currently running tests on the following platforms: camlp5, and with warnings as errors; it runs the test-suite and tests the compilation of several external developments. -- Circle CI runs tests that are redundant with GitLab CI and may be removed - eventually. - - Travis CI is used to test the compilation of Coq and run the test-suite on macOS. It also runs a linter that checks whitespace discipline. A [pre-commit hook](../tools/pre-commit) is automatically installed by @@ -165,8 +162,7 @@ automatically built and uploaded to your GitLab registry, and is loaded by subsequent jobs. **IMPORTANT**: When updating Coq's CI docker image, you must modify -the `CACHEKEY` variable in [`.gitlab-ci.yml`](../../.gitlab-ci.yml), -[`.circleci/config.yml`](../../.circleci/config.yml), +the `CACHEKEY` variable in [`.gitlab-ci.yml`](../../.gitlab-ci.yml) and [`Dockerfile`](docker/bionic_coq/Dockerfile) The Docker building job reuses the uploaded image if it is available, diff --git a/dev/ci/ci-common.sh b/dev/ci/ci-common.sh index a68cd0933e..9259a6e0c8 100644 --- a/dev/ci/ci-common.sh +++ b/dev/ci/ci-common.sh @@ -20,10 +20,6 @@ else then export CI_PULL_REQUEST="$TRAVIS_PULL_REQUEST" export CI_BRANCH="$TRAVIS_BRANCH" - elif [ -n "${CIRCLECI}" ]; - then - export CI_PULL_REQUEST="$CIRCLE_PR_NUMBER" - export CI_BRANCH="$CIRCLE_BRANCH" else # assume local CI_BRANCH="$(git rev-parse --abbrev-ref HEAD)" export CI_BRANCH diff --git a/dev/ci/ci-hott.sh b/dev/ci/ci-hott.sh index 6ded97984e..184b90a50b 100755 --- a/dev/ci/ci-hott.sh +++ b/dev/ci/ci-hott.sh @@ -7,4 +7,4 @@ HoTT_CI_DIR="${CI_BUILD_DIR}"/HoTT git_checkout "${HoTT_CI_BRANCH}" "${HoTT_CI_GITURL}" "${HoTT_CI_DIR}" -( cd "${HoTT_CI_DIR}" && ./autogen.sh && ./configure && make ) +( cd "${HoTT_CI_DIR}" && ./autogen.sh && ./configure && make && make validate ) diff --git a/dev/ci/user-overlays/07859-printers.sh b/dev/ci/user-overlays/07859-printers.sh new file mode 100644 index 0000000000..27f588e214 --- /dev/null +++ b/dev/ci/user-overlays/07859-printers.sh @@ -0,0 +1,6 @@ +#!/bin/sh + +if [ "$CI_PULL_REQUEST" = "7859" ] || [ "$CI_BRANCH" = "rm-univ-broken-printing" ]; then + Equations_CI_BRANCH=fix-printers + Equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations +fi diff --git a/dev/ci/user-overlays/07908-proj-mind.sh b/dev/ci/user-overlays/07908-proj-mind.sh new file mode 100644 index 0000000000..293eeb5a5a --- /dev/null +++ b/dev/ci/user-overlays/07908-proj-mind.sh @@ -0,0 +1,6 @@ +#!/bin/sh + +if [ "$CI_PULL_REQUEST" = "7908" ] || [ "$CI_BRANCH" = "proj-mind" ]; then + Equations_CI_BRANCH=fix-proj-mind + Equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations +fi diff --git a/dev/ci/user-overlays/07941-bollu-questionmark-into-record-for-missing-record-field-error.sh b/dev/ci/user-overlays/07941-bollu-questionmark-into-record-for-missing-record-field-error.sh new file mode 100644 index 0000000000..56c0dc3433 --- /dev/null +++ b/dev/ci/user-overlays/07941-bollu-questionmark-into-record-for-missing-record-field-error.sh @@ -0,0 +1,6 @@ +#!/bin/sh + +if [ "$CI_PULL_REQUEST" = "7941" ] || [ "$CI_BRANCH" = "jun-27-missing-record-field-error-message-quickfix" ]; then + Equations_CI_BRANCH=overlay-question-mark-extended-for-missing-record-field + Equations_CI_GITURL=https://github.com/bollu/Coq-Equations +fi diff --git a/dev/ci/user-overlays/08063-jasongross-string-eqb.sh b/dev/ci/user-overlays/08063-jasongross-string-eqb.sh new file mode 100644 index 0000000000..99a11b9fbf --- /dev/null +++ b/dev/ci/user-overlays/08063-jasongross-string-eqb.sh @@ -0,0 +1,6 @@ +#!/bin/sh + +if [ "$CI_PULL_REQUEST" = "8063" ] || [ "$CI_BRANCH" = "string-eqb" ]; then + quickchick_CI_BRANCH=fix-for-pr-8063 + quickchick_CI_GITURL=https://github.com/JasonGross/QuickChick +fi diff --git a/dev/ocamldebug-coq.run b/dev/ocamldebug-coq.run index 2bec09de2b..bccd3fefb4 100644 --- a/dev/ocamldebug-coq.run +++ b/dev/ocamldebug-coq.run @@ -33,7 +33,7 @@ if [ -z "$GUESS_CHECKER" ]; then -I $COQTOP/toplevel -I $COQTOP/dev -I $COQTOP/config -I $COQTOP/ltac \ -I $COQTOP/plugins/cc -I $COQTOP/plugins/dp \ -I $COQTOP/plugins/extraction -I $COQTOP/plugins/field \ - -I $COQTOP/plugins/firstorder -I $COQTOP/plugins/fourier \ + -I $COQTOP/plugins/firstorder \ -I $COQTOP/plugins/funind -I $COQTOP/plugins/groebner \ -I $COQTOP/plugins/interface -I $COQTOP/plugins/micromega \ -I $COQTOP/plugins/omega -I $COQTOP/plugins/quote \ diff --git a/dev/tools/check-overlays.sh b/dev/tools/check-overlays.sh index f7e05b51cd..33a9ff058e 100755 --- a/dev/tools/check-overlays.sh +++ b/dev/tools/check-overlays.sh @@ -1,8 +1,8 @@ #!/usr/bin/env bash -for f in dev/ci/user-overlays/* +for f in $(git ls-files "dev/ci/user-overlays/") do - if ! ([[ $f = dev/ci/user-overlays/README.md ]] || [[ $f == *.sh ]]) + if ! ([[ "$f" = dev/ci/user-overlays/README.md ]] || [[ "$f" == *.sh ]]) then >&2 echo "Bad overlay '$f'." >&2 echo "User overlays need to have extension .sh to be picked up!" diff --git a/dev/tools/coqdev.el b/dev/tools/coqdev.el index 70a9756e51..ec72f96509 100644 --- a/dev/tools/coqdev.el +++ b/dev/tools/coqdev.el @@ -33,7 +33,7 @@ (defun coqdev-default-directory () "Return the Coq repository containing `default-directory'." - (let ((dir (locate-dominating-file default-directory "META.coq"))) + (let ((dir (locate-dominating-file default-directory "META.coq.in"))) (when dir (expand-file-name dir)))) (defun coqdev-setup-compile-command () diff --git a/dev/vm_printers.ml b/dev/vm_printers.ml index c8385da618..98190b05b5 100644 --- a/dev/vm_printers.ml +++ b/dev/vm_printers.ml @@ -17,7 +17,7 @@ let ppripos (ri,pos) = | Reloc_getglobal kn -> print_string ("getglob "^(Constant.to_string kn)^"\n") | Reloc_proj_name p -> - print_string ("proj "^(Constant.to_string p)^"\n") + print_string ("proj "^(Projection.Repr.to_string p)^"\n") ); print_flush () diff --git a/doc/sphinx/addendum/canonical-structures.rst b/doc/sphinx/addendum/canonical-structures.rst index 6843e9eaa1..3af3115a59 100644 --- a/doc/sphinx/addendum/canonical-structures.rst +++ b/doc/sphinx/addendum/canonical-structures.rst @@ -6,14 +6,14 @@ Canonical Structures :Authors: Assia Mahboubi and Enrico Tassi -This chapter explains the basics of Canonical Structure and how they can be used +This chapter explains the basics of canonical structures and how they can be used to overload notations and build a hierarchy of algebraic structures. The examples are taken from :cite:`CSwcu`. We invite the interested reader to refer to this paper for all the details that are omitted here for brevity. The interested reader shall also find in :cite:`CSlessadhoc` a detailed description -of another, complementary, use of Canonical Structures: advanced proof search. +of another, complementary, use of canonical structures: advanced proof search. This latter papers also presents many techniques one can employ to tune the -inference of Canonical Structures. +inference of canonical structures. Notation overloading @@ -38,21 +38,21 @@ of the terms that are compared. End theory. End EQ. -We use Coq modules as name spaces. This allows us to follow the same +We use Coq modules as namespaces. This allows us to follow the same pattern and naming convention for the rest of the chapter. The base -name space contains the definitions of the algebraic structure. To +namespace contains the definitions of the algebraic structure. To keep the example small, the algebraic structure ``EQ.type`` we are defining is very simplistic, and characterizes terms on which a binary relation is defined, without requiring such relation to validate any property. The inner theory module contains the overloaded notation ``==`` -and will eventually contain lemmas holding on all the instances of the +and will eventually contain lemmas holding all the instances of the algebraic structure (in this case there are no lemmas). Note that in practice the user may want to declare ``EQ.obj`` as a coercion, but we will not do that here. The following line tests that, when we assume a type ``e`` that is in -theEQ class, then we can relates two of its objects with ``==``. +theEQ class, we can relate two of its objects with ``==``. .. coqtop:: all @@ -312,7 +312,7 @@ The following script registers an ``LEQ`` class for ``nat`` and for the type constructor ``*``. It also tests that they work as expected. Unfortunately, these declarations are very verbose. In the following -subsection we show how to make these declaration more compact. +subsection we show how to make them more compact. .. coqtop:: all @@ -385,7 +385,7 @@ with message "T is not an EQ.type"”. The other utilities are used to ask |Coq| to solve a specific unification problem, that will in turn require the inference of some canonical structures. -They are explained in mode details in :cite:`CSwcu`. +They are explained in more details in :cite:`CSwcu`. We now have all we need to create a compact “packager” to declare instances of the ``LEQ`` class. diff --git a/doc/sphinx/addendum/implicit-coercions.rst b/doc/sphinx/addendum/implicit-coercions.rst index 09faa06765..f134022eb6 100644 --- a/doc/sphinx/addendum/implicit-coercions.rst +++ b/doc/sphinx/addendum/implicit-coercions.rst @@ -31,7 +31,7 @@ A class with `n` parameters is any defined name with a type :g:`forall (x₁:A₁)..(xₙ:Aₙ),s` where ``s`` is a sort. Thus a class with parameters is considered as a single class and not as a family of classes. An object of a class ``C`` is any term of type :g:`C t₁ .. tₙ`. -In addition to these user-classes, we have two abstract classes: +In addition to these user-defined classes, we have two built-in classes: * ``Sortclass``, the class of sorts; its objects are the terms whose type is a @@ -50,11 +50,11 @@ Formally, the syntax of a classes is defined as: Coercions --------- -A name ``f`` can be declared as a coercion between a source user-class +A name ``f`` can be declared as a coercion between a source user-defined class ``C`` with `n` parameters and a target class ``D`` if one of these conditions holds: - * ``D`` is a user-class, then the type of ``f`` must have the form + * ``D`` is a user-defined class, then the type of ``f`` must have the form :g:`forall (x₁:A₁)..(xₙ:Aₙ)(y:C x₁..xₙ), D u₁..uₘ` where `m` is the number of parameters of ``D``. * ``D`` is ``Funclass``, then the type of ``f`` must have the form @@ -65,8 +65,8 @@ conditions holds: We then write :g:`f : C >-> D`. The restriction on the type of coercions is called *the uniform inheritance condition*. -.. note:: The abstract class ``Sortclass`` can be used as a source class, but - the abstract class ``Funclass`` cannot. +.. note:: The built-in class ``Sortclass`` can be used as a source class, but + the built-in class ``Funclass`` cannot. To coerce an object :g:`t:C t₁..tₙ` of ``C`` towards ``D``, we have to apply the coercion ``f`` to it; the obtained term :g:`f t₁..tₙ t` is @@ -95,7 +95,7 @@ We can now declare ``f`` as coercion from ``C'`` to ``D``, since we can The identity coercions have a special status: to coerce an object :g:`t:C' t₁..tₖ` -of ``C'`` towards ``C``, we does not have to insert explicitly ``Id_C'_C`` +of ``C'`` towards ``C``, we do not have to insert explicitly ``Id_C'_C`` since :g:`Id_C'_C t₁..tₖ t` is convertible with ``t``. However we "rewrite" the type of ``t`` to become an object of ``C``; in this case, it becomes :g:`C uₙ'..uₖ'` where each ``uᵢ'`` is the result of the @@ -121,7 +121,7 @@ by the coercions ``f₁..fₖ``. The application of a coercion path to a term consists of the successive application of its coercions. -Declaration of Coercions +Declaring Coercions ------------------------- .. cmd:: Coercion @qualid : @class >-> @class @@ -140,8 +140,8 @@ Declaration of Coercions .. warn:: Ambiguous path. - When the coercion :token:`qualid` is added to the inheritance graph, non - valid coercion paths are ignored; they are signaled by a warning + When the coercion :token:`qualid` is added to the inheritance graph, + invalid coercion paths are ignored; they are signaled by a warning displaying these paths of the form :g:`[f₁;..;fₙ] : C >-> D`. .. cmdv:: Local Coercion @qualid : @class >-> @class @@ -215,7 +215,7 @@ declaration, this constructor is declared as a coercion. .. cmdv:: Local Identity Coercion @ident : @ident >-> @ident - Idem but locally to the current section. + Same as ``Identity Coercion`` but locally to the current section. .. cmdv:: SubClass @ident := @type :name: SubClass @@ -319,7 +319,7 @@ Coercions and Modules Since |Coq| version 8.3, the coercions present in a module are activated only when the module is explicitly imported. Formerly, the coercions - were activated as soon as the module was required, whatever it was + were activated as soon as the module was required, whether it was imported or not. This option makes it possible to recover the behavior of the versions of @@ -387,8 +387,8 @@ We give now an example using identity coercions. In the case of functional arguments, we use the monotonic rule of -sub-typing. Approximatively, to coerce :g:`t:forall x:A,B` towards -:g:`forall x:A',B'`, one have to coerce ``A'`` towards ``A`` and ``B`` +sub-typing. To coerce :g:`t : forall x : A, B` towards +:g:`forall x : A', B'`, we have to coerce ``A'`` towards ``A`` and ``B`` towards ``B'``. An example is given below: .. coqtop:: all @@ -424,8 +424,8 @@ replaced by ``x:A'`` where ``A'`` is the result of the application to ``Sortclass`` if it exists. This case occurs in the abstraction :g:`fun x:A => t`, universal quantification :g:`forall x:A,B`, global variables and parameters of (co-)inductive definitions and -functions. In :g:`forall x:A,B`, such a coercion path may be applied -to ``B`` also if necessary. +functions. In :g:`forall x:A,B`, such a coercion path may also be applied +to ``B`` if necessary. .. coqtop:: all diff --git a/doc/sphinx/addendum/micromega.rst b/doc/sphinx/addendum/micromega.rst index 0e9c23b9bb..2407a9051a 100644 --- a/doc/sphinx/addendum/micromega.rst +++ b/doc/sphinx/addendum/micromega.rst @@ -96,15 +96,14 @@ and checked to be :math:`-1`. .. tacn:: lra :name: lra -This tactic is searching for *linear* refutations using Fourier -elimination [#]_. As a result, this tactic explores a subset of the *Cone* -defined as + This tactic is searching for *linear* refutations using Fourier + elimination [#]_. As a result, this tactic explores a subset of the *Cone* + defined as - :math:`\mathit{LinCone}(S) =\left\{ \left. \sum_{p \in S} \alpha_p \times p~\right|~\alpha_p \mbox{ are positive constants} \right\}` + :math:`\mathit{LinCone}(S) =\left\{ \left. \sum_{p \in S} \alpha_p \times p~\right|~\alpha_p \mbox{ are positive constants} \right\}` -The deductive power of `lra` is the combined deductive power of -`ring_simplify` and `fourier`. There is also an overlap with the field -tactic *e.g.*, :math:`x = 10 * x / 10` is solved by `lra`. + The deductive power of :tacn:`lra` overlaps with the one of :tacn:`field` + tactic *e.g.*, :math:`x = 10 * x / 10` is solved by :tacn:`lra`. `lia`: a tactic for linear integer arithmetic diff --git a/doc/sphinx/language/cic.rst b/doc/sphinx/language/cic.rst index b01a4ef0f9..98e81ebc65 100644 --- a/doc/sphinx/language/cic.rst +++ b/doc/sphinx/language/cic.rst @@ -1175,7 +1175,7 @@ ourselves to primitive recursive functions and functionals. For instance, assuming a parameter :g:`A:Set` exists in the local context, we want to build a function length of type :g:`list A -> nat` which computes -the length of the list, so such that :g:`(length (nil A)) = O` and :g:`(length +the length of the list, such that :g:`(length (nil A)) = O` and :g:`(length (cons A a l)) = (S (length l))`. We want these equalities to be recognized implicitly and taken into account in the conversion rule. @@ -1364,7 +1364,7 @@ irrelevance property which is sometimes a useful axiom: The elimination of an inductive definition of type :math:`\Prop` on a predicate :math:`P` of type :math:`I→ Type` leads to a paradox when applied to impredicative inductive definition like the second-order existential quantifier -:g:`exProp` defined above, because it give access to the two projections on +:g:`exProp` defined above, because it gives access to the two projections on this type. @@ -1613,7 +1613,7 @@ then the recursive arguments will correspond to :math:`T_i` in which one of the :math:`I_l` occurs. The main rules for being structurally smaller are the following. -Given a variable :math:`y` of type an inductive definition in a declaration +Given a variable :math:`y` of an inductively defined type in a declaration :math:`\ind{r}{Γ_I}{Γ_C}` where :math:`Γ_I` is :math:`[I_1 :A_1 ;…;I_k :A_k]`, and :math:`Γ_C` is :math:`[c_1 :C_1 ;…;c_n :C_n ]`, the terms structurally smaller than :math:`y` are: @@ -1625,7 +1625,7 @@ Given a variable :math:`y` of type an inductive definition in a declaration Each :math:`f_i` corresponds to a type of constructor :math:`C_q ≡ ∀ p_1 :P_1 ,…,∀ p_r :P_r , ∀ y_1 :B_1 , … ∀ y_k :B_k , (I~a_1 … a_k )` and can consequently be written :math:`λ y_1 :B_1' . … λ y_k :B_k'. g_i`. (:math:`B_i'` is - obtained from :math:`B_i` by substituting parameters variables) the variables + obtained from :math:`B_i` by substituting parameters for variables) the variables :math:`y_j` occurring in :math:`g_i` corresponding to recursive arguments :math:`B_i` (the ones in which one of the :math:`I_l` occurs) are structurally smaller than y. @@ -1801,7 +1801,7 @@ definitions can be found in :cite:`Gimenez95b,Gim98,GimCas05`. .. _The-Calculus-of-Inductive-Construction-with-impredicative-Set: -The Calculus of Inductive Construction with impredicative Set +The Calculus of Inductive Constructions with impredicative Set ----------------------------------------------------------------- |Coq| can be used as a type-checker for the Calculus of Inductive @@ -1834,7 +1834,7 @@ inductive definitions* like the example of second-order existential quantifier (:g:`exSet`). There should be restrictions on the eliminations which can be -performed on such definitions. The eliminations rules in the +performed on such definitions. The elimination rules in the impredicative system for sort :math:`\Set` become: diff --git a/doc/sphinx/language/coq-library.rst b/doc/sphinx/language/coq-library.rst index afb49413dd..52c56d2bd2 100644 --- a/doc/sphinx/language/coq-library.rst +++ b/doc/sphinx/language/coq-library.rst @@ -705,21 +705,29 @@ fixpoint equation can be proved. Accessing the Type level ~~~~~~~~~~~~~~~~~~~~~~~~ -The basic library includes the definitions of the counterparts of some data-types and logical -quantifiers at the ``Type``: level: negation, pair, and properties -of ``identity``. This is the module ``Logic_Type.v``. +The standard library includes ``Type`` level definitions of counterparts of some +logic concepts and basic lemmas about them. + +The module ``Datatypes`` defines ``identity``, which is the ``Type`` level counterpart +of equality: + +.. index:: + single: identity (term) + +.. coqtop:: in + + Inductive identity (A:Type) (a:A) : A -> Type := + identity_refl : identity a a. + +Some properties of ``identity`` are proved in the module ``Logic_Type``, which also +provides the definition of ``Type`` level negation: .. index:: single: notT (term) - single: prodT (term) - single: pairT (term) .. coqtop:: in Definition notT (A:Type) := A -> False. - Inductive prodT (A B:Type) : Type := pairT (_:A) (_:B). - -At the end, it defines data-types at the ``Type`` level. Tactics ~~~~~~~ @@ -889,7 +897,7 @@ Notation Interpretation Some tactics for real numbers +++++++++++++++++++++++++++++ -In addition to the powerful ``ring``, ``field`` and ``fourier`` +In addition to the powerful ``ring``, ``field`` and ``lra`` tactics (see Chapter :ref:`tactics`), there are also: .. tacn:: discrR diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index 509ac92f81..394b928ada 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -781,7 +781,8 @@ Section :ref:`gallina-definitions`). .. cmd:: Section @ident - This command is used to open a section named `ident`. + This command is used to open a section named :token:`ident`. + Section names do not need to be unique. .. cmd:: End @ident @@ -1079,7 +1080,7 @@ The definition of ``N`` using the module type expression ``SIG`` with Module N : SIG' := M. -If we just want to be sure that the our implementation satisfies a +If we just want to be sure that our implementation satisfies a given module type without restricting the interface, we can use a transparent constraint diff --git a/doc/sphinx/practical-tools/utilities.rst b/doc/sphinx/practical-tools/utilities.rst index bdaa2aa1a2..e15bcb8e2c 100644 --- a/doc/sphinx/practical-tools/utilities.rst +++ b/doc/sphinx/practical-tools/utilities.rst @@ -546,12 +546,12 @@ The printing for one token can be removed with Initially, the pretty-printing table contains the following mapping: -==== === ==== ===== === ==== ==== === -`->` → `<-` ← `*` × -`<=` ≤ `>=` ≥ `=>` ⇒ -`<>` ≠ `<->` ↔ `|-` ⊢ -`\/` ∨ `/\\` ∧ `~` ¬ -==== === ==== ===== === ==== ==== === +===== === ==== ===== === ==== ==== === +`->` → `<-` ← `*` × +`<=` ≤ `>=` ≥ `=>` ⇒ +`<>` ≠ `<->` ↔ `|-` ⊢ +`\\/` ∨ `/\\` ∧ `~` ¬ +===== === ==== ===== === ==== ==== === Any of these can be overwritten or suppressed using the printing commands. diff --git a/doc/sphinx/proof-engine/detailed-tactic-examples.rst b/doc/sphinx/proof-engine/detailed-tactic-examples.rst index 84810ddba5..78719c1ef1 100644 --- a/doc/sphinx/proof-engine/detailed-tactic-examples.rst +++ b/doc/sphinx/proof-engine/detailed-tactic-examples.rst @@ -25,7 +25,7 @@ argument an hypothesis to generalize. It uses the JMeq datatype defined in Coq.Logic.JMeq, hence we need to require it before. For example, revisiting the first example of the inversion documentation: -.. coqtop:: in +.. coqtop:: in reset Require Import Coq.Logic.JMeq. @@ -63,6 +63,10 @@ to use an heterogeneous equality to relate the new hypothesis to the old one (which just disappeared here). However, the tactic works just as well in this case, e.g.: +.. coqtop:: none + + Abort. + .. coqtop:: in Variable Q : forall (n m : nat), Le n m -> Prop. @@ -80,7 +84,7 @@ to recover the needed equalities. Also, some subgoals should be directly solved because of inconsistent contexts arising from the constraints on indexes. The nice thing is that we can make a tactic based on discriminate, injection and variants of substitution to -automatically do such simplifications (which may involve the K axiom). +automatically do such simplifications (which may involve the axiom K). This is what the ``simplify_dep_elim`` tactic from ``Coq.Program.Equality`` does. For example, we might simplify the previous goals considerably: @@ -101,9 +105,9 @@ are ``dependent induction`` and ``dependent destruction`` that do induction or simply case analysis on the generalized hypothesis. For example we can redo what we’ve done manually with dependent destruction: -.. coqtop:: in +.. coqtop:: none - Require Import Coq.Program.Equality. + Abort. .. coqtop:: in @@ -122,9 +126,9 @@ destructed hypothesis actually appeared in the goal, the tactic would still be able to invert it, contrary to dependent inversion. Consider the following example on vectors: -.. coqtop:: in +.. coqtop:: none - Require Import Coq.Program.Equality. + Abort. .. coqtop:: in @@ -167,7 +171,7 @@ predicates on a real example. We will develop an example application to the theory of simply-typed lambda-calculus formalized in a dependently-typed style: -.. coqtop:: in +.. coqtop:: in reset Inductive type : Type := | base : type @@ -226,11 +230,15 @@ name. A term is either an application of: Once we have this datatype we want to do proofs on it, like weakening: -.. coqtop:: in undo +.. coqtop:: in Lemma weakening : forall G D tau, term (G ; D) tau -> forall tau', term (G , tau' ; D) tau. +.. coqtop:: none + + Abort. + The problem here is that we can’t just use induction on the typing derivation because it will forget about the ``G ; D`` constraint appearing in the instance. A solution would be to rewrite the goal as: @@ -241,6 +249,10 @@ in the instance. A solution would be to rewrite the goal as: forall G D, (G ; D) = G' -> forall tau', term (G, tau' ; D) tau. +.. coqtop:: none + + Abort. + With this proper separation of the index from the instance and the right induction loading (putting ``G`` and ``D`` after the inducted-on hypothesis), the proof will go through, but it is a very tedious @@ -252,6 +264,7 @@ back automatically. Indeed we can simply write: .. coqtop:: in Require Import Coq.Program.Tactics. + Require Import Coq.Program.Equality. .. coqtop:: in @@ -308,17 +321,14 @@ it can be used directly. apply weak, IHterm. -If there is an easy first-order solution to these equations as in this -subgoal, the ``specialize_eqs`` tactic can be used instead of giving -explicit proof terms: - -.. coqtop:: all +Now concluding this subgoal is easy. - specialize_eqs IHterm. +.. coqtop:: in -This concludes our example. + constructor; apply IHterm; reflexivity. -See also: The :tacn:`induction`, :tacn:`case`, and :tacn:`inversion` tactics. +.. seealso:: + The :tacn:`induction`, :tacn:`case`, and :tacn:`inversion` tactics. autorewrite @@ -331,79 +341,83 @@ involves conditional rewritings and shows how to deal with them using the optional tactic of the ``Hint Rewrite`` command. -Example 1: Ackermann function +.. example:: + Ackermann function -.. coqtop:: in + .. coqtop:: in reset - Reset Initial. + Require Import Arith. -.. coqtop:: in + .. coqtop:: in - Require Import Arith. + Variable Ack : nat -> nat -> nat. -.. coqtop:: in + .. coqtop:: in - Variable Ack : nat -> nat -> nat. + Axiom Ack0 : forall m:nat, Ack 0 m = S m. + Axiom Ack1 : forall n:nat, Ack (S n) 0 = Ack n 1. + Axiom Ack2 : forall n m:nat, Ack (S n) (S m) = Ack n (Ack (S n) m). -.. coqtop:: in + .. coqtop:: in - Axiom Ack0 : forall m:nat, Ack 0 m = S m. - Axiom Ack1 : forall n:nat, Ack (S n) 0 = Ack n 1. - Axiom Ack2 : forall n m:nat, Ack (S n) (S m) = Ack n (Ack (S n) m). + Hint Rewrite Ack0 Ack1 Ack2 : base0. -.. coqtop:: in + .. coqtop:: all - Hint Rewrite Ack0 Ack1 Ack2 : base0. + Lemma ResAck0 : Ack 3 2 = 29. -.. coqtop:: all + .. coqtop:: all - Lemma ResAck0 : Ack 3 2 = 29. + autorewrite with base0 using try reflexivity. -.. coqtop:: all +.. example:: + MacCarthy function - autorewrite with base0 using try reflexivity. + .. coqtop:: in reset -Example 2: Mac Carthy function + Require Import Omega. -.. coqtop:: in + .. coqtop:: in - Require Import Omega. + Variable g : nat -> nat -> nat. -.. coqtop:: in + .. coqtop:: in - Variable g : nat -> nat -> nat. + Axiom g0 : forall m:nat, g 0 m = m. + Axiom g1 : forall n m:nat, (n > 0) -> (m > 100) -> g n m = g (pred n) (m - 10). + Axiom g2 : forall n m:nat, (n > 0) -> (m <= 100) -> g n m = g (S n) (m + 11). -.. coqtop:: in + .. coqtop:: in - Axiom g0 : forall m:nat, g 0 m = m. - Axiom g1 : forall n m:nat, (n > 0) -> (m > 100) -> g n m = g (pred n) (m - 10). - Axiom g2 : forall n m:nat, (n > 0) -> (m <= 100) -> g n m = g (S n) (m + 11). + Hint Rewrite g0 g1 g2 using omega : base1. + .. coqtop:: in -.. coqtop:: in + Lemma Resg0 : g 1 110 = 100. - Hint Rewrite g0 g1 g2 using omega : base1. + .. coqtop:: out -.. coqtop:: in + Show. - Lemma Resg0 : g 1 110 = 100. + .. coqtop:: all -.. coqtop:: out + autorewrite with base1 using reflexivity || simpl. - Show. + .. coqtop:: none -.. coqtop:: all + Qed. - autorewrite with base1 using reflexivity || simpl. + .. coqtop:: all -.. coqtop:: all + Lemma Resg1 : g 1 95 = 91. - Lemma Resg1 : g 1 95 = 91. + .. coqtop:: all -.. coqtop:: all + autorewrite with base1 using reflexivity || simpl. - autorewrite with base1 using reflexivity || simpl. + .. coqtop:: none + Qed. .. _quote: @@ -419,7 +433,7 @@ the form ``(f t)``. ``L`` must have a constructor of type: ``A -> L``. Here is an example: -.. coqtop:: in +.. coqtop:: in reset Require Import Quote. @@ -461,16 +475,11 @@ corresponding left-hand side and call yourself recursively on sub- terms. If there is no match, we are at a leaf: return the corresponding constructor (here ``f_const``) applied to the term. - -Error messages: - - -#. quote: not a simple fixpoint +.. exn:: quote: not a simple fixpoint Happens when ``quote`` is not able to perform inversion properly. - Introducing variables map ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -553,7 +562,13 @@ example, this is the case for the :tacn:`ring` tactic. Then one must provide to is ``[O S]`` then closed natural numbers will be considered as constants and other terms as variables. -Example: +.. coqtop:: in reset + + Require Import Quote. + +.. coqtop:: in + + Parameters A B C : Prop. .. coqtop:: in @@ -594,8 +609,9 @@ Example: quote interp_f [ B C iff ]. -Warning: Since function inversion is undecidable in general case, -don’t expect miracles from it! +.. warning:: + Since functional inversion is undecidable in the general case, + don’t expect miracles from it! .. tacv:: quote @ident in @term using @tactic @@ -607,25 +623,28 @@ don’t expect miracles from it! Same as above, but will use the additional ``ident`` list to chose which subterms are constants (see above). -See also: comments of source file ``plugins/quote/quote.ml`` +.. seealso:: + Comments from the source file ``plugins/quote/quote.ml`` -See also: the :tacn:`ring` tactic. +.. seealso:: + The :tacn:`ring` tactic. -Using the tactical language +Using the tactic language --------------------------- About the cardinality of the set of natural numbers ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A first example which shows how to use pattern matching over the -proof contexts is the proof that natural numbers have more than two -elements. The proof of such a lemma can be done as follows: +The first example which shows how to use pattern matching over the +proof context is a proof of the fact that natural numbers have more +than two elements. This can be done as follows: -.. coqtop:: in +.. coqtop:: in reset - Lemma card_nat : ~ (exists x : nat, exists y : nat, forall z:nat, x = z \/ y = z). + Lemma card_nat : + ~ exists x : nat, exists y : nat, forall z:nat, x = z \/ y = z. Proof. .. coqtop:: in @@ -637,8 +656,8 @@ elements. The proof of such a lemma can be done as follows: elim (Hy 0); elim (Hy 1); elim (Hy 2); intros; match goal with - | [_:(?a = ?b),_:(?a = ?c) |- _ ] => - cut (b = c); [ discriminate | transitivity a; auto ] + | _ : ?a = ?b, _ : ?a = ?c |- _ => + cut (b = c); [ discriminate | transitivity a; auto ] end. .. coqtop:: in @@ -651,16 +670,14 @@ solved by a match goal structure and, in particular, with only one pattern (use of non-linear matching). -Permutation on closed lists +Permutations of lists ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Another more complex example is the problem of permutation on closed -lists. The aim is to show that a closed list is a permutation of -another one. - -First, we define the permutation predicate as shown here: +A more complex example is the problem of permutations of +lists. The aim is to show that a list is a permutation of +another list. -.. coqtop:: in +.. coqtop:: in reset Section Sort. @@ -670,205 +687,179 @@ First, we define the permutation predicate as shown here: .. coqtop:: in - Inductive permut : list A -> list A -> Prop := - | permut_refl : forall l, permut l l - | permut_cons : forall a l0 l1, permut l0 l1 -> permut (a :: l0) (a :: l1) - | permut_append : forall a l, permut (a :: l) (l ++ a :: nil) - | permut_trans : forall l0 l1 l2, permut l0 l1 -> permut l1 l2 -> permut l0 l2. + Inductive perm : list A -> list A -> Prop := + | perm_refl : forall l, perm l l + | perm_cons : forall a l0 l1, perm l0 l1 -> perm (a :: l0) (a :: l1) + | perm_append : forall a l, perm (a :: l) (l ++ a :: nil) + | perm_trans : forall l0 l1 l2, perm l0 l1 -> perm l1 l2 -> perm l0 l2. .. coqtop:: in End Sort. -A more complex example is the problem of permutation on closed lists. -The aim is to show that a closed list is a permutation of another one. First, we define the permutation predicate as shown above. - .. coqtop:: none Require Import List. -.. coqtop:: all - - Ltac Permut n := - match goal with - | |- (permut _ ?l ?l) => apply permut_refl - | |- (permut _ (?a :: ?l1) (?a :: ?l2)) => - let newn := eval compute in (length l1) in - (apply permut_cons; Permut newn) - | |- (permut ?A (?a :: ?l1) ?l2) => - match eval compute in n with - | 1 => fail - | _ => - let l1' := constr:(l1 ++ a :: nil) in - (apply (permut_trans A (a :: l1) l1' l2); - [ apply permut_append | compute; Permut (pred n) ]) - end - end. - - -.. coqtop:: all - - Ltac PermutProve := - match goal with - | |- (permut _ ?l1 ?l2) => - match eval compute in (length l1 = length l2) with - | (?n = ?n) => Permut n - end - end. - -Next, we can write naturally the tactic and the result can be seen -above. We can notice that we use two top level definitions -``PermutProve`` and ``Permut``. The function to be called is -``PermutProve`` which computes the lengths of the two lists and calls -``Permut`` with the length if the two lists have the same -length. ``Permut`` works as expected. If the two lists are equal, it -concludes. Otherwise, if the lists have identical first elements, it -applies ``Permut`` on the tail of the lists. Finally, if the lists -have different first elements, it puts the first element of one of the -lists (here the second one which appears in the permut predicate) at -the end if that is possible, i.e., if the new first element has been -at this place previously. To verify that all rotations have been done -for a list, we use the length of the list as an argument for Permut -and this length is decremented for each rotation down to, but not -including, 1 because for a list of length ``n``, we can make exactly -``n−1`` rotations to generate at most ``n`` distinct lists. Here, it -must be noticed that we use the natural numbers of Coq for the -rotation counter. In :ref:`ltac-syntax`, we can -see that it is possible to use usual natural numbers but they are only -used as arguments for primitive tactics and they cannot be handled, in -particular, we cannot make computations with them. So, a natural -choice is to use Coq data structures so that Coq makes the -computations (reductions) by eval compute in and we can get the terms -back by match. - -With ``PermutProve``, we can now prove lemmas as follows: - .. coqtop:: in - Lemma permut_ex1 : permut nat (1 :: 2 :: 3 :: nil) (3 :: 2 :: 1 :: nil). + Ltac perm_aux n := + match goal with + | |- (perm _ ?l ?l) => apply perm_refl + | |- (perm _ (?a :: ?l1) (?a :: ?l2)) => + let newn := eval compute in (length l1) in + (apply perm_cons; perm_aux newn) + | |- (perm ?A (?a :: ?l1) ?l2) => + match eval compute in n with + | 1 => fail + | _ => + let l1' := constr:(l1 ++ a :: nil) in + (apply (perm_trans A (a :: l1) l1' l2); + [ apply perm_append | compute; perm_aux (pred n) ]) + end + end. -.. coqtop:: in +Next we define an auxiliary tactic ``perm_aux`` which takes an argument +used to control the recursion depth. This tactic behaves as follows. If +the lists are identical (i.e. convertible), it concludes. Otherwise, if +the lists have identical heads, it proceeds to look at their tails. +Finally, if the lists have different heads, it rotates the first list by +putting its head at the end if the new head hasn't been the head previously. To check this, we keep track of the +number of performed rotations using the argument ``n``. We do this by +decrementing ``n`` each time we perform a rotation. It works because +for a list of length ``n`` we can make exactly ``n - 1`` rotations +to generate at most ``n`` distinct lists. Notice that we use the natural +numbers of Coq for the rotation counter. From :ref:`ltac-syntax` we know +that it is possible to use the usual natural numbers, but they are only +used as arguments for primitive tactics and they cannot be handled, so, +in particular, we cannot make computations with them. Thus the natural +choice is to use Coq data structures so that Coq makes the computations +(reductions) by ``eval compute in`` and we can get the terms back by match. + +.. coqtop:: in + + Ltac solve_perm := + match goal with + | |- (perm _ ?l1 ?l2) => + match eval compute in (length l1 = length l2) with + | (?n = ?n) => perm_aux n + end + end. - Proof. PermutProve. Qed. +The main tactic is ``solve_perm``. It computes the lengths of the two lists +and uses them as arguments to call ``perm_aux`` if the lengths are equal (if they +aren't, the lists cannot be permutations of each other). Using this tactic we +can now prove lemmas as follows: .. coqtop:: in - Lemma permut_ex2 : permut nat - (0 :: 1 :: 2 :: 3 :: 4 :: 5 :: 6 :: 7 :: 8 :: 9 :: nil) - (0 :: 2 :: 4 :: 6 :: 8 :: 9 :: 7 :: 5 :: 3 :: 1 :: nil). - - Proof. PermutProve. Qed. + Lemma solve_perm_ex1 : + perm nat (1 :: 2 :: 3 :: nil) (3 :: 2 :: 1 :: nil). + Proof. solve_perm. Qed. +.. coqtop:: in + Lemma solve_perm_ex2 : + perm nat + (0 :: 1 :: 2 :: 3 :: 4 :: 5 :: 6 :: 7 :: 8 :: 9 :: nil) + (0 :: 2 :: 4 :: 6 :: 8 :: 9 :: 7 :: 5 :: 3 :: 1 :: nil). + Proof. solve_perm. Qed. Deciding intuitionistic propositional logic ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. _decidingintuitionistic1: - -.. coqtop:: all - - Ltac Axioms := - match goal with - | |- True => trivial - | _:False |- _ => elimtype False; assumption - | _:?A |- ?A => auto - end. - -.. _decidingintuitionistic2: - -.. coqtop:: all - - Ltac DSimplif := - repeat - (intros; - match goal with - | id:(~ _) |- _ => red in id - | id:(_ /\ _) |- _ => - elim id; do 2 intro; clear id - | id:(_ \/ _) |- _ => - elim id; intro; clear id - | id:(?A /\ ?B -> ?C) |- _ => - cut (A -> B -> C); - [ intro | intros; apply id; split; assumption ] - | id:(?A \/ ?B -> ?C) |- _ => - cut (B -> C); - [ cut (A -> C); - [ intros; clear id - | intro; apply id; left; assumption ] - | intro; apply id; right; assumption ] - | id0:(?A -> ?B),id1:?A |- _ => - cut B; [ intro; clear id0 | apply id0; assumption ] - | |- (_ /\ _) => split - | |- (~ _) => red - end). - -.. coqtop:: all - - Ltac TautoProp := - DSimplif; - Axioms || - match goal with - | id:((?A -> ?B) -> ?C) |- _ => - cut (B -> C); - [ intro; cut (A -> B); - [ intro; cut C; - [ intro; clear id | apply id; assumption ] - | clear id ] - | intro; apply id; intro; assumption ]; TautoProp - | id:(~ ?A -> ?B) |- _ => - cut (False -> B); - [ intro; cut (A -> False); - [ intro; cut B; - [ intro; clear id | apply id; assumption ] - | clear id ] - | intro; apply id; red; intro; assumption ]; TautoProp - | |- (_ \/ _) => (left; TautoProp) || (right; TautoProp) - end. - -The pattern matching on goals allows a complete and so a powerful -backtracking when returning tactic values. An interesting application -is the problem of deciding intuitionistic propositional logic. -Considering the contraction-free sequent calculi LJT* of Roy Dyckhoff -:cite:`Dyc92`, it is quite natural to code such a tactic -using the tactic language as shown on figures: :ref:`Deciding -intuitionistic propositions (1) <decidingintuitionistic1>` and -:ref:`Deciding intuitionistic propositions (2) -<decidingintuitionistic2>`. The tactic ``Axioms`` tries to conclude -using usual axioms. The tactic ``DSimplif`` applies all the reversible -rules of Dyckhoff’s system. Finally, the tactic ``TautoProp`` (the -main tactic to be called) simplifies with ``DSimplif``, tries to -conclude with ``Axioms`` and tries several paths using the -backtracking rules (one of the four Dyckhoff’s rules for the left -implication to get rid of the contraction and the right or). - -For example, with ``TautoProp``, we can prove tautologies like those: - -.. coqtop:: in - - Lemma tauto_ex1 : forall A B:Prop, A /\ B -> A \/ B. +Pattern matching on goals allows a powerful backtracking when returning tactic +values. An interesting application is the problem of deciding intuitionistic +propositional logic. Considering the contraction-free sequent calculi LJT* of +Roy Dyckhoff :cite:`Dyc92`, it is quite natural to code such a tactic using the +tactic language as shown below. -.. coqtop:: in - - Proof. TautoProp. Qed. - -.. coqtop:: in +.. coqtop:: in reset - Lemma tauto_ex2 : - forall A B:Prop, (~ ~ B -> B) -> (A -> B) -> ~ ~ A -> B. + Ltac basic := + match goal with + | |- True => trivial + | _ : False |- _ => contradiction + | _ : ?A |- ?A => assumption + end. .. coqtop:: in - Proof. TautoProp. Qed. + Ltac simplify := + repeat (intros; + match goal with + | H : ~ _ |- _ => red in H + | H : _ /\ _ |- _ => + elim H; do 2 intro; clear H + | H : _ \/ _ |- _ => + elim H; intro; clear H + | H : ?A /\ ?B -> ?C |- _ => + cut (A -> B -> C); + [ intro | intros; apply H; split; assumption ] + | H: ?A \/ ?B -> ?C |- _ => + cut (B -> C); + [ cut (A -> C); + [ intros; clear H + | intro; apply H; left; assumption ] + | intro; apply H; right; assumption ] + | H0 : ?A -> ?B, H1 : ?A |- _ => + cut B; [ intro; clear H0 | apply H0; assumption ] + | |- _ /\ _ => split + | |- ~ _ => red + end). + +.. coqtop:: in + + Ltac my_tauto := + simplify; basic || + match goal with + | H : (?A -> ?B) -> ?C |- _ => + cut (B -> C); + [ intro; cut (A -> B); + [ intro; cut C; + [ intro; clear H | apply H; assumption ] + | clear H ] + | intro; apply H; intro; assumption ]; my_tauto + | H : ~ ?A -> ?B |- _ => + cut (False -> B); + [ intro; cut (A -> False); + [ intro; cut B; + [ intro; clear H | apply H; assumption ] + | clear H ] + | intro; apply H; red; intro; assumption ]; my_tauto + | |- _ \/ _ => (left; my_tauto) || (right; my_tauto) + end. + +The tactic ``basic`` tries to reason using simple rules involving truth, falsity +and available assumptions. The tactic ``simplify`` applies all the reversible +rules of Dyckhoff’s system. Finally, the tactic ``my_tauto`` (the main +tactic to be called) simplifies with ``simplify``, tries to conclude with +``basic`` and tries several paths using the backtracking rules (one of the +four Dyckhoff’s rules for the left implication to get rid of the contraction +and the right ``or``). + +Having defined ``my_tauto``, we can prove tautologies like these: + +.. coqtop:: in + + Lemma my_tauto_ex1 : + forall A B : Prop, A /\ B -> A \/ B. + Proof. my_tauto. Qed. + +.. coqtop:: in + + Lemma my_tauto_ex2 : + forall A B : Prop, (~ ~ B -> B) -> (A -> B) -> ~ ~ A -> B. + Proof. my_tauto. Qed. Deciding type isomorphisms ~~~~~~~~~~~~~~~~~~~~~~~~~~ -A more tricky problem is to decide equalities between types and modulo +A more tricky problem is to decide equalities between types modulo isomorphisms. Here, we choose to use the isomorphisms of the simply typed λ-calculus with Cartesian product and unit type (see, for example, :cite:`RC95`). The axioms of this λ-calculus are given below. @@ -915,112 +906,104 @@ example, :cite:`RC95`). The axioms of this λ-calculus are given below. End Iso_axioms. +.. coqtop:: in + Ltac simplify_type ty := + match ty with + | ?A * ?B * ?C => + rewrite <- (Ass A B C); try simplify_type_eq + | ?A * ?B -> ?C => + rewrite (Cur A B C); try simplify_type_eq + | ?A -> ?B * ?C => + rewrite (Dis A B C); try simplify_type_eq + | ?A * unit => + rewrite (P_unit A); try simplify_type_eq + | unit * ?B => + rewrite (Com unit B); try simplify_type_eq + | ?A -> unit => + rewrite (AR_unit A); try simplify_type_eq + | unit -> ?B => + rewrite (AL_unit B); try simplify_type_eq + | ?A * ?B => + (simplify_type A; try simplify_type_eq) || + (simplify_type B; try simplify_type_eq) + | ?A -> ?B => + (simplify_type A; try simplify_type_eq) || + (simplify_type B; try simplify_type_eq) + end + with simplify_type_eq := + match goal with + | |- ?A = ?B => try simplify_type A; try simplify_type B + end. -.. _typeisomorphism1: - -.. coqtop:: all - - Ltac DSimplif trm := - match trm with - | (?A * ?B * ?C) => - rewrite <- (Ass A B C); try MainSimplif - | (?A * ?B -> ?C) => - rewrite (Cur A B C); try MainSimplif - | (?A -> ?B * ?C) => - rewrite (Dis A B C); try MainSimplif - | (?A * unit) => - rewrite (P_unit A); try MainSimplif - | (unit * ?B) => - rewrite (Com unit B); try MainSimplif - | (?A -> unit) => - rewrite (AR_unit A); try MainSimplif - | (unit -> ?B) => - rewrite (AL_unit B); try MainSimplif - | (?A * ?B) => - (DSimplif A; try MainSimplif) || (DSimplif B; try MainSimplif) - | (?A -> ?B) => - (DSimplif A; try MainSimplif) || (DSimplif B; try MainSimplif) - end - with MainSimplif := - match goal with - | |- (?A = ?B) => try DSimplif A; try DSimplif B - end. - -.. coqtop:: all +.. coqtop:: in - Ltac Length trm := - match trm with - | (_ * ?B) => let succ := Length B in constr:(S succ) - | _ => constr:(1) - end. + Ltac len trm := + match trm with + | _ * ?B => let succ := len B in constr:(S succ) + | _ => constr:(1) + end. -.. coqtop:: all +.. coqtop:: in Ltac assoc := repeat rewrite <- Ass. +.. coqtop:: in -.. _typeisomorphism2: - -.. coqtop:: all - - Ltac DoCompare n := - match goal with - | [ |- (?A = ?A) ] => reflexivity - | [ |- (?A * ?B = ?A * ?C) ] => - apply Cons; let newn := Length B in - DoCompare newn - | [ |- (?A * ?B = ?C) ] => - match eval compute in n with - | 1 => fail - | _ => - pattern (A * B) at 1; rewrite Com; assoc; DoCompare (pred n) - end - end. - -.. coqtop:: all + Ltac solve_type_eq n := + match goal with + | |- ?A = ?A => reflexivity + | |- ?A * ?B = ?A * ?C => + apply Cons; let newn := len B in solve_type_eq newn + | |- ?A * ?B = ?C => + match eval compute in n with + | 1 => fail + | _ => + pattern (A * B) at 1; rewrite Com; assoc; solve_type_eq (pred n) + end + end. - Ltac CompareStruct := - match goal with - | [ |- (?A = ?B) ] => - let l1 := Length A - with l2 := Length B in - match eval compute in (l1 = l2) with - | (?n = ?n) => DoCompare n - end - end. +.. coqtop:: in -.. coqtop:: all + Ltac compare_structure := + match goal with + | |- ?A = ?B => + let l1 := len A + with l2 := len B in + match eval compute in (l1 = l2) with + | ?n = ?n => solve_type_eq n + end + end. - Ltac IsoProve := MainSimplif; CompareStruct. +.. coqtop:: in + Ltac solve_iso := simplify_type_eq; compare_structure. -The tactic to judge equalities modulo this axiomatization can be -written as shown on these figures: :ref:`type isomorphism tactic (1) -<typeisomorphism1>` and :ref:`type isomorphism tactic (2) -<typeisomorphism2>`. The algorithm is quite simple. Types are reduced -using axioms that can be oriented (this done by ``MainSimplif``). The -normal forms are sequences of Cartesian products without Cartesian -product in the left component. These normal forms are then compared -modulo permutation of the components (this is done by -``CompareStruct``). The main tactic to be called and realizing this -algorithm isIsoProve. +The tactic to judge equalities modulo this axiomatization is shown above. +The algorithm is quite simple. First types are simplified using axioms that +can be oriented (this is done by ``simplify_type`` and ``simplify_type_eq``). +The normal forms are sequences of Cartesian products without Cartesian product +in the left component. These normal forms are then compared modulo permutation +of the components by the tactic ``compare_structure``. If they have the same +lengths, the tactic ``solve_type_eq`` attempts to prove that the types are equal. +The main tactic that puts all these components together is called ``solve_iso``. -Here are examples of what can be solved by ``IsoProve``. +Here are examples of what can be solved by ``solve_iso``. .. coqtop:: in - Lemma isos_ex1 : - forall A B:Set, A * unit * B = B * (unit * A). + Lemma solve_iso_ex1 : + forall A B : Set, A * unit * B = B * (unit * A). Proof. - intros; IsoProve. + intros; solve_iso. Qed. .. coqtop:: in - Lemma isos_ex2 : - forall A B C:Set, - (A * unit -> B * (C * unit)) = (A * unit -> (C -> unit) * C) * (unit -> A -> B). + Lemma solve_iso_ex2 : + forall A B C : Set, + (A * unit -> B * (C * unit)) = + (A * unit -> (C -> unit) * C) * (unit -> A -> B). Proof. - intros; IsoProve. + intros; solve_iso. Qed. diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index 278a4ff012..dc355fa013 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -10,8 +10,8 @@ This chapter gives a compact documentation of |Ltac|, the tactic language available in |Coq|. We start by giving the syntax, and next, we present the informal semantics. If you want to know more regarding this language and especially about its foundations, you can refer to :cite:`Del00`. Chapter -:ref:`detailedexamplesoftactics` is devoted to giving examples of use of this -language on small but also with non-trivial problems. +:ref:`detailedexamplesoftactics` is devoted to giving small but nontrivial +use examples of this language. .. _ltac-syntax: @@ -33,7 +33,7 @@ notation :g:`_` can also be used to denote metavariable whose instance is irrelevant. In the notation :g:`?id`, the identifier allows us to keep instantiations and to make constraints whereas :g:`_` shows that we are not interested in what will be matched. On the right hand side of pattern-matching -clauses, the named metavariable are used without the question mark prefix. There +clauses, the named metavariables are used without the question mark prefix. There is also a special notation for second-order pattern-matching problems: in an applicative pattern of the form :g:`@?id id1 … idn`, the variable id matches any complex expression with (possible) dependencies in the variables :g:`id1 … idn` @@ -160,13 +160,13 @@ Semantics --------- Tactic expressions can only be applied in the context of a proof. The -evaluation yields either a term, an integer or a tactic. Intermediary +evaluation yields either a term, an integer or a tactic. Intermediate results can be terms or integers but the final result must be a tactic which is then applied to the focused goals. There is a special case for ``match goal`` expressions of which the clauses evaluate to tactics. Such expressions can only be used as end result of -a tactic expression (never as argument of a non recursive local +a tactic expression (never as argument of a non-recursive local definition or of an application). The rest of this section explains the semantics of every construction of @@ -197,8 +197,8 @@ following form: :name: [> ... | ... | ... ] (dispatch) The expressions :n:`@expr__i` are evaluated to :n:`v__i`, for - i=0,...,n and all have to be tactics. The :n:`v__i` is applied to the - i-th goal, for =1,...,n. It fails if the number of focused goals is not + i = 0, ..., n and all have to be tactics. The :n:`v__i` is applied to the + i-th goal, for i = 1, ..., n. It fails if the number of focused goals is not exactly n. .. note:: @@ -221,7 +221,7 @@ following form: .. tacv:: [> @expr .. ] In this variant, the tactic :n:`@expr` is applied independently to each of - the goals, rather than globally. In particular, if there are no goal, the + the goals, rather than globally. In particular, if there are no goals, the tactic is not run at all. A tactic which expects multiple goals, such as ``swap``, would act as if a single goal is focused. @@ -385,11 +385,12 @@ tactic to work (i.e. which does not fail) among a panel of tactics: :name: first The :n:`@expr__i` are evaluated to :n:`v__i` and :n:`v__i` must be - tactic values, for i=1,...,n. Supposing n>1, it applies, in each focused - goal independently, :n:`v__1`, if it works, it stops otherwise it + tactic values for i = 1, ..., n. Supposing n > 1, + :n:`first [@expr__1 | ... | @expr__n]` applies :n:`v__1` in each + focused goal independently and stops if it succeeds; otherwise it tries to apply :n:`v__2` and so on. It fails when there is no applicable tactic. In other words, - :n:`first [:@expr__1 | ... | @expr__n]` behaves, in each goal, as the the first + :n:`first [@expr__1 | ... | @expr__n]` behaves, in each goal, as the the first :n:`v__i` to have *at least* one success. .. exn:: No applicable tactic. @@ -397,7 +398,7 @@ tactic to work (i.e. which does not fail) among a panel of tactics: .. tacv:: first @expr This is an |Ltac| alias that gives a primitive access to the first - tactical as a |Ltac| definition without going through a parsing rule. It + tactical as an |Ltac| definition without going through a parsing rule. It expects to be given a list of tactics through a ``Tactic Notation``, allowing to write notations of the following form: @@ -454,7 +455,7 @@ single success *a posteriori*: :n:`@expr` is evaluated to ``v`` which must be a tactic value. The tactic value ``v`` is applied but only its first success is used. If ``v`` fails, - :n:`once @expr` fails like ``v``. If ``v`` has a least one success, + :n:`once @expr` fails like ``v``. If ``v`` has at least one success, :n:`once @expr` succeeds once, but cannot produce more successes. Checking the successes @@ -475,7 +476,7 @@ one* success: .. warning:: The experimental status of this tactic pertains to the fact if ``v`` - performs side effects, they may occur in a unpredictable way. Indeed, + performs side effects, they may occur in an unpredictable way. Indeed, normally ``v`` would only be executed up to the first success until backtracking is needed, however exactly_once needs to look ahead to see whether a second success exists, and may run further effects @@ -515,8 +516,9 @@ among a panel of tactics: :name: solve The :n:`@expr__i` are evaluated to :n:`v__i` and :n:`v__i` must be - tactic values, for i=1,...,n. Supposing n>1, it applies :n:`v__1` to - each goal independently, if it doesn’t solve the goal then it tries to + tactic values, for i = 1, ..., n. Supposing n > 1, + :n:`solve [@expr__1 | ... | @expr__n]` applies :n:`v__1` to + each goal independently and stops if it succeeds; otherwise it tries to apply :n:`v__2` and so on. It fails if there is no solving tactic. .. exn:: Cannot solve the goal. @@ -546,15 +548,13 @@ Failing This is the always-failing tactic: it does not solve any goal. It is useful for defining other tacticals since it can be caught by - :tacn:`try`, :tacn:`repeat`, :tacn:`match goal`, or the branching tacticals. The - :tacn:`fail` tactic will, however, succeed if all the goals have already been - solved. + :tacn:`try`, :tacn:`repeat`, :tacn:`match goal`, or the branching tacticals. .. tacv:: fail @num The number is the failure level. If no level is specified, it defaults to 0. The level is used by :tacn:`try`, :tacn:`repeat`, :tacn:`match goal` and the branching - tacticals. If 0, it makes :tacn:`match goal` considering the next clause + tacticals. If 0, it makes :tacn:`match goal` consider the next clause (backtracking). If non zero, the current :tacn:`match goal` block, :tacn:`try`, :tacn:`repeat`, or branching command is aborted and the level is decremented. In the case of :n:`+`, a non-zero level skips the first backtrack point, even if @@ -572,7 +572,9 @@ Failing .. tacv:: gfail :name: gfail - This variant fails even if there are no goals left. + This variant fails even when used after :n:`;` and there are no goals left. + Similarly, ``gfail`` fails even when used after ``all:`` and there are no + goals left. See the example for clarification. .. tacv:: gfail {* message_token} @@ -582,10 +584,41 @@ Failing there are no goals left. Be careful however if Coq terms have to be printed as part of the failure: term construction always forces the tactic into the goals, meaning that if there are no goals when it is - evaluated, a tactic call like :n:`let x:=H in fail 0 x` will succeed. + evaluated, a tactic call like :n:`let x := H in fail 0 x` will succeed. .. exn:: Tactic Failure message (level @num). + .. exn:: No such goal. + :name: No such goal. (fail) + + .. example:: + + .. coqtop:: all + + Goal True. + Proof. fail. Abort. + + Goal True. + Proof. trivial; fail. Qed. + + Goal True. + Proof. trivial. fail. Abort. + + Goal True. + Proof. trivial. all: fail. Qed. + + Goal True. + Proof. gfail. Abort. + + Goal True. + Proof. trivial; gfail. Abort. + + Goal True. + Proof. trivial. gfail. Abort. + + Goal True. + Proof. trivial. all: gfail. Abort. + Timeout ~~~~~~~ @@ -605,7 +638,7 @@ amount of time: which is very machine-dependent: a script that works on a quick machine may fail on a slow one. The converse is even possible if you combine a timeout with some other tacticals. This tactical is hence proposed only - for convenience during debug or other development phases, we strongly + for convenience during debugging or other development phases, we strongly advise you to not leave any timeout in final scripts. Note also that this tactical isn’t available on the native Windows port of Coq. @@ -617,9 +650,9 @@ A tactic execution can be timed: .. tacn:: time @string @expr :name: time - evaluates :n:`@expr` and displays the time the tactic expression ran, whether it - fails or successes. In case of several successes, the time for each successive - runs is displayed. Time is in seconds and is machine-dependent. The :n:`@string` + evaluates :n:`@expr` and displays the running time of the tactic expression, whether it + fails or succeeds. In case of several successes, the time for each successive + run is displayed. Time is in seconds and is machine-dependent. The :n:`@string` argument is optional. When provided, it is used to identify this particular occurrence of time. @@ -685,12 +718,12 @@ Local definitions can be done as follows: each :n:`@expr__i` is evaluated to :n:`v__i`, then, :n:`@expr` is evaluated by substituting :n:`v__i` to each occurrence of :n:`@ident__i`, for - i=1,...,n. There is no dependencies between the :n:`@expr__i` and the + i = 1, ..., n. There are no dependencies between the :n:`@expr__i` and the :n:`@ident__i`. - Local definitions can be recursive by using :n:`let rec` instead of :n:`let`. + Local definitions can be made recursive by using :n:`let rec` instead of :n:`let`. In this latter case, the definitions are evaluated lazily so that the rec - keyword can be used also in non recursive cases so as to avoid the eager + keyword can be used also in non-recursive cases so as to avoid the eager evaluation of local definitions. .. but rec changes the binding!! @@ -704,7 +737,7 @@ An application is an expression of the following form: The reference :n:`@qualid` must be bound to some defined tactic definition expecting at least as many arguments as the provided :n:`tacarg`. The - expressions :n:`@expr__i` are evaluated to :n:`v__i`, for i=1,...,n. + expressions :n:`@expr__i` are evaluated to :n:`v__i`, for i = 1, ..., n. .. what expressions ?? @@ -755,7 +788,7 @@ We can carry out pattern matching on terms with: evaluation of :n:`@expr__1` fails, or if the evaluation of :n:`@expr__1` succeeds but returns a tactic in execution position whose execution fails, then :n:`cpattern__2` is used and so on. The pattern - :n:`_` matches any term and shunts all remaining patterns if any. If all + :n:`_` matches any term and shadows all remaining patterns if any. If all clauses fail (in particular, there is no pattern :n:`_`) then a no-matching-clause error is raised. @@ -821,14 +854,14 @@ We can carry out pattern matching on terms with: Pattern matching on goals ~~~~~~~~~~~~~~~~~~~~~~~~~ -We can make pattern matching on goals using the following expression: +We can perform pattern matching on goals using the following expression: .. we should provide the full grammar here .. tacn:: match goal with {+| {+ hyp} |- @cpattern => @expr } | _ => @expr end :name: match goal - If each hypothesis pattern :n:`hyp`\ :sub:`1,i`, with i=1,...,m\ :sub:`1` is + If each hypothesis pattern :n:`hyp`\ :sub:`1,i`, with i = 1, ..., m\ :sub:`1` is matched (non-linear first-order unification) by an hypothesis of the goal and if :n:`cpattern_1` is matched by the conclusion of the goal, then :n:`@expr__1` is evaluated to :n:`v__1` by substituting the @@ -857,10 +890,10 @@ We can make pattern matching on goals using the following expression: It is important to know that each hypothesis of the goal can be matched by at most one hypothesis pattern. The order of matching is the - following: hypothesis patterns are examined from the right to the left + following: hypothesis patterns are examined from right to left (i.e. hyp\ :sub:`i,m`\ :sub:`i`` before hyp\ :sub:`i,1`). For each - hypothesis pattern, the goal hypothesis are matched in order (fresher - hypothesis first), but it possible to reverse this order (older first) + hypothesis pattern, the goal hypotheses are matched in order (newest + first), but it possible to reverse this order (oldest first) with the :n:`match reverse goal with` variant. .. tacv:: multimatch goal with {+| {+ hyp} |- @cpattern => @expr } | _ => @expr end @@ -896,6 +929,10 @@ produce subgoals but generates a term to be used in tactic expressions: value of :n:`@ident` by the value of :n:`@expr`. .. exn:: Not a context variable. + :undocumented: + + .. exn:: Unbound context identifier @ident. + :undocumented: Generating fresh hypothesis names ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1167,7 +1204,7 @@ Interactive debugger This option governs the step-by-step debugger that comes with the |Ltac| interpreter When the debugger is activated, it stops at every step of the evaluation of -the current |Ltac| expression and it prints information on what it is doing. +the current |Ltac| expression and prints information on what it is doing. The debugger stops, prompting for a command which can be one of the following: @@ -1185,6 +1222,9 @@ following: | r string: | advance up to the next call to “idtac string” | +-----------------+-----------------------------------------------+ +.. exn:: Debug mode not available in the IDE + :undocumented: + A non-interactive mode for the debugger is available via the option: .. opt:: Ltac Batch Debug @@ -1204,9 +1244,9 @@ which can sometimes be so slow as to impede interactive usage. The reasons for the performence degradation can be intricate, like a slowly performing |Ltac| match or a sub-tactic whose performance only degrades in certain situations. The profiler generates a call tree and -indicates the time spent in a tactic depending its calling context. Thus +indicates the time spent in a tactic depending on its calling context. Thus it allows to locate the part of a tactic definition that contains the -performance bug. +performance issue. .. opt:: Ltac Profiling @@ -1240,8 +1280,12 @@ performance bug. Goal forall x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z, max x (max y z) = max (max x y) z /\ max x (max y z) = max (max x y) z - /\ (A /\ B /\ C /\ D /\ E /\ F /\ G /\ H /\ I /\ J /\ K /\ L /\ M /\ N /\ O /\ P /\ Q /\ R /\ S /\ T /\ U /\ V /\ W /\ X /\ Y /\ Z - -> Z /\ Y /\ X /\ W /\ V /\ U /\ T /\ S /\ R /\ Q /\ P /\ O /\ N /\ M /\ L /\ K /\ J /\ I /\ H /\ G /\ F /\ E /\ D /\ C /\ B /\ A). + /\ + (A /\ B /\ C /\ D /\ E /\ F /\ G /\ H /\ I /\ J /\ K /\ L /\ M /\ + N /\ O /\ P /\ Q /\ R /\ S /\ T /\ U /\ V /\ W /\ X /\ Y /\ Z + -> + Z /\ Y /\ X /\ W /\ V /\ U /\ T /\ S /\ R /\ Q /\ P /\ O /\ N /\ + M /\ L /\ K /\ J /\ I /\ H /\ G /\ F /\ E /\ D /\ C /\ B /\ A). Proof. .. coqtop:: all diff --git a/doc/sphinx/proof-engine/proof-handling.rst b/doc/sphinx/proof-engine/proof-handling.rst index eba0db3ff5..44376080c3 100644 --- a/doc/sphinx/proof-engine/proof-handling.rst +++ b/doc/sphinx/proof-engine/proof-handling.rst @@ -321,7 +321,7 @@ Navigation in the proof tree goal, much like :cmd:`Focus` does, however, the subproof can only be unfocused when it has been fully solved ( *i.e.* when there is no focused goal left). Unfocusing is then handled by ``}`` (again, without a - terminating period). See also example in next section. + terminating period). See also an example in the next section. Note that when a focused goal is proved a message is displayed together with a suggestion about the right bullet or ``}`` to unfocus it @@ -403,7 +403,7 @@ The following example script illustrates all these features: .. exn:: No such goal. Focus next goal with bullet @bullet. - You tried to apply a tactic but no goal where under focus. Using :n:`@bullet` is mandatory here. + You tried to apply a tactic but no goals were under focus. Using :n:`@bullet` is mandatory here. .. exn:: No such goal. Try unfocusing with %{. @@ -470,7 +470,7 @@ Requesting information constructed. These holes appear as a question mark indexed by an integer, and applied to the list of variables in the context, since it may depend on them. The types obtained by abstracting away the context - from the type of each hole-placer are also printed. + from the type of each placeholder are also printed. .. cmdv:: Show Conjectures :name: Show Conjectures diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 89668a2d7e..e6bc84365c 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -26,8 +26,8 @@ address a particular goal in the list by writing n:tactic which means “apply tactic tactic to goal number n”. We can show the list of subgoals by typing Show (see Section :ref:`requestinginformation`). -Since not every rule applies to a given statement, every tactic cannot -be used to reduce any goal. In other words, before applying a tactic +Since not every rule applies to a given statement, not every tactic can +be used to reduce a given goal. In other words, before applying a tactic to a given goal, the system checks that some *preconditions* are satisfied. If it is not the case, the tactic raises an error message. @@ -107,10 +107,10 @@ bindings_list`` where ``bindings_list`` may be of two different forms: .. _occurencessets: -Occurrences sets and occurrences clauses +Occurrence sets and occurrence clauses ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -An occurrences clause is a modifier to some tactics that obeys the +An occurrence clause is a modifier to some tactics that obeys the following syntax: .. _tactic_occurence_grammar: @@ -137,7 +137,7 @@ negates the condition so that the clause denotes all the occurrences except the ones explicitly mentioned after the minus sign. As an exception to the left-to-right order, the occurrences in -thereturn subexpression of a match are considered *before* the +the return subexpression of a match are considered *before* the occurrences in the matched term. In the second case, the ``*`` on the left of ``|-`` means that all occurrences @@ -151,7 +151,7 @@ no numbers are given, all occurrences of :n:`@term` in the goal are selected. Finally, the last notation is an abbreviation for ``* |- *``. Note also that ``|-`` is optional in the first case when no ``*`` is given. -Here are some tactics that understand occurrences clauses: :tacn:`set`, :tacn:`remember` +Here are some tactics that understand occurrence clauses: :tacn:`set`, :tacn:`remember` , :tacn:`induction`, :tacn:`destruct`. @@ -281,7 +281,7 @@ Applying theorems :g:`t`:sub:`n` in the goal. See :tacn:`pattern` to transform the goal so that it gets the form :g:`(fun x => Q) u`:sub:`1` :g:`...` :g:`u`:sub:`n`. - .. exn:: Unable to unify ... with ... . + .. exn:: Unable to unify @term with @term. The apply tactic failed to match the conclusion of :token:`term` and the current goal. You can help the apply tactic by transforming your goal with @@ -466,7 +466,7 @@ Applying theorems the tuple is (recursively) decomposed and the first component of the tuple of which a non-dependent premise matches the conclusion of the type of :n:`@ident`. Tuples are decomposed in a width-first left-to-right order (for - instance if the type of :g:`H1` is a :g:`A <-> B` statement, and the type of + instance if the type of :g:`H1` is :g:`A <-> B` and the type of :g:`H2` is :g:`A` then ``apply H1 in H2`` transforms the type of :g:`H2` into :g:`B`). The tactic ``apply`` relies on first-order pattern-matching with dependent types. @@ -846,7 +846,7 @@ quantification or an implication. :n:`intros {+ p}` is not equivalent to :n:`intros p; ... ; intros p` for the following reason: If one of the :n:`p` is a wildcard pattern, it might succeed in the first case because the further hypotheses it - depends in are eventually erased too while it might fail in the second + depends on are eventually erased too while it might fail in the second case because of dependencies in hypotheses which are not yet introduced (and a fortiori not yet erased). @@ -1040,7 +1040,7 @@ The name of the hypothesis in the proof-term, however, is left unchanged. .. tacv:: remember @term as @ident in @goal_occurrences This is a more general form of :n:`remember` that remembers the occurrences - of term specified by an occurrences set. + of term specified by an occurrence set. .. tacv:: eremember @term as @ident .. tacv:: eremember @term as @ident in @goal_occurrences @@ -1523,7 +1523,7 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) .. tacv:: case_eq @term - The tactic :n:`case_eq` is a variant of the :n:`case` tactic that allow to + The tactic :n:`case_eq` is a variant of the :n:`case` tactic that allows to perform case analysis on a term without completely forgetting its original form. This is done by generating equalities between the original form of the term and the outcomes of the case analysis. @@ -1806,7 +1806,7 @@ and an explanation of the underlying technique. following the definition of a function. It makes use of a principle generated by ``Function`` (see :ref:`advanced-recursive-functions`) or ``Functional Scheme`` (see :ref:`functional-scheme`). - Note that this tactic is only available after a + Note that this tactic is only available after a ``Require Import FunInd``. .. example:: .. coqtop:: reset all @@ -1825,7 +1825,7 @@ and an explanation of the underlying technique. arguments explicitly. .. note:: - Parentheses over :n:`@qualid {+ @term}` are mandatory. + Parentheses around :n:`@qualid {+ @term}` are not mandatory and can be skipped. .. note:: :n:`functional induction (f x1 x2 x3)` is actually a wrapper for @@ -2237,7 +2237,7 @@ See also: :ref:`advanced-recursive-functions` To prove the goal, we may need to reason by cases on H and to derive that m is necessarily of the form (S m 0 ) for certain m 0 and that - (Le n m 0 ). Deriving these conditions corresponds to prove that the + (Le n m 0 ). Deriving these conditions corresponds to proving that the only possible constructor of (Le (S n) m) isLeS and that we can invert the-> in the type of LeS. This inversion is possible because Le is the smallest set closed by the constructors LeO and LeS. @@ -2598,7 +2598,7 @@ simply :g:`t=u` dropping the implicit type of :g:`t` and :g:`u`. Adds :n:`@term` to the database used by :tacn:`stepl`. - The tactic is especially useful for parametric setoids which are not accepted + This tactic is especially useful for parametric setoids which are not accepted as regular setoids for :tacn:`rewrite` and :tacn:`setoid_replace` (see :ref:`Generalizedrewriting`). @@ -2708,7 +2708,7 @@ the conversion in hypotheses :n:`{+ @ident}`. Normalization according to the flags is done by first evaluating the head of the expression into a *weak-head* normal form, i.e. until the - evaluation is bloked by a variable (or an opaque constant, or an + evaluation is blocked by a variable (or an opaque constant, or an axiom), as e.g. in :g:`x u1 ... un` , or :g:`match x with ... end`, or :g:`(fix f x {struct x} := ...) x`, or is a constructed form (a :math:`\lambda`-expression, a constructor, a cofixpoint, an inductive type, a @@ -2804,14 +2804,18 @@ the conversion in hypotheses :n:`{+ @ident}`. This tactic applies to a goal that has the form:: - forall (x:T1) ... (xk:Tk), t + forall (x:T1) ... (xk:Tk), T - with :g:`t` :math:`\beta`:math:`\iota`:math:`\zeta`-reducing to :g:`c t`:sub:`1` :g:`... t`:sub:`n` and :g:`c` a + with :g:`T` :math:`\beta`:math:`\iota`:math:`\zeta`-reducing to :g:`c t`:sub:`1` :g:`... t`:sub:`n` and :g:`c` a constant. If :g:`c` is transparent then it replaces :g:`c` with its definition (say :g:`t`) and then reduces :g:`(t t`:sub:`1` :g:`... t`:sub:`n` :g:`)` according to :math:`\beta`:math:`\iota`:math:`\zeta`-reduction rules. .. exn:: Not reducible. + :undocumented: + +.. exn:: No head constant to reduce. + :undocumented: .. tacn:: hnf :name: hnf @@ -2821,8 +2825,7 @@ the conversion in hypotheses :n:`{+ @ident}`. reduces the head of the goal until it becomes a product or an irreducible term. All inner :math:`\beta`:math:`\iota`-redexes are also reduced. - Example: The term :g:`forall n:nat, (plus (S n) (S n))` is not reduced by - :n:`hnf`. + Example: The term :g:`fun n : nat => S n + S n` is not reduced by :n:`hnf`. .. note:: The :math:`\delta` rule only applies to transparent constants (see :ref:`vernac-controlling-the-reduction-strategies` @@ -2862,7 +2865,7 @@ the conversion in hypotheses :n:`{+ @ident}`. + A constant can be marked to be unfolded only if applied to enough arguments. The number of arguments required can be specified using the - ``/`` symbol in the arguments list of the ``Arguments`` vernacular command. + ``/`` symbol in the argument list of the :cmd:`Arguments` vernacular command. .. example:: .. coqtop:: all @@ -3030,7 +3033,7 @@ the conversion in hypotheses :n:`{+ @ident}`. For instance, if the current goal :g:`T` is expressible as :math:`\varphi`:g:`(t)` where the notation captures all the instances of :g:`t` in :math:`\varphi`:g:`(t)`, then :n:`pattern t` transforms it into - :g:`(fun x:A =>` :math:`\varphi`:g:`(x)) t`. This command can be used, for + :g:`(fun x:A =>` :math:`\varphi`:g:`(x)) t`. This tactic can be used, for instance, when the tactic ``apply`` fails on matching. .. tacv:: pattern @term at {+ @num} @@ -3072,10 +3075,10 @@ Conversion tactics applied to hypotheses listed in this section. If :n:`@ident` is a local definition, then :n:`@ident` can be replaced by - (Type of :n:`@ident`) to address not the body but the type of the local + (type of :n:`@ident`) to address not the body but the type of the local definition. - Example: :n:`unfold not in (Type of H1) (Type of H3)`. + Example: :n:`unfold not in (type of H1) (type of H3)`. .. exn:: No such hypothesis: @ident. @@ -3216,10 +3219,10 @@ in the given databases. .. tacn:: autorewrite with {+ @ident} :name: autorewrite -This tactic [4]_ carries out rewritings according the rewriting rule +This tactic [4]_ carries out rewritings according to the rewriting rule bases :n:`{+ @ident}`. -Each rewriting rule of a base :n:`@ident` is applied to the main subgoal until +Each rewriting rule from the base :n:`@ident` is applied to the main subgoal until it fails. Once all the rules have been processed, if the main subgoal has progressed (e.g., if it is distinct from the initial main goal) then the rules of this base are processed again. If the main subgoal has not progressed then @@ -3312,7 +3315,7 @@ automatically created. (c.f. :ref:`The hints databases for auto and eauto <thehintsdatabasesforautoandeauto>`), making the retrieval more efficient. The legacy implementation (the default one for new databases) uses the DT only on goals without existentials (i.e., :tacn:`auto` - goals), for non-Immediate hints and do not make use of transparency + goals), for non-Immediate hints and does not make use of transparency hints, putting more work on the unification that is run after retrieval (it keeps a list of the lemmas in case the DT is not used). The new implementation enabled by the discriminated option makes use @@ -3496,7 +3499,7 @@ The general command to add a hint to some databases :n:`{+ @ident}` is The `emp` regexp does not match any search path while `eps` matches the empty path. During proof search, the path of successive successful hints on a search branch is recorded, as a - list of identifiers for the hints (note Hint Extern’s do not have + list of identifiers for the hints (note that Hint Extern’s do not have an associated identifier). Before applying any hint :n:`@ident` the current path `p` extended with :n:`@ident` is matched against the current cut expression `c` associated to @@ -3535,15 +3538,14 @@ Hint databases defined in the Coq standard library ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Several hint databases are defined in the Coq standard library. The -actual content of a database is the collection of the hints declared +actual content of a database is the collection of hints declared to belong to this database in each of the various modules currently -loaded. Especially, requiring new modules potentially extend a -database. At Coq startup, only the core database is non empty and can -be used. +loaded. Especially, requiring new modules may extend the database. +At Coq startup, only the core database is nonempty and can be used. :core: This special database is automatically used by ``auto``, except when pseudo-database ``nocore`` is given to ``auto``. The core database - contains only basic lemmas about negation, conjunction, and so on from. + contains only basic lemmas about negation, conjunction, and so on. Most of the hints in this database come from the Init and Logic directories. :arith: This database contains all lemmas about Peano’s arithmetic proved in the @@ -3655,7 +3657,7 @@ but this is a mere workaround and has some limitations (for instance, external hints cannot be removed). A proper way to fix this issue is to bind the hints to their module scope, as -for most of the other objects Coq uses. Hints should only made available when +for most of the other objects Coq uses. Hints should only be made available when the module they are defined in is imported, not just required. It is very difficult to change the historical behavior, as it would break a lot of scripts. We propose a smooth transitional path by providing the :opt:`Loose Hint Behavior` @@ -3774,9 +3776,9 @@ Therefore, the use of :tacn:`intros` in the previous proof is unnecessary. :name: dtauto While :tacn:`tauto` recognizes inductively defined connectives isomorphic to - the standard connective ``and, prod, or, sum, False, Empty_set, unit, True``, - :tacn:`dtauto` recognizes also all inductive types with one constructors and - no indices, i.e. record-style connectives. + the standard connectives ``and``, ``prod``, ``or``, ``sum``, ``False``, + ``Empty_set``, ``unit``, ``True``, :tacn:`dtauto` also recognizes all inductive + types with one constructor and no indices, i.e. record-style connectives. .. tacn:: intuition @tactic :name: intuition @@ -3792,7 +3794,7 @@ For instance, the tactic :g:`intuition auto` applied to the goal :: - (forall (x:nat), P x)/\B -> (forall (y:nat),P y)/\ P O \/B/\ P O + (forall (x:nat), P x) /\ B -> (forall (y:nat), P y) /\ P O \/ B /\ P O internally replaces it by the equivalent one: @@ -3819,9 +3821,9 @@ some incompatibilities. :name: dintuition While :tacn:`intuition` recognizes inductively defined connectives - isomorphic to the standard connective ``and``, ``prod``, ``or``, ``sum``, ``False``, - ``Empty_set``, ``unit``, ``True``, :tacn:`dintuition` recognizes also all inductive - types with one constructors and no indices, i.e. record-style connectives. + isomorphic to the standard connectives ``and``, ``prod``, ``or``, ``sum``, ``False``, + ``Empty_set``, ``unit``, ``True``, :tacn:`dintuition` also recognizes all inductive + types with one constructor and no indices, i.e. record-style connectives. .. opt:: Intuition Negation Unfolding @@ -3836,11 +3838,12 @@ The :tacn:`rtauto` tactic solves propositional tautologies similarly to what reflection scheme applied to a sequent calculus proof of the goal. The search procedure is also implemented using a different technique. -Users should be aware that this difference may result in faster proof- search +Users should be aware that this difference may result in faster proof-search but slower proof-checking, and :tacn:`rtauto` might not solve goals that :tacn:`tauto` would be able to solve (e.g. goals involving universal quantifiers). +Note that this tactic is only available after a ``Require Import Rtauto``. .. tacn:: firstorder :name: firstorder @@ -3887,7 +3890,7 @@ inductive definition. The tactic :tacn:`congruence`, by Pierre Corbineau, implements the standard Nelson and Oppen congruence closure algorithm, which is a decision procedure -for ground equalities with uninterpreted symbols. It also include the +for ground equalities with uninterpreted symbols. It also includes constructor theory (see :tacn:`injection` and :tacn:`discriminate`). If the goal is a non-quantified equality, congruence tries to prove it with non-quantified equalities in the context. Otherwise it tries to infer a discriminable equality @@ -3895,8 +3898,8 @@ from those in the context. Alternatively, congruence tries to prove that a hypothesis is equal to the goal or to the negation of another hypothesis. :tacn:`congruence` is also able to take advantage of hypotheses stating -quantified equalities, you have to provide a bound for the number of extra -equalities generated that way. Please note that one of the members of the +quantified equalities, but you have to provide a bound for the number of extra +equalities generated that way. Please note that one of the sides of the equality must contain all the quantified variables in order for congruence to match against it. @@ -3932,7 +3935,7 @@ match against it. discriminable equality but this proof could not be built in Coq because of dependently-typed functions. -.. exn:: Goal is solvable by congruence but some arguments are missing. Try congruence with ..., replacing metavariables by arbitrary terms. +.. exn:: Goal is solvable by congruence but some arguments are missing. Try congruence with {+ @term}, replacing metavariables by arbitrary terms. The decision procedure could solve the goal with the provision that additional arguments are supplied for some partially applied constructors. Any term of an @@ -4071,10 +4074,10 @@ symbol :g:`=`. .. tacn:: decide equality :name: decide equality - This tactic solves a goal of the form :g:`forall x y:R, {x=y}+{ ~x=y}`, + This tactic solves a goal of the form :g:`forall x y : R, {x = y} + {~ x = y}`, where :g:`R` is an inductive type such that its constructors do not take proofs or functions as arguments, nor objects in dependent types. It - solves goals of the form :g:`{x=y}+{ ~x=y}` as well. + solves goals of the form :g:`{x = y} + {~ x = y}` as well. .. tacn:: compare @term @term :name: compare @@ -4214,9 +4217,9 @@ using the ``Require Import`` command. Use ``classical_right`` to prove the right part of the disjunction with the assumption that the negation of left part holds. -.. _tactics-automatizing: +.. _tactics-automating: -Automatizing +Automating ------------ @@ -4245,6 +4248,12 @@ constructed over the following grammar: Internally, it uses a system very similar to the one of the ring tactic. + Note that this tactic is only available after a ``Require Import Btauto``. + +.. exn:: Cannot recognize a boolean equality. + + The goal is not of the form :g:`t = u`. Especially note that :tacn:`btauto` + doesn't introduce variables into the context on its own. .. tacn:: omega :name: omega @@ -4270,7 +4279,7 @@ distributivity, constant propagation) and comparing syntactically the results. :n:`ring_simplify` applies the normalization procedure described above to -the terms given. The tactic then replaces all occurrences of the terms +the given terms. The tactic then replaces all occurrences of the terms given in the conclusion of the goal by their normal forms. If no term is given, then the conclusion should be an equation and both hand sides are normalized. @@ -4319,21 +4328,6 @@ printed with the Print Fields command. See also: file plugins/setoid_ring/RealField.v for an example of instantiation, theory theories/Reals for many examples of use of field. -.. tacn:: fourier - :name: fourier - -This tactic written by Loïc Pottier solves linear inequalities on real -numbers using Fourier’s method :cite:`Fourier`. This tactic must be loaded by -``Require Import Fourier``. - -.. example:: - .. coqtop:: reset all - - Require Import Reals. - Require Import Fourier. - Goal forall x y:R, (x < y)%R -> (y + 1 >= x - 1)%R. - intros; fourier. - Non-logical tactics ------------------------ diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index c37233734b..0a517973c2 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -1097,7 +1097,7 @@ described first. The scope of :cmd:`Opaque` is limited to the current section, or current file, unless the variant :cmd:`Global Opaque` is used. - See also: sections :ref:`performingcomputations`, :ref:`tactics-automatizing`, + See also: sections :ref:`performingcomputations`, :ref:`tactics-automating`, :ref:`proof-editing-mode` .. exn:: The reference @qualid was not found in the current environment. @@ -1131,7 +1131,7 @@ described first. There is no constant referred by :n:`@qualid` in the environment. See also: sections :ref:`performingcomputations`, - :ref:`tactics-automatizing`, :ref:`proof-editing-mode` + :ref:`tactics-automating`, :ref:`proof-editing-mode` .. _vernac-strategy: @@ -1217,19 +1217,19 @@ scope of their effect. There are four kinds of commands: current section or module it occurs in. As an example, the :cmd:`Coercion` and :cmd:`Strategy` commands belong to this category. + Commands whose default behavior is to stop their effect at the end - of the section they occur in but to extent their effect outside the module or + of the section they occur in but to extend their effect outside the module or library file they occur in. For these commands, the Local modifier limits the effect of the command to the current module if the command does not occur in a section and the Global modifier extends the effect outside the current sections and current module if the command occurs in a section. As an example, the :cmd:`Arguments`, :cmd:`Ltac` or :cmd:`Notation` commands belong to this category. Notice that a subclass of these commands do not support - extension of their scope outside sections at all and the Global is not + extension of their scope outside sections at all and the Global modifier is not applicable to them. + Commands whose default behavior is to stop their effect at the end of the section or module they occur in. For these commands, the ``Global`` modifier extends their effect outside the sections and modules they - occurs in. The :cmd:`Transparent` and :cmd:`Opaque` + occur in. The :cmd:`Transparent` and :cmd:`Opaque` (see Section :ref:`vernac-controlling-the-reduction-strategies`) commands belong to this category. + Commands whose default behavior is to extend their effect outside diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index 8c09b23a5a..f448248468 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -498,6 +498,9 @@ through the <tt>Require Import</tt> command.</p> <dd> theories/Strings/Ascii.v theories/Strings/String.v + theories/Strings/BinaryString.v + theories/Strings/HexString.v + theories/Strings/OctalString.v </dd> <dt> <b>Reals</b>: diff --git a/engine/eConstr.ml b/engine/eConstr.ml index 005ef16351..3dc1933a14 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -565,9 +565,8 @@ let compare_head_gen_proj env sigma equ eqs eqc' nargs m n = | App (f, args), Proj (p, c) -> (match kind_upto sigma f with | Const (p', u) when Constant.equal (Projection.constant p) p' -> - let pb = Environ.lookup_projection p env in - let npars = pb.Declarations.proj_npars in - if Array.length args == npars + 1 then + let npars = Projection.npars p in + if Array.length args == npars + 1 then eqc' 0 c args.(npars) else false | _ -> false) diff --git a/engine/evar_kinds.ml b/engine/evar_kinds.ml index 12e2fda8e2..ea1e572548 100644 --- a/engine/evar_kinds.ml +++ b/engine/evar_kinds.ml @@ -21,12 +21,27 @@ type matching_var_kind = FirstOrderPatVar of Id.t | SecondOrderPatVar of Id.t type subevar_kind = Domain | Codomain | Body +(* maybe this should be a Projection.t *) +type record_field = { fieldname : Constant.t; recordname : Names.inductive } + +type question_mark = { + qm_obligation: obligation_definition_status; + qm_name: Name.t; + qm_record_field: record_field option; +} + +let default_question_mark = { + qm_obligation=Define true; + qm_name=Anonymous; + qm_record_field=None; +} + type t = | ImplicitArg of GlobRef.t * (int * Id.t option) * bool (** Force inference *) | BinderType of Name.t | NamedHole of Id.t (* coming from some ?[id] syntax *) - | QuestionMark of obligation_definition_status * Name.t + | QuestionMark of question_mark | CasesType of bool (* true = a subterm of the type *) | InternalHole | TomatchTypeParameter of inductive * int diff --git a/engine/evar_kinds.mli b/engine/evar_kinds.mli new file mode 100644 index 0000000000..4facdb2005 --- /dev/null +++ b/engine/evar_kinds.mli @@ -0,0 +1,51 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names + +(** The kinds of existential variable *) + +(** Should the obligation be defined (opaque or transparent (default)) or + defined transparent and expanded in the term? *) + +type obligation_definition_status = Define of bool | Expand + +type matching_var_kind = FirstOrderPatVar of Id.t | SecondOrderPatVar of Id.t + +type subevar_kind = Domain | Codomain | Body + +(* maybe this should be a Projection.t *) +(* Represents missing record field *) +type record_field = { fieldname : Constant.t; recordname : Names.inductive } + +type question_mark = { + qm_obligation: obligation_definition_status; + qm_name: Name.t; + (* Tracks if the evar represents a missing record field *) + qm_record_field: record_field option; +} + +(* Default value of question_mark which is used most often *) +val default_question_mark : question_mark + +type t = + | ImplicitArg of GlobRef.t * (int * Id.t option) + * bool (** Force inference *) + | BinderType of Name.t + | NamedHole of Id.t (* coming from some ?[id] syntax *) + | QuestionMark of question_mark + | CasesType of bool (* true = a subterm of the type *) + | InternalHole + | TomatchTypeParameter of inductive * int + | GoalEvar + | ImpossibleCase + | MatchingVar of matching_var_kind + | VarInstance of Id.t + | SubEvar of subevar_kind option * Evar.t diff --git a/engine/proofview.ml b/engine/proofview.ml index b4afb6415e..12d31e5f46 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -754,7 +754,7 @@ let mark_in_evm ~goal evd content = - GoalEvar (morally not dependent) - VarInstance (morally dependent of some name). This is a heuristic for naming these evars. *) - | loc, (Evar_kinds.QuestionMark (_,Names.Name id) | + | loc, (Evar_kinds.QuestionMark { Evar_kinds.qm_name=Names.Name id} | Evar_kinds.ImplicitArg (_,(_,Some id),_)) -> loc, Evar_kinds.VarInstance id | _, (Evar_kinds.VarInstance _ | Evar_kinds.GoalEvar) as x -> x | loc,_ -> loc,Evar_kinds.GoalEvar } diff --git a/engine/termops.ml b/engine/termops.ml index 2b179c43b6..e4c8ae66bc 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -114,7 +114,7 @@ let pr_evar_suggested_name evk sigma = | None -> match evi.evar_source with | _,Evar_kinds.ImplicitArg (c,(n,Some id),b) -> id | _,Evar_kinds.VarInstance id -> id - | _,Evar_kinds.QuestionMark (_,Name id) -> id + | _,Evar_kinds.QuestionMark {Evar_kinds.qm_name = Name id} -> id | _,Evar_kinds.GoalEvar -> Id.of_string "Goal" | _ -> let env = reset_with_named_context evi.evar_hyps (Global.env()) in diff --git a/grammar/q_util.mli b/grammar/q_util.mli index 323a12357d..f3af318b60 100644 --- a/grammar/q_util.mli +++ b/grammar/q_util.mli @@ -48,3 +48,5 @@ val mlexpr_of_prod_entry_key : (string -> MLast.expr) -> user_symbol -> MLast.ex val type_of_user_symbol : user_symbol -> argument_type val parse_user_entry : string -> string -> user_symbol + +val mlexpr_of_symbol : user_symbol -> MLast.expr diff --git a/grammar/q_util.mlp b/grammar/q_util.mlp index 0b8d7fda7a..0e2bf55d86 100644 --- a/grammar/q_util.mlp +++ b/grammar/q_util.mlp @@ -128,3 +128,17 @@ let rec parse_user_entry s sep = let s = match s with "hyp" -> "var" | _ -> s in check_separator sep; Uentry s + +let rec mlexpr_of_symbol = function +| Ulist1 s -> <:expr< Extend.TUlist1 $mlexpr_of_symbol s$ >> +| Ulist1sep (s,sep) -> <:expr< Extend.TUlist1sep $mlexpr_of_symbol s$ $str:sep$ >> +| Ulist0 s -> <:expr< Extend.TUlist0 $mlexpr_of_symbol s$ >> +| Ulist0sep (s,sep) -> <:expr< Extend.TUlist0sep $mlexpr_of_symbol s$ $str:sep$ >> +| Uopt s -> <:expr< Extend.TUopt $mlexpr_of_symbol s$ >> +| Uentry e -> + let wit = <:expr< $lid:"wit_"^e$ >> in + <:expr< Extend.TUentry (Genarg.get_arg_tag $wit$) >> +| Uentryl (e, l) -> + assert (e = "tactic"); + let wit = <:expr< $lid:"wit_"^e$ >> in + <:expr< Extend.TUentryl (Genarg.get_arg_tag $wit$) $mlexpr_of_int l$>> diff --git a/grammar/tacextend.mlp b/grammar/tacextend.mlp index 02da61ef77..07239e7af0 100644 --- a/grammar/tacextend.mlp +++ b/grammar/tacextend.mlp @@ -15,20 +15,6 @@ open Argextend let plugin_name = <:expr< __coq_plugin_name >> -let rec mlexpr_of_symbol = function -| Ulist1 s -> <:expr< Extend.TUlist1 $mlexpr_of_symbol s$ >> -| Ulist1sep (s,sep) -> <:expr< Extend.TUlist1sep $mlexpr_of_symbol s$ $str:sep$ >> -| Ulist0 s -> <:expr< Extend.TUlist0 $mlexpr_of_symbol s$ >> -| Ulist0sep (s,sep) -> <:expr< Extend.TUlist0sep $mlexpr_of_symbol s$ $str:sep$ >> -| Uopt s -> <:expr< Extend.TUopt $mlexpr_of_symbol s$ >> -| Uentry e -> - let wit = <:expr< $lid:"wit_"^e$ >> in - <:expr< Extend.TUentry (Genarg.get_arg_tag $wit$) >> -| Uentryl (e, l) -> - assert (e = "tactic"); - let wit = <:expr< $lid:"wit_"^e$ >> in - <:expr< Extend.TUentryl (Genarg.get_arg_tag $wit$) $mlexpr_of_int l$>> - let rec mlexpr_of_clause = function | [] -> <:expr< TyNil >> | ExtTerminal s :: cl -> <:expr< TyIdent($str:s$, $mlexpr_of_clause cl$) >> diff --git a/grammar/vernacextend.mlp b/grammar/vernacextend.mlp index a2872d07f6..f30c96a7f5 100644 --- a/grammar/vernacextend.mlp +++ b/grammar/vernacextend.mlp @@ -14,134 +14,42 @@ open Q_util open Argextend type rule = { - r_head : string option; - (** The first terminal grammar token *) r_patt : extend_token list; (** The remaining tokens of the parsing rule *) r_class : MLast.expr option; (** An optional classifier for the STM *) r_branch : MLast.expr; (** The action performed by this rule. *) - r_depr : unit option; + r_depr : bool; (** Whether this entry is deprecated *) } -(** Quotation difference for match clauses *) - -let default_patt loc = - (<:patt< _ >>, ploc_vala None, <:expr< failwith "Extension: cannot occur" >>) - -let make_fun loc cl = - let l = cl @ [default_patt loc] in - MLast.ExFun (loc, ploc_vala l) (* correspond to <:expr< fun [ $list:l$ ] >> *) - -let rec make_patt = function - | [] -> <:patt< [] >> - | ExtNonTerminal (_, Some p) :: l -> - <:patt< [ $lid:p$ :: $make_patt l$ ] >> - | _::l -> make_patt l - -let rec make_let e = function - | [] -> e - | ExtNonTerminal (g, Some p) :: l -> - let t = type_of_user_symbol g in - let loc = MLast.loc_of_expr e in - let e = make_let e l in - <:expr< let $lid:p$ = Genarg.out_gen $make_rawwit loc t$ $lid:p$ in $e$ >> - | _::l -> make_let e l - -let make_clause { r_patt = pt; r_branch = e; } = - (make_patt pt, - ploc_vala None, - make_let e pt) - -(* To avoid warnings *) -let mk_ignore c pt = - let fold accu = function - | ExtNonTerminal (_, Some p) -> p :: accu - | _ -> accu - in - let names = List.fold_left fold [] pt in - let fold accu id = <:expr< let _ = $lid:id$ in $accu$ >> in - let names = List.fold_left fold <:expr< () >> names in - <:expr< do { let _ = $names$ in $c$ } >> - -let make_clause_classifier cg s { r_patt = pt; r_class = c; } = - match c ,cg with - | Some c, _ -> - (make_patt pt, - ploc_vala None, - make_let (mk_ignore c pt) pt) - | None, Some cg -> - (make_patt pt, - ploc_vala None, - <:expr< fun loc -> $cg$ $str:s$ >>) - | None, None -> prerr_endline - (("Vernac entry \""^s^"\" misses a classifier. "^ - "A classifier is a function that returns an expression "^ - "of type vernac_classification (see Vernacexpr). You can: ") ^ - "- " ^ ( - ("Use '... EXTEND "^s^" CLASSIFIED AS QUERY ...' if the "^ - "new vernacular command does not alter the system state;"))^ "\n" ^ - "- " ^ ( - ("Use '... EXTEND "^s^" CLASSIFIED AS SIDEFF ...' if the "^ - "new vernacular command alters the system state but not the "^ - "parser nor it starts a proof or ends one;"))^ "\n" ^ - "- " ^ ( - ("Use '... EXTEND "^s^" CLASSIFIED BY f ...' to specify "^ - "a global function f. The function f will be called passing "^ - "\""^s^"\" as the only argument;")) ^ "\n" ^ - "- " ^ ( - "Add a specific classifier in each clause using the syntax:" - ^ "\n" ^("'[...] => [ f ] -> [...]'. "))^ "\n" ^ - ("Specific classifiers have precedence over global "^ - "classifiers. Only one classifier is called.") ^ "\n"); - (make_patt pt, - ploc_vala None, - <:expr< fun () -> ( CErrors.anomaly (Pp.str "No classification given for command " ^ s ) ) >>) - -let make_fun_clauses loc s l = - let map c = - let depr = match c.r_depr with - | None -> false - | Some () -> true - in - let cl = make_fun loc [make_clause c] in - <:expr< ($mlexpr_of_bool depr$, $cl$)>> - in - mlexpr_of_list map l - -let make_fun_classifiers loc s c l = - let cl = List.map (fun x -> make_fun loc [make_clause_classifier c s x]) l in - mlexpr_of_list (fun x -> x) cl - -let make_prod_item = function - | ExtTerminal s -> <:expr< Egramml.GramTerminal $str:s$ >> - | ExtNonTerminal (g, ido) -> - let nt = type_of_user_symbol g in - let base s = <:expr< Pcoq.genarg_grammar ($mk_extraarg loc s$) >> in - let typ = match ido with None -> None | Some _ -> Some nt in - <:expr< Egramml.GramNonTerminal ( Loc.tag ( $mlexpr_of_option (make_rawwit loc) typ$ , - $mlexpr_of_prod_entry_key base g$ ) ) >> - -let mlexpr_of_clause cl = - let mkexpr { r_head = a; r_patt = b; } = match a with - | None -> mlexpr_of_list make_prod_item b - | Some a -> mlexpr_of_list make_prod_item (ExtTerminal a :: b) - in - mlexpr_of_list mkexpr cl +let rec make_patt r = function +| [] -> r +| ExtNonTerminal (_, Some p) :: l -> <:expr< fun $lid:p$ -> $make_patt r l$ >> +| ExtNonTerminal (_, None) :: l -> <:expr< fun _ -> $make_patt r l$ >> +| ExtTerminal _ :: l -> make_patt r l + +let rec mlexpr_of_clause = function +| [] -> <:expr< Vernacentries.TyNil >> +| ExtTerminal s :: cl -> <:expr< Vernacentries.TyTerminal ($str:s$, $mlexpr_of_clause cl$) >> +| ExtNonTerminal (g, id) :: cl -> + let id = mlexpr_of_option mlexpr_of_string id in + <:expr< Vernacentries.TyNonTerminal ($id$, $mlexpr_of_symbol g$, $mlexpr_of_clause cl$) >> + +let make_rule r = + let ty = mlexpr_of_clause r.r_patt in + let cmd = make_patt r.r_branch r.r_patt in + let make_classifier c = make_patt c r.r_patt in + let classif = mlexpr_of_option make_classifier r.r_class in + <:expr< Vernacentries.TyML ($mlexpr_of_bool r.r_depr$, $ty$, $cmd$, $classif$) >> let declare_command loc s c nt cl = let se = mlexpr_of_string s in - let gl = mlexpr_of_clause cl in - let funcl = make_fun_clauses loc s cl in - let classl = make_fun_classifiers loc s c cl in + let c = mlexpr_of_option (fun x -> x) c in + let rules = mlexpr_of_list make_rule cl in declare_str_items loc - [ <:str_item< do { - CList.iteri (fun i (depr, f) -> Vernacinterp.vinterp_add depr ($se$, i) f) $funcl$; - CList.iteri (fun i f -> Vernac_classifier.declare_vernac_classifier ($se$, i) f) $classl$; - CList.iteri (fun i r -> Egramml.extend_vernac_command_grammar ($se$, i) $nt$ r) $gl$; - } >> ] + [ <:str_item< Vernacentries.vernac_extend ?{ classifier = $c$ } ~{ command = $se$ } ?{ entry = $nt$ } $rules$ >> ] open Pcaml @@ -176,38 +84,25 @@ EXTEND ] ] ; deprecation: - [ [ "DEPRECATED" -> () ] ] + [ [ -> false | "DEPRECATED" -> true ] ] ; - (* spiwack: comment-by-guessing: it seems that the isolated string - (which otherwise could have been another argument) is not passed - to the VernacExtend interpreter function to discriminate between - the clauses. *) rule: - [ [ "["; s = STRING; l = LIST0 args; "]"; - d = OPT deprecation; c = OPT classifier; "->"; "["; e = Pcaml.expr; "]" -> - let () = if s = "" then failwith "Command name is empty." in - let b = <:expr< fun ~{atts} ~{st} -> ( let () = $e$ in st ) >> in - { r_head = Some s; r_patt = l; r_class = c; r_branch = b; r_depr = d; } - | "[" ; "-" ; l = LIST1 args ; "]" ; - d = OPT deprecation; c = OPT classifier; "->"; "["; e = Pcaml.expr; "]" -> + [ [ "["; OPT "-"; l = LIST1 args; "]"; + d = deprecation; c = OPT classifier; "->"; "["; e = Pcaml.expr; "]" -> let b = <:expr< fun ~{atts} ~{st} -> ( let () = $e$ in st ) >> in - { r_head = None; r_patt = l; r_class = c; r_branch = b; r_depr = d; } + { r_patt = l; r_class = c; r_branch = b; r_depr = d; } ] ] ; + (** The [OPT "-"] argument serves no purpose nowadays, it is left here for + backward compatibility. *) fun_rule: - [ [ "["; s = STRING; l = LIST0 args; "]"; - d = OPT deprecation; c = OPT classifier; "->"; "["; e = Pcaml.expr; "]" -> - let () = if s = "" then failwith "Command name is empty." in - let b = <:expr< $e$ >> in - { r_head = Some s; r_patt = l; r_class = c; r_branch = b; r_depr = d; } - | "[" ; "-" ; l = LIST1 args ; "]" ; - d = OPT deprecation; c = OPT classifier; "->"; "["; e = Pcaml.expr; "]" -> - let b = <:expr< $e$ >> in - { r_head = None; r_patt = l; r_class = c; r_branch = b; r_depr = d; } + [ [ "["; OPT "-"; l = LIST1 args; "]"; + d = deprecation; c = OPT classifier; "->"; "["; e = Pcaml.expr; "]" -> + { r_patt = l; r_class = c; r_branch = e; r_depr = d; } ] ] ; classifier: - [ [ "=>"; "["; c = Pcaml.expr; "]" -> <:expr< fun loc -> $c$>> ] ] + [ [ "=>"; "["; c = Pcaml.expr; "]" -> <:expr< $c$>> ] ] ; args: [ [ e = LIDENT; "("; s = LIDENT; ")" -> diff --git a/ide/.merlin b/ide/.merlin.in index 953b5dce4c..953b5dce4c 100644 --- a/ide/.merlin +++ b/ide/.merlin.in diff --git a/ide/MacOS/default_accel_map b/ide/MacOS/default_accel_map index 47612cdf72..54a592a04d 100644 --- a/ide/MacOS/default_accel_map +++ b/ide/MacOS/default_accel_map @@ -217,7 +217,6 @@ ; (gtk_accel_path "<Actions>/Tactics/Tactic casetype" "") ; (gtk_accel_path "<Actions>/Tactics/Tactic cbv in" "") ; (gtk_accel_path "<Actions>/Templates/Template Load" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic fourier" "") ; (gtk_accel_path "<Actions>/Templates/Template Goal" "") ; (gtk_accel_path "<Actions>/Tactics/Tactic exists" "") ; (gtk_accel_path "<Actions>/Tactics/Tactic decompose record" "") diff --git a/ide/coq.ml b/ide/coq.ml index 63986935aa..e948360191 100644 --- a/ide/coq.ml +++ b/ide/coq.ml @@ -530,20 +530,31 @@ let break_coqtop coqtop workers = module PrintOpt = struct - type t = string list + type _ t = + | BoolOpt : string list -> bool t + | StringOpt : string list -> string t + + let opt_name (type a) : a t -> string list = function + | BoolOpt l -> l + | StringOpt l -> l + + let opt_data (type a) (key : a t) (v : a) = match key with + | BoolOpt l -> Interface.BoolValue v + | StringOpt l -> Interface.StringValue v (* Boolean options *) - let implicit = ["Printing"; "Implicit"] - let coercions = ["Printing"; "Coercions"] - let raw_matching = ["Printing"; "Matching"] - let notations = ["Printing"; "Notations"] - let all_basic = ["Printing"; "All"] - let existential = ["Printing"; "Existential"; "Instances"] - let universes = ["Printing"; "Universes"] - let unfocused = ["Printing"; "Unfocused"] + let implicit = BoolOpt ["Printing"; "Implicit"] + let coercions = BoolOpt ["Printing"; "Coercions"] + let raw_matching = BoolOpt ["Printing"; "Matching"] + let notations = BoolOpt ["Printing"; "Notations"] + let all_basic = BoolOpt ["Printing"; "All"] + let existential = BoolOpt ["Printing"; "Existential"; "Instances"] + let universes = BoolOpt ["Printing"; "Universes"] + let unfocused = BoolOpt ["Printing"; "Unfocused"] + let diff = StringOpt ["Diffs"] - type bool_descr = { opts : t list; init : bool; label : string } + type 'a descr = { opts : 'a t list; init : 'a; label : string } let bool_items = [ { opts = [implicit]; init = false; label = "Display _implicit arguments" }; @@ -561,24 +572,32 @@ struct { opts = [unfocused]; init = false; label = "Display _unfocused goals" } ] + let diff_item = { opts = [diff]; init = "off"; label = "Display _proof diffs" } + (** The current status of the boolean options *) let current_state = Hashtbl.create 11 - let set opt v = Hashtbl.replace current_state opt v + let set (type a) (opt : a t) (v : a) = + Hashtbl.replace current_state (opt_name opt) (opt_data opt v) let reset () = let init_descr d = List.iter (fun o -> set o d.init) d.opts in - List.iter init_descr bool_items + List.iter init_descr bool_items; + List.iter (fun o -> set o diff_item.init) diff_item.opts let _ = reset () - let printing_unfocused () = Hashtbl.find current_state unfocused + let printing_unfocused () = + let BoolOpt unfocused = unfocused in + match Hashtbl.find current_state unfocused with + | Interface.BoolValue b -> b + | _ -> assert false (** Transmitting options to coqtop *) let enforce h k = - let mkopt o v acc = (o, Interface.BoolValue v) :: acc in + let mkopt o v acc = (o, v) :: acc in let opts = Hashtbl.fold mkopt current_state [] in eval_call (Xmlprotocol.set_options opts) h (function diff --git a/ide/coq.mli b/ide/coq.mli index 40a6dea8d3..3af0aa697e 100644 --- a/ide/coq.mli +++ b/ide/coq.mli @@ -134,13 +134,15 @@ val stop_worker: Interface.stop_worker_sty-> Interface.stop_worker_rty query module PrintOpt : sig - type t (** Representation of an option *) + type 'a t (** Representation of an option *) - type bool_descr = { opts : t list; init : bool; label : string } + type 'a descr = { opts : 'a t list; init : 'a; label : string } - val bool_items : bool_descr list + val bool_items : bool descr list - val set : t -> bool -> unit + val diff_item : string descr + + val set : 'a t -> 'a -> unit val printing_unfocused: unit -> bool diff --git a/ide/coq_commands.ml b/ide/coq_commands.ml index f5dba2085a..b0bafb7930 100644 --- a/ide/coq_commands.ml +++ b/ide/coq_commands.ml @@ -311,7 +311,6 @@ let tactics = "fix __ with"; "fold"; "fold __ in"; - "fourier"; "functional induction"; ]; diff --git a/ide/coqide.ml b/ide/coqide.ml index aa816f2b8b..09a82ba91e 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -826,6 +826,7 @@ let refresh_notebook_pos () = let menu = GAction.add_actions let item = GAction.add_action +let radio = GAction.add_radio_action (** Toggle items in menus for printing options *) @@ -1043,7 +1044,19 @@ let build_ui () = ~callback:(fun _ -> show_toolbar#set (not show_toolbar#get)); item "Query Pane" ~label:"_Query Pane" ~accel:"F1" - ~callback:(cb_on_current_term MiscMenu.show_hide_query_pane) + ~callback:(cb_on_current_term MiscMenu.show_hide_query_pane); + GAction.group_radio_actions + ~callback:begin function + | 0 -> List.iter (fun o -> Opt.set o "off") Opt.diff_item.Opt.opts + | 1 -> List.iter (fun o -> Opt.set o "on") Opt.diff_item.Opt.opts + | 2 -> List.iter (fun o -> Opt.set o "removed") Opt.diff_item.Opt.opts + | _ -> assert false + end + [ + radio "Unset diff" 0 ~label:"Unset _Diff"; + radio "Set diff" 1 ~label:"Set Di_ff"; + radio "Set removed diff" 2 ~label:"Set _Removed Diff"; + ]; ]; toggle_items view_menu Coq.PrintOpt.bool_items; @@ -1106,15 +1119,15 @@ let build_ui () = ]; alpha_items templates_menu "Template" Coq_commands.commands; - let qitem s sc ?(dots = true) = - let query = if dots then s ^ "..." else s in + let qitem s sc = + let query = s ^ "..." in item s ~label:("_"^s) ~accel:(modifier_for_queries#get^sc) ~callback:(Query.query query) in menu queries_menu [ item "Queries" ~label:"_Queries"; - qitem "Search" "K" ~dots:false; + qitem "Search" "K"; qitem "Check" "C"; qitem "Print" "P"; qitem "About" "A"; diff --git a/ide/coqide_ui.ml b/ide/coqide_ui.ml index 717c4000f5..91c529932f 100644 --- a/ide/coqide_ui.ml +++ b/ide/coqide_ui.ml @@ -86,6 +86,10 @@ let init () = \n <menuitem action='Display universe levels' />\ \n <menuitem action='Display all low-level contents' />\ \n <menuitem action='Display unfocused goals' />\ +\n <separator/>\ +\n <menuitem action='Unset diff' />\ +\n <menuitem action='Set diff' />\ +\n <menuitem action='Set removed diff' />\ \n </menu>\ \n <menu action='Navigation'>\ \n <menuitem action='Forward' />\ diff --git a/ide/gtk_parsing.ml b/ide/gtk_parsing.ml index 9f5c992444..d554bebdd3 100644 --- a/ide/gtk_parsing.ml +++ b/ide/gtk_parsing.ml @@ -35,8 +35,11 @@ let find_word_start (it:GText.iter) = (Minilib.log "find_word_start: cannot backward"; it) else if is_word_char it#char then step_to_start it - else (it#nocopy#forward_char; - Minilib.log ("Word start at: "^(string_of_int it#offset));it) + else begin + ignore(it#nocopy#forward_char); + Minilib.log ("Word start at: "^(string_of_int it#offset)); + it + end in step_to_start it#copy diff --git a/ide/idetop.ml b/ide/idetop.ml index 0c3328ee08..854b1abe31 100644 --- a/ide/idetop.ml +++ b/ide/idetop.ml @@ -202,13 +202,30 @@ let export_pre_goals pgs = Interface.given_up_goals = pgs.Proof.given_up_goals } +let add_diffs oldp newp intf = + let open Interface in + let (hyps_pp_list, concl_pp) = Proof_diffs.diff_first_goal oldp newp in + match intf.fg_goals with + | [] -> intf + | first_goal :: tl -> + { intf with fg_goals = { first_goal with goal_hyp = hyps_pp_list; goal_ccl = concl_pp } :: tl } + let goals () = + let oldp = + try Some (Proof_global.give_me_the_proof ()) + with Proof_global.NoCurrentProof -> None in let doc = get_doc () in set_doc @@ Stm.finish ~doc; try - let pfts = Proof_global.give_me_the_proof () in - Some (export_pre_goals (Proof.map_structured_proof pfts process_goal)) - with Proof_global.NoCurrentProof -> None + let newp = Proof_global.give_me_the_proof () in + let intf = export_pre_goals (Proof.map_structured_proof newp process_goal) in + if Proof_diffs.show_diffs () then + try + Some (add_diffs oldp (Some newp) intf) + with Pp_diff.Diff_Failure _ -> Some intf + else + Some intf + with Proof_global.NoCurrentProof -> None;; let evars () = try diff --git a/ide/ideutils.ml b/ide/ideutils.ml index e96b992999..960beb8455 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -37,6 +37,11 @@ let flash_info = let flash_context = status#new_context ~name:"Flash" in (fun ?(delay=5000) s -> flash_context#flash ~delay s) +(* Note: Setting the same attribute with two separate tags appears to use +the first value applied and not the second. I saw this trying to set the background +color on Windows. A clean fix, if ever needed, would be to combine the attributes +of the tags into a single composite tag before applying. This is left as an +exercise for the reader. *) let insert_with_tags (buf : #GText.buffer_skel) mark rmark tags text = (** FIXME: LablGTK2 does not export the C insert_with_tags function, so that it has to reimplement its own helper function. Unluckily, it relies on @@ -50,21 +55,51 @@ let insert_with_tags (buf : #GText.buffer_skel) mark rmark tags text = let start = buf#get_iter_at_mark mark in let stop = buf#get_iter_at_mark rmark in let iter tag = buf#apply_tag tag ~start ~stop in - List.iter iter tags + List.iter iter (List.rev tags) + +let nl_white_regex = Str.regexp "^\\( *\n *\\)" +let diff_regex = Str.regexp "^diff." let insert_xml ?(mark = `INSERT) ?(tags = []) (buf : #GText.buffer_skel) msg = let open Xml_datatype in + let dtags = ref [] in let tag name = match GtkText.TagTable.lookup buf#tag_table name with | None -> raise Not_found | Some tag -> new GText.tag tag in let rmark = `MARK (buf#create_mark buf#start_iter) in + (* insert the string, but don't apply diff highlights to white space at the begin/end of line *) + let rec insert_str tags s = + try + let _ = Str.search_forward nl_white_regex s 0 in + insert_with_tags buf mark rmark tags (Str.matched_group 1 s); + let mend = Str.match_end () in + insert_str tags (String.sub s mend (String.length s - mend)) + with Not_found -> begin + let etags = try List.hd !dtags :: tags with hd -> tags in + insert_with_tags buf mark rmark etags s + end + in let rec insert tags = function - | PCData s -> insert_with_tags buf mark rmark tags s + | PCData s -> insert_str tags s | Element (t, _, children) -> - let tags = try tag t :: tags with Not_found -> tags in - List.iter (fun xml -> insert tags xml) children + let (pfx, tname) = Pp.split_tag t in + let is_diff = try let _ = Str.search_forward diff_regex tname 0 in true with Not_found -> false in + let (tags, have_tag) = + try + let t = tag tname in + if is_diff && pfx <> Pp.end_pfx then + dtags := t :: !dtags; + if pfx = "" then + ((if is_diff then tags else t :: tags), true) + else + (tags, true) + with Not_found -> (tags, false) + in + List.iter (fun xml -> insert tags xml) children; + if have_tag && is_diff && pfx <> Pp.start_pfx then + dtags := (try List.tl !dtags with tl -> []); in let () = try insert tags msg with _ -> () in buf#delete_mark rmark diff --git a/ide/preferences.ml b/ide/preferences.ml index 11aaf6e8cc..526d94a939 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -25,6 +25,7 @@ type tag = { tag_bold : bool; tag_italic : bool; tag_underline : bool; + tag_strikethrough : bool; } (** Generic preferences *) @@ -215,15 +216,17 @@ object string_of_bool tag.tag_bold; string_of_bool tag.tag_italic; string_of_bool tag.tag_underline; + string_of_bool tag.tag_strikethrough; ] method into = function - | [fg; bg; bd; it; ul] -> + | [fg; bg; bd; it; ul; st] -> (try Some { tag_fg_color = _to fg; tag_bg_color = _to bg; tag_bold = bool_of_string bd; tag_italic = bool_of_string it; tag_underline = bool_of_string ul; + tag_strikethrough = bool_of_string st; } with _ -> None) | _ -> None @@ -429,12 +432,13 @@ let tags = ref Util.String.Map.empty let list_tags () = !tags -let make_tag ?fg ?bg ?(bold = false) ?(italic = false) ?(underline = false) () = { +let make_tag ?fg ?bg ?(bold = false) ?(italic = false) ?(underline = false) ?(strikethrough = false) () = { tag_fg_color = fg; tag_bg_color = bg; tag_bold = bold; tag_italic = italic; tag_underline = underline; + tag_strikethrough = strikethrough; } let create_tag name default = @@ -470,6 +474,12 @@ let create_tag name default = tag#set_property (`UNDERLINE_SET true); tag#set_property (`UNDERLINE `SINGLE) end; + begin match pref#get.tag_strikethrough with + | false -> tag#set_property (`STRIKETHROUGH_SET false) + | true -> + tag#set_property (`STRIKETHROUGH_SET true); + tag#set_property (`STRIKETHROUGH true) + end; in let iter table = let tag = GText.tag ~name () in @@ -480,6 +490,8 @@ let create_tag name default = List.iter iter [Tags.Script.table; Tags.Proof.table; Tags.Message.table]; tags := Util.String.Map.add name pref !tags +(* note these appear to only set the defaults; they don't override +the user selection from the Edit/Preferences/Tags dialog *) let () = let iter (name, tag) = create_tag name tag in List.iter iter [ @@ -498,6 +510,10 @@ let () = ("tactic.keyword", make_tag ()); ("tactic.primitive", make_tag ()); ("tactic.string", make_tag ()); + ("diff.added", make_tag ~bg:"#b6f1c0" ~underline:true ()); + ("diff.removed", make_tag ~bg:"#f6b9c1" ~strikethrough:true ()); + ("diff.added.bg", make_tag ~bg:"#e9feee" ()); + ("diff.removed.bg", make_tag ~bg:"#fce9eb" ()); ] let processed_color = @@ -561,6 +577,7 @@ object (self) val bold = GButton.toggle_button () val italic = GButton.toggle_button () val underline = GButton.toggle_button () + val strikethrough = GButton.toggle_button () method set_tag tag = let track c but set = match c with @@ -574,6 +591,7 @@ object (self) bold#set_active tag.tag_bold; italic#set_active tag.tag_italic; underline#set_active tag.tag_underline; + strikethrough#set_active tag.tag_strikethrough; method tag = let get but set = @@ -586,6 +604,7 @@ object (self) tag_bold = bold#active; tag_italic = italic#active; tag_underline = underline#active; + tag_strikethrough = strikethrough#active; } initializer @@ -599,6 +618,7 @@ object (self) set_stock bold `BOLD; set_stock italic `ITALIC; set_stock underline `UNDERLINE; + set_stock strikethrough `STRIKETHROUGH; box#pack fg_color#coerce; box#pack fg_unset#coerce; box#pack bg_color#coerce; @@ -606,6 +626,7 @@ object (self) box#pack bold#coerce; box#pack italic#coerce; box#pack underline#coerce; + box#pack strikethrough#coerce; let cb but obj = obj#set_sensitive (not but#active) in let _ = fg_unset#connect#toggled ~callback:(fun () -> cb fg_unset fg_color#misc) in let _ = bg_unset#connect#toggled ~callback:(fun () -> cb bg_unset bg_color#misc) in diff --git a/ide/preferences.mli b/ide/preferences.mli index ccf028aee4..f3882d486d 100644 --- a/ide/preferences.mli +++ b/ide/preferences.mli @@ -21,6 +21,7 @@ type tag = { tag_bold : bool; tag_italic : bool; tag_underline : bool; + tag_strikethrough : bool; } class type ['a] repr = diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 18d6c1a5b7..715823e5d0 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -552,7 +552,7 @@ let find_fresh_name renaming (terms,termlists,binders,binderlists) avoid id = let is_var store pat = match DAst.get pat with - | PatVar na -> store na; true + | PatVar na -> ignore(store na); true | _ -> false let out_var pat = @@ -566,7 +566,7 @@ let term_of_name = function | Name id -> DAst.make (GVar id) | Anonymous -> let st = Evar_kinds.Define (not (Program.get_proofs_transparency ())) in - DAst.make (GHole (Evar_kinds.QuestionMark (st,Anonymous), IntroAnonymous, None)) + DAst.make (GHole (Evar_kinds.QuestionMark { Evar_kinds.default_question_mark with Evar_kinds.qm_obligation=st }, IntroAnonymous, None)) let traverse_binder intern_pat ntnvars (terms,_,binders,_ as subst) avoid (renaming,env) = function | Anonymous -> (renaming,env), None, Anonymous @@ -1370,7 +1370,8 @@ let sort_fields ~complete loc fields completer = (* the order does not matter as we sort them next, List.rev_* is just for efficiency *) let remaining_fields = - let complete_field (idx, _field_ref) = (idx, completer idx) in + let complete_field (idx, field_ref) = (idx, + completer idx field_ref record.Recordops.s_CONST) in List.rev_map complete_field remaining_projs in List.rev_append remaining_fields acc in @@ -1524,7 +1525,7 @@ let drop_notations_pattern looked_for genv = | CPatAlias (p, id) -> DAst.make ?loc @@ RCPatAlias (in_pat top scopes p, id) | CPatRecord l -> let sorted_fields = - sort_fields ~complete:false loc l (fun _idx -> CAst.make ?loc @@ CPatAtom None) in + sort_fields ~complete:false loc l (fun _idx fieldname constructor -> CAst.make ?loc @@ CPatAtom None) in begin match sorted_fields with | None -> DAst.make ?loc @@ RCPatAtom None | Some (n, head, pl) -> @@ -1890,9 +1891,9 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = intern_applied_reference intern env (Environ.named_context globalenv) lvar us args ref in - (* Rem: GApp(_,f,[]) stands for @f *) - DAst.make ?loc @@ - GApp (f, intern_args env args_scopes (List.map fst args)) + (* Rem: GApp(_,f,[]) stands for @f *) + if args = [] then DAst.make ?loc @@ GApp (f,[]) else + smart_gapp f loc (intern_args env args_scopes (List.map fst args)) | CApp ((isproj,f), args) -> let f,args = match f.CAst.v with @@ -1918,8 +1919,16 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let st = Evar_kinds.Define (not (Program.get_proofs_transparency ())) in let fields = sort_fields ~complete:true loc fs - (fun _idx -> CAst.make ?loc @@ CHole (Some (Evar_kinds.QuestionMark (st,Anonymous)), - IntroAnonymous, None)) + (fun _idx fieldname constructorname -> + let open Evar_kinds in + let fieldinfo : Evar_kinds.record_field = + {fieldname=fieldname; recordname=inductive_of_constructor constructorname} + in + CAst.make ?loc @@ CHole (Some + (Evar_kinds.QuestionMark { Evar_kinds.default_question_mark with + Evar_kinds.qm_obligation=st; + Evar_kinds.qm_record_field=Some fieldinfo + }) , IntroAnonymous, None)) in begin match fields with @@ -2002,7 +2011,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let st = Evar_kinds.Define (not (Program.get_proofs_transparency ())) in (match naming with | IntroIdentifier id -> Evar_kinds.NamedHole id - | _ -> Evar_kinds.QuestionMark (st,Anonymous)) + | _ -> Evar_kinds.QuestionMark { Evar_kinds.default_question_mark with Evar_kinds.qm_obligation=st; }) | Some k -> k in let solve = match solve with @@ -2050,6 +2059,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = | CProj (pr, c) -> match intern_reference pr with | ConstRef p -> + let p = Option.get @@ Recordops.find_primitive_projection p in DAst.make ?loc @@ GProj (Projection.make p false, intern env c) | _ -> raise (InternalizationError (loc,IllegalMetavariable)) (* FIXME *) diff --git a/interp/declare.ml b/interp/declare.ml index fcb62ac8c4..532339c03c 100644 --- a/interp/declare.ml +++ b/interp/declare.ml @@ -382,40 +382,44 @@ let inInductive : inductive_obj -> obj = discharge_function = discharge_inductive; rebuild_function = infer_inductive_subtyping } +let declare_one_projection univs (mind,_ as ind) ~proj_npars proj_arg label (term,types) = + let id = Label.to_id label in + let p = Projection.Repr.make ind ~proj_npars ~proj_arg label in + Recordops.declare_primitive_projection p; + (* ^ needs to happen before declaring the constant, otherwise + Heads gets confused. *) + let univs = match univs with + | Monomorphic_ind_entry _ -> + (** Global constraints already defined through the inductive *) + Monomorphic_const_entry Univ.ContextSet.empty + | Polymorphic_ind_entry ctx -> + Polymorphic_const_entry ctx + | Cumulative_ind_entry ctx -> + Polymorphic_const_entry (Univ.CumulativityInfo.univ_context ctx) + in + let term, types = match univs with + | Monomorphic_const_entry _ -> term, types + | Polymorphic_const_entry ctx -> + let u = Univ.UContext.instance ctx in + Vars.subst_instance_constr u term, Vars.subst_instance_constr u types + in + let entry = definition_entry ~types ~univs term in + ignore(declare_constant id (DefinitionEntry entry, IsDefinition StructureComponent)) + let declare_projections univs mind = let env = Global.env () in let mib = Environ.lookup_mind mind env in match mib.mind_record with | PrimRecord info -> - let iter i (_, kns, _) = - let mind = (mind, i) in - let projs = Inductiveops.compute_projections env mind in - Array.iter2 (fun kn (term, types) -> - let id = Label.to_id (Constant.label kn) in - let univs = match univs with - | Monomorphic_ind_entry _ -> - (** Global constraints already defined through the inductive *) - Monomorphic_const_entry Univ.ContextSet.empty - | Polymorphic_ind_entry ctx -> - Polymorphic_const_entry ctx - | Cumulative_ind_entry ctx -> - Polymorphic_const_entry (Univ.CumulativityInfo.univ_context ctx) - in - let term, types = match univs with - | Monomorphic_const_entry _ -> term, types - | Polymorphic_const_entry ctx -> - let u = Univ.UContext.instance ctx in - Vars.subst_instance_constr u term, Vars.subst_instance_constr u types - in - let entry = definition_entry ~types ~univs term in - let kn' = declare_constant id (DefinitionEntry entry, IsDefinition StructureComponent) in - assert (Constant.equal kn kn') - ) kns projs + let iter_ind i (_, labs, _) = + let ind = (mind, i) in + let projs = Inductiveops.compute_projections env ind in + Array.iter2_i (declare_one_projection univs ind ~proj_npars:mib.mind_nparams) labs projs in - let () = Array.iteri iter info in - true, true - | FakeRecord -> true, false - | NotRecord -> false, false + let () = Array.iteri iter_ind info in + true + | FakeRecord -> false + | NotRecord -> false (* for initial declaration *) let declare_mind mie = @@ -424,7 +428,7 @@ let declare_mind mie = | [] -> anomaly (Pp.str "cannot declare an empty list of inductives.") in let (sp,kn as oname) = add_leaf id (inInductive ([],mie)) in let mind = Global.mind_of_delta_kn kn in - let isrecord,isprim = declare_projections mie.mind_entry_universes mind in + let isprim = declare_projections mie.mind_entry_universes mind in declare_mib_implicits mind; declare_inductive_argument_scopes mind mie; oname, isprim @@ -593,27 +597,8 @@ let do_universe poly l = ignore(Lib.add_leaf id (input_universe (src, lev)))) l -type constraint_decl = polymorphic * Univ.Constraint.t - -let cache_constraints (na, (p, c)) = - let ctx = - Univ.ContextSet.add_constraints c - Univ.ContextSet.empty (* No declared universes here, just constraints *) - in cache_universe_context (p,ctx) - -let discharge_constraints (_, (p, c as a)) = - if p then None else Some a - -let input_constraints : constraint_decl -> Libobject.obj = - let open Libobject in - declare_object - { (default_object "Global universe constraints") with - cache_function = cache_constraints; - load_function = (fun _ -> cache_constraints); - discharge_function = discharge_constraints; - classify_function = (fun a -> Keep a) } - let do_constraint poly l = + let open Univ in let u_of_id x = let level = Pretyping.interp_known_glob_level (Evd.from_env (Global.env ())) x in UnivNames.is_polymorphic level, level @@ -635,7 +620,8 @@ let do_constraint poly l = let constraints = List.fold_left (fun acc (l, d, r) -> let p, lu = u_of_id l and p', ru = u_of_id r in check_poly p p'; - Univ.Constraint.add (lu, d, ru) acc) - Univ.Constraint.empty l + Constraint.add (lu, d, ru) acc) + Constraint.empty l in - Lib.add_anonymous_leaf (input_constraints (poly, constraints)) + let uctx = ContextSet.add_constraints constraints ContextSet.empty in + declare_universe_context poly uctx diff --git a/interp/impargs.ml b/interp/impargs.ml index 8aa1e62504..e542b818f6 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -689,8 +689,8 @@ let check_rigidity isrigid = user_err (strbrk "Multiple sequences of implicit arguments available only for references that cannot be applied to an arbitrarily large number of arguments.") let projection_implicits env p impls = - let pb = Environ.lookup_projection p env in - CList.skipn_at_least pb.Declarations.proj_npars impls + let npars = Projection.npars p in + CList.skipn_at_least npars impls let declare_manual_implicits local ref ?enriching l = let flags = !implicit_args in diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index ab0bf9c6fe..7cde563cd2 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -641,11 +641,9 @@ let rec subst_notation_constr subst bound raw = if r1' == r1 && k' == k then raw else NCast(r1',k') | NProj (p, c) -> - let kn = Projection.constant p in - let b = Projection.unfolded p in - let kn' = subst_constant subst kn in + let p' = subst_proj subst p in let c' = subst_notation_constr subst bound c in - if kn' == kn && c' == c then raw else NProj(Projection.make kn' b, c') + if p' == p && c' == c then raw else NProj(p', c') let subst_interpretation subst (metas,pat) = diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index 61ed40394e..ac4c6c52c6 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -397,7 +397,7 @@ let update v1 no t = type stack_member = | Zapp of fconstr array | ZcaseT of case_info * constr * constr array * fconstr subs - | Zproj of int * int * Constant.t + | Zproj of Projection.Repr.t | Zfix of fconstr * stack | Zshift of int | Zupdate of fconstr @@ -691,8 +691,8 @@ let rec zip m stk = | ZcaseT(ci,p,br,e)::s -> let t = FCaseT(ci, p, m, br, e) in zip {norm=neutr m.norm; term=t} s - | Zproj (i,j,cst) :: s -> - zip {norm=neutr m.norm; term=FProj(Projection.make cst true,m)} s + | Zproj p :: s -> + zip {norm=neutr m.norm; term=FProj(Projection.make p true,m)} s | Zfix(fx,par)::s -> zip fx (par @ append_stack [|m|] s) | Zshift(n)::s -> @@ -822,21 +822,24 @@ let drop_parameters depth n argstk = let eta_expand_ind_stack env ind m s (f, s') = let open Declarations in let mib = lookup_mind (fst ind) env in - match mib.Declarations.mind_record with - | PrimRecord infos when - mib.Declarations.mind_finite == Declarations.BiFinite -> - let (_, projs, _) = infos.(snd ind) in - (* (Construct, pars1 .. parsm :: arg1...argn :: []) ~= (f, s') -> + (* disallow eta-exp for non-primitive records *) + if not (mib.mind_finite == BiFinite) then raise Not_found; + match Declareops.inductive_make_projections ind mib with + | Some projs -> + (* (Construct, pars1 .. parsm :: arg1...argn :: []) ~= (f, s') -> arg1..argn ~= (proj1 t...projn t) where t = zip (f,s') *) - let pars = mib.Declarations.mind_nparams in - let right = fapp_stack (f, s') in - let (depth, args, s) = strip_update_shift_app m s in - (** Try to drop the params, might fail on partially applied constructors. *) - let argss = try_drop_parameters depth pars args in - let hstack = Array.map (fun p -> { norm = Red; (* right can't be a constructor though *) - term = FProj (Projection.make p true, right) }) projs in - argss, [Zapp hstack] - | PrimRecord _ | NotRecord | FakeRecord -> raise Not_found (* disallow eta-exp for non-primitive records *) + let pars = mib.Declarations.mind_nparams in + let right = fapp_stack (f, s') in + let (depth, args, s) = strip_update_shift_app m s in + (** Try to drop the params, might fail on partially applied constructors. *) + let argss = try_drop_parameters depth pars args in + let hstack = Array.map (fun p -> + { norm = Red; (* right can't be a constructor though *) + term = FProj (Projection.make p true, right) }) + projs + in + argss, [Zapp hstack] + | None -> raise Not_found (* disallow eta-exp for non-primitive records *) let rec project_nth_arg n argstk = match argstk with @@ -875,9 +878,7 @@ let contract_fix_vect fix = let unfold_projection info p = if red_projection info.i_flags p then - let open Declarations in - let pb = lookup_projection p (info_env info) in - Some (Zproj (pb.proj_npars, pb.proj_arg, Projection.constant p)) + Some (Zproj (Projection.repr p)) else None (*********************************************************************) @@ -958,9 +959,9 @@ let rec knr info tab m stk = let stk' = par @ append_stack [|rarg|] s in let (fxe,fxbd) = contract_fix_vect fx.term in knit info tab fxe fxbd stk' - | (depth, args, Zproj (n, m, cst)::s) when use_match -> - let rargs = drop_parameters depth n args in - let rarg = project_nth_arg m rargs in + | (depth, args, Zproj p::s) when use_match -> + let rargs = drop_parameters depth (Projection.Repr.npars p) args in + let rarg = project_nth_arg (Projection.Repr.arg p) rargs in kni info tab rarg s | (_,args,s) -> (m,args@s)) else (m,stk) @@ -1002,7 +1003,7 @@ let rec zip_term zfun m stk = let t = mkCase(ci, zfun (mk_clos e p), m, Array.map (fun b -> zfun (mk_clos e b)) br) in zip_term zfun t s - | Zproj(_,_,p)::s -> + | Zproj p::s -> let t = mkProj (Projection.make p true, m) in zip_term zfun t s | Zfix(fx,par)::s -> diff --git a/kernel/cClosure.mli b/kernel/cClosure.mli index f8f98f0abe..1e3e7b48ac 100644 --- a/kernel/cClosure.mli +++ b/kernel/cClosure.mli @@ -152,7 +152,7 @@ type fterm = type stack_member = | Zapp of fconstr array | ZcaseT of case_info * constr * constr array * fconstr subs - | Zproj of int * int * Constant.t + | Zproj of Projection.Repr.t | Zfix of fconstr * stack | Zshift of int | Zupdate of fconstr diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml index 3095ce148b..9a1224aab2 100644 --- a/kernel/cbytecodes.ml +++ b/kernel/cbytecodes.ml @@ -128,8 +128,7 @@ type instruction = | Ksetfield of int | Kstop | Ksequence of bytecodes * bytecodes - | Kproj of int * Constant.t (* index of the projected argument, - name of projection *) + | Kproj of Projection.Repr.t | Kensurestackcapacity of int (* spiwack: instructions concerning integers *) | Kbranch of Label.t (* jump to label *) @@ -311,7 +310,7 @@ let rec pp_instr i = | Kbranch lbl -> str "branch " ++ pp_lbl lbl - | Kproj(n,p) -> str "proj " ++ int n ++ str " " ++ Constant.print p + | Kproj p -> str "proj " ++ Projection.Repr.print p | Kensurestackcapacity size -> str "growstack " ++ int size diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli index de21401b31..f17a1e657e 100644 --- a/kernel/cbytecodes.mli +++ b/kernel/cbytecodes.mli @@ -88,8 +88,7 @@ type instruction = | Ksetfield of int (** accu[n] = sp[0] ; sp = pop sp *) | Kstop | Ksequence of bytecodes * bytecodes - | Kproj of int * Constant.t (** index of the projected argument, - name of projection *) + | Kproj of Projection.Repr.t | Kensurestackcapacity of int (** spiwack: instructions concerning integers *) diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index 6677db2fd9..e336ea922d 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -492,8 +492,8 @@ let rec compile_lam env cenv lam sz cont = | Lval v -> compile_structured_constant cenv v sz cont - | Lproj (n,kn,arg) -> - compile_lam env cenv arg sz (Kproj (n,kn) :: cont) + | Lproj (p,arg) -> + compile_lam env cenv arg sz (Kproj p :: cont) | Lvar id -> pos_named id cenv :: cont @@ -501,6 +501,9 @@ let rec compile_lam env cenv lam sz cont = if Array.is_empty args then compile_fv_elem cenv (FVevar evk) sz cont else + (** Arguments are reversed in evar instances *) + let args = Array.copy args in + let () = Array.rev args in comp_app compile_fv_elem (compile_lam env) cenv (FVevar evk) args sz cont | Lconst (kn,u) -> compile_constant env cenv kn u [||] sz cont diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml index 2426255e48..ca24f9b689 100644 --- a/kernel/cemitcodes.ml +++ b/kernel/cemitcodes.ml @@ -27,7 +27,7 @@ type reloc_info = | Reloc_annot of annot_switch | Reloc_const of structured_constant | Reloc_getglobal of Names.Constant.t - | Reloc_proj_name of Constant.t + | Reloc_proj_name of Projection.Repr.t let eq_reloc_info r1 r2 = match r1, r2 with | Reloc_annot sw1, Reloc_annot sw2 -> eq_annot_switch sw1 sw2 @@ -36,7 +36,7 @@ let eq_reloc_info r1 r2 = match r1, r2 with | Reloc_const _, _ -> false | Reloc_getglobal c1, Reloc_getglobal c2 -> Constant.equal c1 c2 | Reloc_getglobal _, _ -> false -| Reloc_proj_name p1, Reloc_proj_name p2 -> Constant.equal p1 p2 +| Reloc_proj_name p1, Reloc_proj_name p2 -> Projection.Repr.equal p1 p2 | Reloc_proj_name _, _ -> false let hash_reloc_info r = @@ -45,7 +45,7 @@ let hash_reloc_info r = | Reloc_annot sw -> combinesmall 1 (hash_annot_switch sw) | Reloc_const c -> combinesmall 2 (hash_structured_constant c) | Reloc_getglobal c -> combinesmall 3 (Constant.hash c) - | Reloc_proj_name p -> combinesmall 4 (Constant.hash p) + | Reloc_proj_name p -> combinesmall 4 (Projection.Repr.hash p) module RelocTable = Hashtbl.Make(struct type t = reloc_info @@ -284,7 +284,7 @@ let emit_instr env = function if n <= 1 then out env (opSETFIELD0+n) else (out env opSETFIELD;out_int env n) | Ksequence _ -> invalid_arg "Cemitcodes.emit_instr" - | Kproj (n,p) -> out env opPROJ; out_int env n; slot_for_proj_name env p + | Kproj p -> out env opPROJ; out_int env (Projection.Repr.arg p); slot_for_proj_name env p | Kensurestackcapacity size -> out env opENSURESTACKCAPACITY; out_int env size (* spiwack *) | Kbranch lbl -> out env opBRANCH; out_label env lbl @@ -371,7 +371,7 @@ let subst_reloc s ri = Reloc_annot {a with ci = ci} | Reloc_const sc -> Reloc_const (subst_strcst s sc) | Reloc_getglobal kn -> Reloc_getglobal (subst_constant s kn) - | Reloc_proj_name p -> Reloc_proj_name (subst_constant s p) + | Reloc_proj_name p -> Reloc_proj_name (subst_proj_repr s p) let subst_patches subst p = let infos = CArray.map (fun (r, pos) -> (subst_reloc subst r, pos)) p.reloc_infos in diff --git a/kernel/cemitcodes.mli b/kernel/cemitcodes.mli index 696721c375..9009926bdb 100644 --- a/kernel/cemitcodes.mli +++ b/kernel/cemitcodes.mli @@ -5,7 +5,7 @@ type reloc_info = | Reloc_annot of annot_switch | Reloc_const of structured_constant | Reloc_getglobal of Constant.t - | Reloc_proj_name of Constant.t + | Reloc_proj_name of Projection.Repr.t type patches type emitcodes diff --git a/kernel/cinstr.mli b/kernel/cinstr.mli index f42c46175c..171ca38830 100644 --- a/kernel/cinstr.mli +++ b/kernel/cinstr.mli @@ -36,7 +36,7 @@ and lambda = | Lval of structured_constant | Lsort of Sorts.t | Lind of pinductive - | Lproj of int * Constant.t * lambda + | Lproj of Projection.Repr.t * lambda | Luint of uint (* Cofixpoints have to be in eta-expanded form for their call-by-need evaluation diff --git a/kernel/clambda.ml b/kernel/clambda.ml index f1b6f3dffc..7c00e40fb0 100644 --- a/kernel/clambda.ml +++ b/kernel/clambda.ml @@ -111,9 +111,9 @@ let rec pp_lam lam = (str "(PRIM " ++ pr_con kn ++ spc() ++ prlist_with_sep spc pp_lam (Array.to_list args) ++ str")") - | Lproj(i,kn,arg) -> + | Lproj(p,arg) -> hov 1 - (str "(proj#" ++ int i ++ spc() ++ pr_con kn ++ str "(" ++ pp_lam arg + (str "(proj " ++ Projection.Repr.print p ++ str "(" ++ pp_lam arg ++ str ")") | Luint _ -> str "(uint)" @@ -205,9 +205,9 @@ let rec map_lam_with_binders g f n lam = | Lprim(kn,ar,op,args) -> let args' = Array.Smart.map (f n) args in if args == args' then lam else Lprim(kn,ar,op,args') - | Lproj(i,kn,arg) -> + | Lproj(p,arg) -> let arg' = f n arg in - if arg == arg' then lam else Lproj(i,kn,arg') + if arg == arg' then lam else Lproj(p,arg') | Luint u -> let u' = map_uint g f n u in if u == u' then lam else Luint u' @@ -376,7 +376,7 @@ let rec occurrence k kind lam = let kind = occurrence_args k kind ltypes in let _ = occurrence_args (k+Array.length ids) false lbodies in kind - | Lproj(_,_,arg) -> + | Lproj(_,arg) -> occurrence k kind arg | Luint u -> occurrence_uint k kind u @@ -708,10 +708,8 @@ let rec lambda_of_constr env c = Lcofix(init, (names, ltypes, lbodies)) | Proj (p,c) -> - let pb = lookup_projection p env.global_env in - let n = pb.proj_arg in let lc = lambda_of_constr env c in - Lproj (n,Projection.constant p,lc) + Lproj (Projection.repr p,lc) and lambda_of_app env f args = match Constr.kind f with diff --git a/kernel/context.ml b/kernel/context.ml index 831dc850fb..4a7204b75c 100644 --- a/kernel/context.ml +++ b/kernel/context.ml @@ -149,6 +149,10 @@ struct | LocalAssum (na, ty) -> na, None, ty | LocalDef (na, v, ty) -> na, Some v, ty + let drop_body = function + | LocalAssum _ as d -> d + | LocalDef (na, v, ty) -> LocalAssum (na, ty) + end (** Rel-context is represented as a list of declarations. @@ -211,6 +215,8 @@ struct | Declaration.LocalAssum _ :: ctx -> aux (false::l) ctx in aux [] l + let drop_bodies l = List.Smart.map Declaration.drop_body l + (** [extended_list n Γ] builds an instance [args] such that [Γ,Δ ⊢ args:Γ] with n = |Δ| and with the {e local definitions} of [Γ] skipped in [args]. Example: for [x:T, y:=c, z:U] and [n]=2, it gives [Rel 5, Rel 3]. *) @@ -348,6 +354,10 @@ struct | id, None, ty -> LocalAssum (id, ty) | id, Some v, ty -> LocalDef (id, v, ty) + let drop_body = function + | LocalAssum _ as d -> d + | LocalDef (id, v, ty) -> LocalAssum (id, ty) + let of_rel_decl f = function | Rel.Declaration.LocalAssum (na,t) -> LocalAssum (f na, t) @@ -403,6 +413,8 @@ struct let to_vars l = List.fold_left (fun accu decl -> Id.Set.add (Declaration.get_id decl) accu) Id.Set.empty l + let drop_bodies l = List.Smart.map Declaration.drop_body l + (** [instance_from_named_context Ω] builds an instance [args] such that [Ω ⊢ args:Ω] where [Ω] is a named context and with the local definitions of [Ω] skipped. Example: for [id1:T,id2:=c,id3:U], it diff --git a/kernel/context.mli b/kernel/context.mli index 957ac4b3d6..2b0d36cb8c 100644 --- a/kernel/context.mli +++ b/kernel/context.mli @@ -85,6 +85,9 @@ sig val fold_constr : ('c -> 'a -> 'a) -> ('c, 'c) pt -> 'a -> 'a val to_tuple : ('c, 't) pt -> Name.t * 'c option * 't + + (** Turn [LocalDef] into [LocalAssum], identity otherwise. *) + val drop_body : ('c, 't) pt -> ('c, 't) pt end (** Rel-context is represented as a list of declarations. @@ -129,6 +132,9 @@ sig and each {e local definition} is mapped to [false]. *) val to_tags : ('c, 't) pt -> bool list + (** Turn all [LocalDef] into [LocalAssum], leave [LocalAssum] unchanged. *) + val drop_bodies : ('c, 't) pt -> ('c, 't) pt + (** [extended_list mk n Γ] builds an instance [args] such that [Γ,Δ ⊢ args:Γ] with n = |Δ| and with the {e local definitions} of [Γ] skipped in [args] where [mk] is used to build the corresponding variables. @@ -202,6 +208,9 @@ sig val to_tuple : ('c, 't) pt -> Id.t * 'c option * 't val of_tuple : Id.t * 'c option * 't -> ('c, 't) pt + (** Turn [LocalDef] into [LocalAssum], identity otherwise. *) + val drop_body : ('c, 't) pt -> ('c, 't) pt + (** Convert [Rel.Declaration.t] value to the corresponding [Named.Declaration.t] value. The function provided as the first parameter determines how to translate "names" to "ids". *) val of_rel_decl : (Name.t -> Id.t) -> ('c, 't) Rel.Declaration.pt -> ('c, 't) pt @@ -249,6 +258,9 @@ sig (** Return the set of all identifiers bound in a given named-context. *) val to_vars : ('c, 't) pt -> Id.Set.t + (** Turn all [LocalDef] into [LocalAssum], leave [LocalAssum] unchanged. *) + val drop_bodies : ('c, 't) pt -> ('c, 't) pt + (** [to_instance Ω] builds an instance [args] such that [Ω ⊢ args:Ω] where [Ω] is a named-context and with the local definitions of [Ω] skipped. Example: for [id1:T,id2:=c,id3:U], it diff --git a/kernel/cooking.ml b/kernel/cooking.ml index 094609b963..c06358054e 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -126,16 +126,13 @@ let expmod_constr cache modlist c = | Not_found -> Constr.map substrec c) | Proj (p, c') -> - (try - (** No need to expand parameters or universes for projections *) - let map cst = - let _ = Cmap.find cst (fst modlist) in - pop_con cst - in - let p = Projection.map map p in - let c' = substrec c' in - mkProj (p, c') - with Not_found -> Constr.map substrec c) + let map cst npars = + let _, newpars = Mindmap.find cst (snd modlist) in + pop_mind cst, npars + Array.length newpars + in + let p' = try Projection.map_npars map p with Not_found -> p in + let c'' = substrec c' in + if p == p' && c' == c'' then c else mkProj (p', c'') | _ -> Constr.map substrec c diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml index bbe0937820..bb9231d000 100644 --- a/kernel/csymtable.ml +++ b/kernel/csymtable.ml @@ -77,11 +77,7 @@ module AnnotTable = Hashtbl.Make (struct let hash = hash_annot_switch end) -module ProjNameTable = Hashtbl.Make (struct - type t = Constant.t - let equal = Constant.equal - let hash = Constant.hash -end) +module ProjNameTable = Hashtbl.Make (Projection.Repr) let str_cst_tbl : int SConstTable.t = SConstTable.create 31 diff --git a/kernel/declarations.ml b/kernel/declarations.ml index 95078800e7..0811eb72fd 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -46,16 +46,6 @@ type inline = int option (** A constant can have no body (axiom/parameter), or a transparent body, or an opaque one *) -(** Projections are a particular kind of constant: - always transparent. *) - -type projection_body = { - proj_ind : inductive; - proj_npars : int; - proj_arg : int; (** Projection index, starting from 0 *) - proj_type : types; (* Type under params *) -} - (* Global declarations (i.e. constants) can be either: *) type constant_def = | Undef of inline (** a global assumption *) @@ -114,7 +104,7 @@ v} If it is a primitive record, for every type in the block, we get: - The identifier for the binder name of the record in primitive projections. - The constants associated to each projection. - - The checked projection bodies. + - The projection types (under parameters). The kernel does not exploit the difference between [NotRecord] and [FakeRecord]. It is mostly used by extraction, and should be extruded from @@ -124,7 +114,7 @@ v} type record_info = | NotRecord | FakeRecord -| PrimRecord of (Id.t * Constant.t array * projection_body array) array +| PrimRecord of (Id.t * Label.t array * types array) array type regular_inductive_arity = { mind_user_arity : types; diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 3e6c4858e0..bbe4bc0dcb 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -83,11 +83,6 @@ let subst_const_def sub def = match def with | Def c -> Def (subst_constr sub c) | OpaqueDef o -> OpaqueDef (Opaqueproof.subst_opaque sub o) -let subst_const_proj sub pb = - { pb with proj_ind = subst_ind sub pb.proj_ind; - proj_type = subst_mps sub pb.proj_type; - } - let subst_const_body sub cb = assert (List.is_empty cb.const_hyps); (* we're outside sections *) if is_empty_subst sub then cb @@ -213,10 +208,9 @@ let subst_mind_record sub r = match r with | FakeRecord -> FakeRecord | PrimRecord infos -> let map (id, ps, pb as info) = - let ps' = Array.Smart.map (subst_constant sub) ps in - let pb' = Array.Smart.map (subst_const_proj sub) pb in - if ps' == ps && pb' == pb then info - else (id, ps', pb') + let pb' = Array.Smart.map (subst_mps sub) pb in + if pb' == pb then info + else (id, ps, pb') in let infos' = Array.Smart.map map infos in if infos' == infos then r else PrimRecord infos' @@ -254,6 +248,25 @@ let inductive_is_cumulative mib = | Polymorphic_ind ctx -> false | Cumulative_ind cumi -> true +let inductive_make_projection ind mib ~proj_arg = + match mib.mind_record with + | NotRecord | FakeRecord -> None + | PrimRecord infos -> + Some (Names.Projection.Repr.make ind + ~proj_npars:mib.mind_nparams + ~proj_arg + (pi2 infos.(snd ind)).(proj_arg)) + +let inductive_make_projections ind mib = + match mib.mind_record with + | NotRecord | FakeRecord -> None + | PrimRecord infos -> + let projs = Array.mapi (fun proj_arg lab -> + Names.Projection.Repr.make ind ~proj_npars:mib.mind_nparams ~proj_arg lab) + (pi2 infos.(snd ind)) + in + Some projs + (** {6 Hash-consing of inductive declarations } *) let hcons_regular_ind_arity a = diff --git a/kernel/declareops.mli b/kernel/declareops.mli index fb46112ea7..f91e69807f 100644 --- a/kernel/declareops.mli +++ b/kernel/declareops.mli @@ -66,6 +66,11 @@ val inductive_is_polymorphic : mutual_inductive_body -> bool (** Is the inductive cumulative? *) val inductive_is_cumulative : mutual_inductive_body -> bool +val inductive_make_projection : Names.inductive -> mutual_inductive_body -> proj_arg:int -> + Names.Projection.Repr.t option +val inductive_make_projections : Names.inductive -> mutual_inductive_body -> + Names.Projection.Repr.t array option + (** {6 Kernel flags} *) (** A default, safe set of flags for kernel type-checking *) diff --git a/kernel/environ.ml b/kernel/environ.ml index 4ab4698031..e7efa5e2c9 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -52,7 +52,6 @@ type mind_key = mutual_inductive_body * link_info ref type globals = { env_constants : constant_key Cmap_env.t; - env_projections : projection_body Cmap_env.t; env_inductives : mind_key Mindmap_env.t; env_modules : module_body MPmap.t; env_modtypes : module_type_body MPmap.t; @@ -110,7 +109,6 @@ let empty_rel_context_val = { let empty_env = { env_globals = { env_constants = Cmap_env.empty; - env_projections = Cmap_env.empty; env_inductives = Mindmap_env.empty; env_modules = MPmap.empty; env_modtypes = MPmap.empty}; @@ -490,11 +488,24 @@ let polymorphic_pconstant (cst,u) env = let type_in_type_constant cst env = not (lookup_constant cst env).const_typing_flags.check_universes -let lookup_projection cst env = - Cmap_env.find (Projection.constant cst) env.env_globals.env_projections - -let is_projection cst env = - Cmap_env.mem cst env.env_globals.env_projections +let lookup_projection p env = + let mind,i = Projection.inductive p in + let mib = lookup_mind mind env in + (if not (Int.equal mib.mind_nparams (Projection.npars p)) + then anomaly ~label:"lookup_projection" Pp.(str "Bad number of parameters on projection.")); + match mib.mind_record with + | NotRecord | FakeRecord -> anomaly ~label:"lookup_projection" Pp.(str "not a projection") + | PrimRecord infos -> + let _,_,typs = infos.(i) in + typs.(Projection.arg p) + +let get_projection env ind ~proj_arg = + let mib = lookup_mind (fst ind) env in + Declareops.inductive_make_projection ind mib ~proj_arg + +let get_projections env ind = + let mib = lookup_mind (fst ind) env in + Declareops.inductive_make_projections ind mib (* Mutual Inductives *) let polymorphic_ind (mind,i) env = @@ -518,17 +529,9 @@ let template_polymorphic_pind (ind,u) env = let add_mind_key kn (mind, _ as mind_key) env = let new_inds = Mindmap_env.add kn mind_key env.env_globals.env_inductives in - let new_projections = match mind.mind_record with - | NotRecord | FakeRecord -> env.env_globals.env_projections - | PrimRecord projs -> - Array.fold_left (fun accu (id, kns, pbs) -> - Array.fold_left2 (fun accu kn pb -> - Cmap_env.add kn pb accu) accu kns pbs) - env.env_globals.env_projections projs - in let new_globals = { env.env_globals with - env_inductives = new_inds; env_projections = new_projections; } in + env_inductives = new_inds; } in { env with env_globals = new_globals } let add_mind kn mib env = diff --git a/kernel/environ.mli b/kernel/environ.mli index 0259dbbdda..f45b7be821 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -217,8 +217,11 @@ val constant_opt_value_in : env -> Constant.t puniverses -> constr option (** {6 Primitive projections} *) -val lookup_projection : Names.Projection.t -> env -> projection_body -val is_projection : Constant.t -> env -> bool +(** Checks that the number of parameters is correct. *) +val lookup_projection : Names.Projection.t -> env -> types + +val get_projection : env -> inductive -> proj_arg:int -> Names.Projection.Repr.t option +val get_projections : env -> inductive -> Names.Projection.Repr.t array option (** {5 Inductive types } *) val lookup_mind_key : MutInd.t -> env -> mind_key diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 5d45c2c1ad..d7eb865e0a 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -796,7 +796,6 @@ let compute_projections (kn, i as ind) mib = let subst = List.init mib.mind_ntypes (fun i -> mkIndU ((kn, mib.mind_ntypes - i - 1), u)) in let rctx, _ = decompose_prod_assum (substl subst pkt.mind_nf_lc.(0)) in let ctx, paramslet = List.chop pkt.mind_consnrealdecls.(0) rctx in - let mp, dp, l = MutInd.repr3 kn in (** We build a substitution smashing the lets in the record parameters so that typechecking projections requires just a substitution and not matching with a parameter context. *) @@ -810,7 +809,7 @@ let compute_projections (kn, i as ind) mib = mkRel 1 :: List.map (lift 1) subst in subst in - let projections decl (i, j, kns, pbs, letsubst) = + let projections decl (i, j, labs, pbs, letsubst) = match decl with | LocalDef (na,c,t) -> (* From [params, field1,..,fieldj |- c(params,field1,..,fieldj)] @@ -822,11 +821,12 @@ let compute_projections (kn, i as ind) mib = (* From [params-wo-let, x:I |- subst:(params, x:I, field1,..,fieldj)] to [params-wo-let, x:I |- subst:(params, x:I, field1,..,fieldj+1)] *) let letsubst = c2 :: letsubst in - (i, j+1, kns, pbs, letsubst) + (i, j+1, labs, pbs, letsubst) | LocalAssum (na,t) -> match na with | Name id -> - let kn = Constant.make1 (KerName.make mp dp (Label.of_id id)) in + let lab = Label.of_id id in + let kn = Projection.Repr.make ind ~proj_npars:mib.mind_nparams ~proj_arg:i lab in (* from [params, field1,..,fieldj |- t(params,field1,..,fieldj)] to [params, x:I, field1,..,fieldj |- t(params,field1,..,fieldj] *) let t = liftn 1 j t in @@ -836,15 +836,13 @@ let compute_projections (kn, i as ind) mib = (* from [params, x:I, field1,..,fieldj |- t(field1,..,fieldj)] to [params, x:I |- t(proj1 x,..,projj x)] *) let fterm = mkProj (Projection.make kn false, mkRel 1) in - let body = { proj_ind = ind; proj_npars = mib.mind_nparams; - proj_arg = i; proj_type = projty; } in - (i + 1, j + 1, kn :: kns, body :: pbs, fterm :: letsubst) + (i + 1, j + 1, lab :: labs, projty :: pbs, fterm :: letsubst) | Anonymous -> raise UndefinableExpansion in - let (_, _, kns, pbs, letsubst) = + let (_, _, labs, pbs, letsubst) = List.fold_right projections ctx (0, 1, [], [], paramsletsubst) in - Array.of_list (List.rev kns), + Array.of_list (List.rev labs), Array.of_list (List.rev pbs) let abstract_inductive_universes iu = @@ -954,8 +952,8 @@ let build_inductive env prv iu env_ar paramsctxt kn isrecord isfinite inds nmr r (** The elimination criterion ensures that all projections can be defined. *) if Array.for_all is_record packets then let map i id = - let kn, projs = compute_projections (kn, i) mib in - (id, kn, projs) + let labs, projs = compute_projections (kn, i) mib in + (id, labs, projs) in try PrimRecord (Array.mapi map rid) with UndefinableExpansion -> FakeRecord diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli index 7c36dac67d..cb09cfa827 100644 --- a/kernel/indtypes.mli +++ b/kernel/indtypes.mli @@ -42,6 +42,3 @@ val check_inductive : env -> MutInd.t -> mutual_inductive_entry -> mutual_induct val enforce_indices_matter : unit -> unit val is_indices_matter : unit -> bool - -val compute_projections : inductive -> - mutual_inductive_body -> (Constant.t array * projection_body array) diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 88b00600e4..4d13a5fcb8 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -798,8 +798,7 @@ let rec subterm_specif renv stack t = (* We take the subterm specs of the constructor of the record *) let wf_args = (dest_subterms wf).(0) in (* We extract the tree of the projected argument *) - let pb = lookup_projection p renv.env in - let n = pb.proj_arg in + let n = Projection.arg p in spec_of_tree (List.nth wf_args n) | Dead_code -> Dead_code | Not_subterm -> Not_subterm) diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index a47af56ca5..b35b9dda31 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -332,6 +332,12 @@ let subst_constant sub con = try fst (subst_con0 sub (con,Univ.Instance.empty)) with No_subst -> con +let subst_proj_repr sub p = + Projection.Repr.map (subst_mind sub) p + +let subst_proj sub p = + Projection.map (subst_mind sub) p + (* Here the semantics is completely unclear. What does "Hint Unfold t" means when "t" is a parameter? Does the user mean "Unfold X.t" or does she mean "Unfold y" @@ -346,11 +352,7 @@ let rec map_kn f f' c = match kind c with | Const kn -> (try snd (f' kn) with No_subst -> c) | Proj (p,t) -> - let p' = - try - Projection.map (fun kn -> fst (f' (kn,Univ.Instance.empty))) p - with No_subst -> p - in + let p' = Projection.map f p in let t' = func t in if p' == p && t' == t then c else mkProj (p', t') diff --git a/kernel/mod_subst.mli b/kernel/mod_subst.mli index 76a1d173b9..2e5211c770 100644 --- a/kernel/mod_subst.mli +++ b/kernel/mod_subst.mli @@ -147,6 +147,9 @@ val subst_con_kn : val subst_constant : substitution -> Constant.t -> Constant.t +val subst_proj_repr : substitution -> Projection.Repr.t -> Projection.Repr.t +val subst_proj : substitution -> Projection.t -> Projection.t + (** Here the semantics is completely unclear. What does "Hint Unfold t" means when "t" is a parameter? Does the user mean "Unfold X.t" or does she mean "Unfold y" diff --git a/kernel/names.ml b/kernel/names.ml index 1d2a7c4ce5..e1d70e8111 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -771,29 +771,141 @@ type module_path = ModPath.t = module Projection = struct - type t = Constant.t * bool + module Repr = struct + type t = + { proj_ind : inductive; + proj_npars : int; + proj_arg : int; + proj_name : Label.t; } + + let make proj_ind ~proj_npars ~proj_arg proj_name = + {proj_ind;proj_npars;proj_arg;proj_name} + + let inductive c = c.proj_ind + + let mind c = fst c.proj_ind + + let constant c = KerPair.change_label (mind c) c.proj_name + + let label c = c.proj_name + + let npars c = c.proj_npars + + let arg c = c.proj_arg + + let equal a b = + eq_ind a.proj_ind b.proj_ind && Int.equal a.proj_arg b.proj_arg + + let hash p = + Hashset.Combine.combinesmall p.proj_arg (ind_hash p.proj_ind) + + module SyntacticOrd = struct + let compare a b = + let c = ind_syntactic_ord a.proj_ind b.proj_ind in + if c == 0 then Int.compare a.proj_arg b.proj_arg + else c + + let equal a b = + a.proj_arg == b.proj_arg && eq_syntactic_ind a.proj_ind b.proj_ind + + let hash p = + Hashset.Combine.combinesmall p.proj_arg (ind_hash p.proj_ind) + end + module CanOrd = struct + let compare a b = + let c = ind_ord a.proj_ind b.proj_ind in + if c == 0 then Int.compare a.proj_arg b.proj_arg + else c + + let equal a b = + a.proj_arg == b.proj_arg && eq_ind a.proj_ind b.proj_ind + + let hash p = + Hashset.Combine.combinesmall p.proj_arg (ind_hash p.proj_ind) + end + module UserOrd = struct + let compare a b = + let c = ind_user_ord a.proj_ind b.proj_ind in + if c == 0 then Int.compare a.proj_arg b.proj_arg + else c + + let equal a b = + a.proj_arg == b.proj_arg && eq_user_ind a.proj_ind b.proj_ind + + let hash p = + Hashset.Combine.combinesmall p.proj_arg (ind_user_hash p.proj_ind) + end + + let compare a b = + let c = ind_ord a.proj_ind b.proj_ind in + if c == 0 then Int.compare a.proj_arg b.proj_arg + else c + + module Self_Hashcons = struct + type nonrec t = t + type u = (inductive -> inductive) * (Id.t -> Id.t) + let hashcons (hind,hid) p = + { proj_ind = hind p.proj_ind; + proj_npars = p.proj_npars; + proj_arg = p.proj_arg; + proj_name = hid p.proj_name } + let eq p p' = + p == p' || (p.proj_ind == p'.proj_ind && p.proj_npars == p'.proj_npars && p.proj_arg == p'.proj_arg && p.proj_name == p'.proj_name) + let hash = hash + end + module HashRepr = Hashcons.Make(Self_Hashcons) + let hcons = Hashcons.simple_hcons HashRepr.generate HashRepr.hcons (hcons_ind,Id.hcons) + + let map_npars f p = + let ind = fst p.proj_ind in + let npars = p.proj_npars in + let ind', npars' = f ind npars in + if ind == ind' && npars == npars' then p + else {p with proj_ind = (ind',snd p.proj_ind); proj_npars = npars'} + + let map f p = map_npars (fun mind n -> f mind, n) p + + let to_string p = Constant.to_string (constant p) + let print p = Constant.print (constant p) + end + + type t = Repr.t * bool let make c b = (c, b) - let constant = fst + let mind (c,_) = Repr.mind c + let inductive (c,_) = Repr.inductive c + let npars (c,_) = Repr.npars c + let arg (c,_) = Repr.arg c + let constant (c,_) = Repr.constant c + let label (c,_) = Repr.label c + let repr = fst let unfolded = snd let unfold (c, b as p) = if b then p else (c, true) - let equal (c, b) (c', b') = Constant.equal c c' && b == b' - let hash (c, b) = (if b then 0 else 1) + Constant.hash c + let equal (c, b) (c', b') = Repr.equal c c' && b == b' + + let hash (c, b) = (if b then 0 else 1) + Repr.hash c module SyntacticOrd = struct let compare (c, b) (c', b') = - if b = b' then Constant.SyntacticOrd.compare c c' else -1 + if b = b' then Repr.SyntacticOrd.compare c c' else -1 + let equal (c, b as x) (c', b' as x') = + x == x' || b = b' && Repr.SyntacticOrd.equal c c' + let hash (c, b) = (if b then 0 else 1) + Repr.SyntacticOrd.hash c + end + module CanOrd = struct + let compare (c, b) (c', b') = + if b = b' then Repr.CanOrd.compare c c' else -1 let equal (c, b as x) (c', b' as x') = - x == x' || b = b' && Constant.SyntacticOrd.equal c c' - let hash (c, b) = (if b then 0 else 1) + Constant.SyntacticOrd.hash c + x == x' || b = b' && Repr.CanOrd.equal c c' + let hash (c, b) = (if b then 0 else 1) + Repr.CanOrd.hash c end module Self_Hashcons = struct type nonrec t = t - type u = Constant.t -> Constant.t + type u = Repr.t -> Repr.t let hashcons hc (c,b) = (hc c,b) let eq ((c,b) as x) ((c',b') as y) = x == y || (c == c' && b == b') @@ -802,15 +914,19 @@ struct module HashProjection = Hashcons.Make(Self_Hashcons) - let hcons = Hashcons.simple_hcons HashProjection.generate HashProjection.hcons hcons_con + let hcons = Hashcons.simple_hcons HashProjection.generate HashProjection.hcons Repr.hcons let compare (c, b) (c', b') = - if b == b' then Constant.CanOrd.compare c c' + if b == b' then Repr.compare c c' else if b then 1 else -1 let map f (c, b as x) = - let c' = f c in - if c' == c then x else (c', b) + let c' = Repr.map f c in + if c' == c then x else (c', b) + + let map_npars f (c, b as x) = + let c' = Repr.map_npars f c in + if c' == c then x else (c', b) let to_string p = Constant.to_string (constant p) let print p = Constant.print (constant p) diff --git a/kernel/names.mli b/kernel/names.mli index 4eb5adb62f..1cdf5c2402 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -549,17 +549,68 @@ type module_path = ModPath.t = [@@ocaml.deprecated "Alias type"] module Projection : sig - type t + module Repr : sig + type t + + val make : inductive -> proj_npars:int -> proj_arg:int -> Label.t -> t + + module SyntacticOrd : sig + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int + end + module CanOrd : sig + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int + end + module UserOrd : sig + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int + end + + val constant : t -> Constant.t + (** Don't use this if you don't have to. *) + + val inductive : t -> inductive + val mind : t -> MutInd.t + val npars : t -> int + val arg : t -> int + val label : t -> Label.t + + val equal : t -> t -> bool + val hash : t -> int + val compare : t -> t -> int + + val map : (MutInd.t -> MutInd.t) -> t -> t + val map_npars : (MutInd.t -> int -> MutInd.t * int) -> t -> t + + val print : t -> Pp.t + val to_string : t -> string + end + type t (* = Repr.t * bool *) - val make : Constant.t -> bool -> t + val make : Repr.t -> bool -> t + val repr : t -> Repr.t module SyntacticOrd : sig val compare : t -> t -> int val equal : t -> t -> bool val hash : t -> int end + module CanOrd : sig + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int + end val constant : t -> Constant.t + val mind : t -> MutInd.t + val inductive : t -> inductive + val npars : t -> int + val arg : t -> int + val label : t -> Label.t val unfolded : t -> bool val unfold : t -> t @@ -570,7 +621,8 @@ module Projection : sig val compare : t -> t -> int - val map : (Constant.t -> Constant.t) -> t -> t + val map : (MutInd.t -> MutInd.t) -> t -> t + val map_npars : (MutInd.t -> int -> MutInd.t * int) -> t -> t val to_string : t -> string val print : t -> Pp.t diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index 39f7de9426..cc35a70cbf 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -278,7 +278,6 @@ type primitive = | Mk_rel of int | Mk_var of Id.t | Mk_proj - | Is_accu | Is_int | Cast_accu | Upd_cofix @@ -319,7 +318,6 @@ let eq_primitive p1 p2 = | Mk_cofix i1, Mk_cofix i2 -> Int.equal i1 i2 | Mk_rel i1, Mk_rel i2 -> Int.equal i1 i2 | Mk_var id1, Mk_var id2 -> Id.equal id1 id2 - | Is_accu, Is_accu -> true | Cast_accu, Cast_accu -> true | Upd_cofix, Upd_cofix -> true | Force_cofix, Force_cofix -> true @@ -345,7 +343,6 @@ let primitive_hash = function combinesmall 8 (Int.hash i) | Mk_var id -> combinesmall 9 (Id.hash id) - | Is_accu -> 10 | Is_int -> 11 | Cast_accu -> 12 | Upd_cofix -> 13 @@ -396,6 +393,7 @@ type mllambda = | MLsetref of string * mllambda | MLsequence of mllambda * mllambda | MLarray of mllambda array + | MLisaccu of string * inductive * mllambda and mllam_branches = ((constructor * lname option array) list * mllambda) array @@ -467,7 +465,12 @@ let rec eq_mllambda gn1 gn2 n env1 env2 t1 t2 = | MLarray arr1, MLarray arr2 -> Array.equal (eq_mllambda gn1 gn2 n env1 env2) arr1 arr2 - | _, _ -> false + | MLisaccu (s1, ind1, ml1), MLisaccu (s2, ind2, ml2) -> + String.equal s1 s2 && eq_ind ind1 ind2 && + eq_mllambda gn1 gn2 n env1 env2 ml1 ml2 + | (MLlocal _ | MLglobal _ | MLprimitive _ | MLlam _ | MLletrec _ | MLlet _ | + MLapp _ | MLif _ | MLmatch _ | MLconstruct _ | MLint _ | MLuint _ | + MLsetref _ | MLsequence _ | MLarray _ | MLisaccu _), _ -> false and eq_letrec gn1 gn2 n env1 env2 defs1 defs2 = let eq_def (_,args1,ml1) (_,args2,ml2) = @@ -542,6 +545,8 @@ let rec hash_mllambda gn n env t = combinesmall 14 (combine hml hml') | MLarray arr -> combinesmall 15 (hash_mllambda_array gn n env 1 arr) + | MLisaccu (s, ind, c) -> + combinesmall 16 (combine (String.hash s) (combine (ind_hash ind) (hash_mllambda gn n env c))) and hash_mllambda_letrec gn n env init defs = let hash_def (_,args,ml) = @@ -608,6 +613,7 @@ let fv_lam l = | MLsetref(_,l) -> aux l bind fv | MLsequence(l1,l2) -> aux l1 bind (aux l2 bind fv) | MLarray arr -> Array.fold_right (fun a fv -> aux a bind fv) arr fv + | MLisaccu (_, _, body) -> aux body bind fv in aux l LNset.empty LNset.empty @@ -1142,7 +1148,7 @@ let ml_of_instance instance u = mkMLapp (MLapp (MLglobal cn, fv_args env fvn fvr)) [|force|] | Lif(t,bt,bf) -> MLif(ml_of_lam env l t, ml_of_lam env l bt, ml_of_lam env l bf) - | Lfix ((rec_pos,start), (ids, tt, tb)) -> + | Lfix ((rec_pos, inds, start), (ids, tt, tb)) -> (* let type_f fvt = [| type fix |] let norm_f1 fv f1 .. fn params1 = body1 .. @@ -1211,8 +1217,9 @@ let ml_of_instance instance u = let paramsi = t_params.(i) in let reci = MLlocal (paramsi.(rec_pos.(i))) in let pargsi = Array.map (fun id -> MLlocal id) paramsi in + let (prefix, ind) = inds.(i) in let body = - MLif(MLapp(MLprimitive Is_accu,[|reci|]), + MLif(MLisaccu (prefix, ind, reci), mkMLapp (MLapp(MLprimitive (Mk_fix(rec_pos,i)), [|mk_type; mk_norm|])) @@ -1374,6 +1381,7 @@ let subst s l = | MLsetref(s,l1) -> MLsetref(s,aux l1) | MLsequence(l1,l2) -> MLsequence(aux l1, aux l2) | MLarray arr -> MLarray (Array.map aux arr) + | MLisaccu (s, ind, l) -> MLisaccu (s, ind, aux l) in aux l @@ -1471,7 +1479,7 @@ let optimize gdef l = let b1 = optimize s b1 in let b2 = optimize s b2 in begin match t, b2 with - | MLapp(MLprimitive Is_accu,[| l1 |]), MLmatch(annot, l2, _, bs) + | MLisaccu (_, _, l1), MLmatch(annot, l2, _, bs) when eq_mllambda l1 l2 -> MLmatch(annot, l1, b1, bs) | _, _ -> MLif(t, b1, b2) end @@ -1483,6 +1491,7 @@ let optimize gdef l = | MLsetref(r,l) -> MLsetref(r, optimize s l) | MLsequence(l1,l2) -> MLsequence(optimize s l1, optimize s l2) | MLarray arr -> MLarray (Array.map (optimize s) arr) + | MLisaccu (pf, ind, l) -> MLisaccu (pf, ind, optimize s l) in optimize LNmap.empty l @@ -1645,7 +1654,11 @@ let pp_mllam fmt l = pp_mllam fmt arr.(len-1) end; Format.fprintf fmt "|]@]" - + | MLisaccu (prefix, (mind, i), c) -> + let accu = Format.sprintf "%sAccu_%s_%i" prefix (string_of_mind mind) i in + Format.fprintf fmt + "@[begin match Obj.magic (%a) with@\n| %s _ ->@\n true@\n| _ ->@\n false@\nend@]" + pp_mllam c accu and pp_letrec fmt defs = let len = Array.length defs in @@ -1738,7 +1751,6 @@ let pp_mllam fmt l = | Mk_var id -> Format.fprintf fmt "mk_var_accu (Names.id_of_string \"%s\")" (string_of_id id) | Mk_proj -> Format.fprintf fmt "mk_proj_accu" - | Is_accu -> Format.fprintf fmt "is_accu" | Is_int -> Format.fprintf fmt "is_int" | Cast_accu -> Format.fprintf fmt "cast_accu" | Upd_cofix -> Format.fprintf fmt "upd_cofix" @@ -1884,7 +1896,7 @@ let compile_constant env sigma prefix ~interactive con cb = let t = Mod_subst.force_constr t in let code = lambda_of_constr env sigma t in if !Flags.debug then Feedback.msg_debug (Pp.str "Generated lambda code"); - let is_lazy = is_lazy prefix t in + let is_lazy = is_lazy env prefix t in let code = if is_lazy then mk_lazy code else code in let name = if interactive then LinkedInteractive prefix @@ -1968,8 +1980,7 @@ let compile_mind mb mind stack = (MLconstruct("", c, Array.map (fun id -> MLlocal id) args)))::acc in let constructors = Array.fold_left_i add_construct [] ob.mind_reloc_tbl in - let add_proj j acc pb = - let () = assert (eq_ind ind pb.proj_ind) in + let add_proj proj_arg acc pb = let tbl = ob.mind_reloc_tbl in (* Building info *) let ci = { ci_ind = ind; ci_npar = nparams; @@ -1983,14 +1994,14 @@ let compile_mind mb mind stack = let _, arity = tbl.(0) in let ci_uid = fresh_lname Anonymous in let cargs = Array.init arity - (fun i -> if Int.equal i pb.proj_arg then Some ci_uid else None) + (fun i -> if Int.equal i proj_arg then Some ci_uid else None) in let i = push_symbol (SymbProj (ind, j)) in let accu = MLapp (MLprimitive Cast_accu, [|MLlocal cf_uid|]) in let accu_br = MLapp (MLprimitive Mk_proj, [|get_proj_code i;accu|]) in let code = MLmatch(asw,MLlocal cf_uid,accu_br,[|[((ind,1),cargs)],MLlocal ci_uid|]) in let code = MLlet(cf_uid, MLapp (MLprimitive Force_cofix, [|MLlocal c_uid|]), code) in - let gn = Gproj ("", ind, pb.proj_arg) in + let gn = Gproj ("", ind, proj_arg) in Glet (gn, mkMLlam [|c_uid|] code) :: acc in let projs = match mb.mind_record with @@ -2058,8 +2069,7 @@ let compile_deps env sigma prefix ~interactive init t = comp_stack, (mind_updates, const_updates) | Construct (((mind,_),_),u) -> compile_mind_deps env prefix ~interactive init mind | Proj (p,c) -> - let pb = lookup_projection p env in - let init = compile_mind_deps env prefix ~interactive init (fst pb.proj_ind) in + let init = compile_mind_deps env prefix ~interactive init (Projection.mind p) in aux env lvl init c | Case (ci, p, c, ac) -> let mind = fst ci.ci_ind in diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml index e97dbd0d67..931b8bbc86 100644 --- a/kernel/nativeconv.ml +++ b/kernel/nativeconv.ml @@ -135,7 +135,18 @@ and conv_fix env lvl t1 f1 t2 f2 cu = else aux (i+1) (conv_val env CONV flvl fi1 fi2 cu) in aux 0 cu +let warn_no_native_compiler = + let open Pp in + CWarnings.create ~name:"native-compiler-disabled" ~category:"native-compiler" + (fun () -> strbrk "Native compiler is disabled," ++ + strbrk " falling back to VM conversion test.") + let native_conv_gen pb sigma env univs t1 t2 = + if not Coq_config.native_compiler then begin + warn_no_native_compiler (); + Vconv.vm_conv_gen pb env univs t1 t2 + end + else let ml_filename, prefix = get_ml_filename () in let code, upds = mk_conv_code env sigma prefix t1 t2 in match compile ml_filename code ~profile:false with @@ -152,19 +163,8 @@ let native_conv_gen pb sigma env univs t1 t2 = end | _ -> anomaly (Pp.str "Compilation failure.") -let warn_no_native_compiler = - let open Pp in - CWarnings.create ~name:"native-compiler-disabled" ~category:"native-compiler" - (fun () -> strbrk "Native compiler is disabled," ++ - strbrk " falling back to VM conversion test.") - (* Wrapper for [native_conv] above *) let native_conv cv_pb sigma env t1 t2 = - if not Coq_config.native_compiler then begin - warn_no_native_compiler (); - Vconv.vm_conv cv_pb env t1 t2 - end - else let univs = Environ.universes env in let b = if cv_pb = CUMUL then Constr.leq_constr_univs univs t1 t2 diff --git a/kernel/nativeinstr.mli b/kernel/nativeinstr.mli index eaad8ee0c2..5075bd3d14 100644 --- a/kernel/nativeinstr.mli +++ b/kernel/nativeinstr.mli @@ -36,7 +36,7 @@ and lambda = | Lcase of annot_sw * lambda * lambda * lam_branches (* annotations, term being matched, accu, branches *) | Lif of lambda * lambda * lambda - | Lfix of (int array * int) * fix_decl + | Lfix of (int array * (string * inductive) array * int) * fix_decl | Lcofix of int * fix_decl (* must be in eta-expanded form *) | Lmakeblock of prefix * pconstructor * int * lambda array (* prefix, constructor name, constructor tag, arguments *) diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index 5843cd5434..cec0ee57d5 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -333,54 +333,13 @@ let rec get_alias env (kn, u as p) = (*i Global environment *) -let global_env = ref empty_env - -let set_global_env env = global_env := env - let get_names decl = let decl = Array.of_list decl in Array.map fst decl -(* Rel Environment *) -module Vect = - struct - type 'a t = { - mutable elems : 'a array; - mutable size : int; - } - - let make n a = { - elems = Array.make n a; - size = 0; - } - - let extend v = - if Int.equal v.size (Array.length v.elems) then - let new_size = min (2*v.size) Sys.max_array_length in - if new_size <= v.size then invalid_arg "Vect.extend"; - let new_elems = Array.make new_size v.elems.(0) in - Array.blit v.elems 0 new_elems 0 (v.size); - v.elems <- new_elems - - let push v a = - extend v; - v.elems.(v.size) <- a; - v.size <- v.size + 1 - - let popn v n = - v.size <- max 0 (v.size - n) - - let pop v = popn v 1 - - let get_last v n = - if v.size <= n then invalid_arg "Vect.get:index out of bounds"; - v.elems.(v.size - n - 1) - - end - let empty_args = [||] -module Renv = +module Cache = struct module ConstrHash = @@ -394,45 +353,20 @@ module Renv = type constructor_info = tag * int * int (* nparam nrealargs *) - type t = { - name_rel : Name.t Vect.t; - construct_tbl : constructor_info ConstrTable.t; - - } - - - let make () = { - name_rel = Vect.make 16 Anonymous; - construct_tbl = ConstrTable.create 111 - } - - let push_rel env id = Vect.push env.name_rel id - - let push_rels env ids = - Array.iter (push_rel env) ids - - let pop env = Vect.pop env.name_rel - - let popn env n = - for _i = 1 to n do pop env done - - let get env n = - Lrel (Vect.get_last env.name_rel (n-1), n) - - let get_construct_info env c = - try ConstrTable.find env.construct_tbl c + let get_construct_info cache env c : constructor_info = + try ConstrTable.find cache c with Not_found -> let ((mind,j), i) = c in - let oib = lookup_mind mind !global_env in + let oib = lookup_mind mind env in let oip = oib.mind_packets.(j) in let tag,arity = oip.mind_reloc_tbl.(i-1) in let nparams = oib.mind_nparams in let r = (tag, nparams, arity) in - ConstrTable.add env.construct_tbl c r; + ConstrTable.add cache c r; r end -let is_lazy prefix t = +let is_lazy env prefix t = match kind t with | App (f,args) -> begin match kind f with @@ -440,7 +374,7 @@ let is_lazy prefix t = let entry = mkInd (fst c) in (try let _ = - Retroknowledge.get_native_before_match_info (!global_env).retroknowledge + Retroknowledge.get_native_before_match_info env.retroknowledge entry prefix c Llazy; in false @@ -463,73 +397,84 @@ let empty_evars = let empty_ids = [||] -let rec lambda_of_constr env sigma c = +(** Extract the inductive type over which a fixpoint is decreasing *) +let rec get_fix_struct env i t = match kind (Reduction.whd_all env t) with +| Prod (na, dom, t) -> + if Int.equal i 0 then + let dom = Reduction.whd_all env dom in + let (dom, _) = decompose_appvect dom in + match kind dom with + | Ind (ind, _) -> ind + | _ -> assert false + else + let env = Environ.push_rel (RelDecl.LocalAssum (na, dom)) env in + get_fix_struct env (i - 1) t +| _ -> assert false + +let rec lambda_of_constr cache env sigma c = match kind c with | Meta mv -> let ty = meta_type sigma mv in - Lmeta (mv, lambda_of_constr env sigma ty) + Lmeta (mv, lambda_of_constr cache env sigma ty) | Evar (evk,args as ev) -> (match evar_value sigma ev with | None -> let ty = evar_type sigma ev in - let args = Array.map (lambda_of_constr env sigma) args in - Levar(evk, lambda_of_constr env sigma ty, args) - | Some t -> lambda_of_constr env sigma t) + let args = Array.map (lambda_of_constr cache env sigma) args in + Levar(evk, lambda_of_constr cache env sigma ty, args) + | Some t -> lambda_of_constr cache env sigma t) - | Cast (c, _, _) -> lambda_of_constr env sigma c + | Cast (c, _, _) -> lambda_of_constr cache env sigma c - | Rel i -> Renv.get env i + | Rel i -> Lrel (RelDecl.get_name (Environ.lookup_rel i env), i) | Var id -> Lvar id | Sort s -> Lsort s | Ind (ind,u as pind) -> - let prefix = get_mind_prefix !global_env (fst ind) in + let prefix = get_mind_prefix env (fst ind) in Lind (prefix, pind) | Prod(id, dom, codom) -> - let ld = lambda_of_constr env sigma dom in - Renv.push_rel env id; - let lc = lambda_of_constr env sigma codom in - Renv.pop env; + let ld = lambda_of_constr cache env sigma dom in + let env = Environ.push_rel (RelDecl.LocalAssum (id, dom)) env in + let lc = lambda_of_constr cache env sigma codom in Lprod(ld, Llam([|id|], lc)) | Lambda _ -> let params, body = Term.decompose_lam c in + let fold (na, t) env = Environ.push_rel (RelDecl.LocalAssum (na, t)) env in + let env = List.fold_right fold params env in + let lb = lambda_of_constr cache env sigma body in let ids = get_names (List.rev params) in - Renv.push_rels env ids; - let lb = lambda_of_constr env sigma body in - Renv.popn env (Array.length ids); mkLlam ids lb - | LetIn(id, def, _, body) -> - let ld = lambda_of_constr env sigma def in - Renv.push_rel env id; - let lb = lambda_of_constr env sigma body in - Renv.pop env; + | LetIn(id, def, t, body) -> + let ld = lambda_of_constr cache env sigma def in + let env = Environ.push_rel (RelDecl.LocalDef (id, def, t)) env in + let lb = lambda_of_constr cache env sigma body in Llet(id, ld, lb) - | App(f, args) -> lambda_of_app env sigma f args + | App(f, args) -> lambda_of_app cache env sigma f args - | Const _ -> lambda_of_app env sigma c empty_args + | Const _ -> lambda_of_app cache env sigma c empty_args - | Construct _ -> lambda_of_app env sigma c empty_args + | Construct _ -> lambda_of_app cache env sigma c empty_args | Proj (p, c) -> - let pb = lookup_projection p !global_env in - let ind = pb.proj_ind in - let prefix = get_mind_prefix !global_env (fst ind) in - mkLapp (Lproj (prefix, ind, pb.proj_arg)) [|lambda_of_constr env sigma c|] + let ind = Projection.inductive p in + let prefix = get_mind_prefix env (fst ind) in + mkLapp (Lproj (prefix, ind, Projection.arg p)) [|lambda_of_constr cache env sigma c|] | Case(ci,t,a,branches) -> let (mind,i as ind) = ci.ci_ind in - let mib = lookup_mind mind !global_env in + let mib = lookup_mind mind env in let oib = mib.mind_packets.(i) in let tbl = oib.mind_reloc_tbl in (* Building info *) - let prefix = get_mind_prefix !global_env mind in + let prefix = get_mind_prefix env mind in let annot_sw = { asw_ind = ind; asw_ci = ci; @@ -538,21 +483,21 @@ let rec lambda_of_constr env sigma c = asw_prefix = prefix} in (* translation of the argument *) - let la = lambda_of_constr env sigma a in + let la = lambda_of_constr cache env sigma a in let entry = mkInd ind in let la = try - Retroknowledge.get_native_before_match_info (!global_env).retroknowledge + Retroknowledge.get_native_before_match_info (env).retroknowledge entry prefix (ind,1) la with Not_found -> la in (* translation of the type *) - let lt = lambda_of_constr env sigma t in + let lt = lambda_of_constr cache env sigma t in (* translation of branches *) let mk_branch i b = let cn = (ind,i+1) in let _, arity = tbl.(i) in - let b = lambda_of_constr env sigma b in + let b = lambda_of_constr cache env sigma b in if Int.equal arity 0 then (cn, empty_ids, b) else match b with @@ -565,86 +510,90 @@ let rec lambda_of_constr env sigma c = let bs = Array.mapi mk_branch branches in Lcase(annot_sw, lt, la, bs) - | Fix(rec_init,(names,type_bodies,rec_bodies)) -> - let ltypes = lambda_of_args env sigma 0 type_bodies in - Renv.push_rels env names; - let lbodies = lambda_of_args env sigma 0 rec_bodies in - Renv.popn env (Array.length names); - Lfix(rec_init, (names, ltypes, lbodies)) + | Fix((pos, i), (names,type_bodies,rec_bodies)) -> + let ltypes = lambda_of_args cache env sigma 0 type_bodies in + let map i t = + let ind = get_fix_struct env i t in + let prefix = get_mind_prefix env (fst ind) in + (prefix, ind) + in + let inds = Array.map2 map pos type_bodies in + let env = Environ.push_rec_types (names, type_bodies, rec_bodies) env in + let lbodies = lambda_of_args cache env sigma 0 rec_bodies in + Lfix((pos, inds, i), (names, ltypes, lbodies)) | CoFix(init,(names,type_bodies,rec_bodies)) -> - let rec_bodies = Array.map2 (Reduction.eta_expand !global_env) rec_bodies type_bodies in - let ltypes = lambda_of_args env sigma 0 type_bodies in - Renv.push_rels env names; - let lbodies = lambda_of_args env sigma 0 rec_bodies in - Renv.popn env (Array.length names); + let rec_bodies = Array.map2 (Reduction.eta_expand env) rec_bodies type_bodies in + let ltypes = lambda_of_args cache env sigma 0 type_bodies in + let env = Environ.push_rec_types (names, type_bodies, rec_bodies) env in + let lbodies = lambda_of_args cache env sigma 0 rec_bodies in Lcofix(init, (names, ltypes, lbodies)) -and lambda_of_app env sigma f args = +and lambda_of_app cache env sigma f args = match kind f with | Const (kn,u as c) -> - let kn,u = get_alias !global_env c in - let cb = lookup_constant kn !global_env in + let kn,u = get_alias env c in + let cb = lookup_constant kn env in (try - let prefix = get_const_prefix !global_env kn in + let prefix = get_const_prefix env kn in (* We delay the compilation of arguments to avoid an exponential behavior *) let f = Retroknowledge.get_native_compiling_info - (!global_env).retroknowledge (mkConst kn) prefix in - let args = lambda_of_args env sigma 0 args in + (env).retroknowledge (mkConst kn) prefix in + let args = lambda_of_args cache env sigma 0 args in f args with Not_found -> begin match cb.const_body with | Def csubst -> (* TODO optimize if f is a proj and argument is known *) if cb.const_inline_code then - lambda_of_app env sigma (Mod_subst.force_constr csubst) args + lambda_of_app cache env sigma (Mod_subst.force_constr csubst) args else - let prefix = get_const_prefix !global_env kn in + let prefix = get_const_prefix env kn in let t = - if is_lazy prefix (Mod_subst.force_constr csubst) then + if is_lazy env prefix (Mod_subst.force_constr csubst) then mkLapp Lforce [|Lconst (prefix, (kn,u))|] else Lconst (prefix, (kn,u)) in - mkLapp t (lambda_of_args env sigma 0 args) + mkLapp t (lambda_of_args cache env sigma 0 args) | OpaqueDef _ | Undef _ -> - let prefix = get_const_prefix !global_env kn in - mkLapp (Lconst (prefix, (kn,u))) (lambda_of_args env sigma 0 args) + let prefix = get_const_prefix env kn in + mkLapp (Lconst (prefix, (kn,u))) (lambda_of_args cache env sigma 0 args) end) | Construct (c,u) -> - let tag, nparams, arity = Renv.get_construct_info env c in + let tag, nparams, arity = Cache.get_construct_info cache env c in let expected = nparams + arity in let nargs = Array.length args in - let prefix = get_mind_prefix !global_env (fst (fst c)) in + let prefix = get_mind_prefix env (fst (fst c)) in if Int.equal nargs expected then try try Retroknowledge.get_native_constant_static_info - (!global_env).retroknowledge + (env).retroknowledge f args with NotClosed -> assert (Int.equal nparams 0); (* should be fine for int31 *) - let args = lambda_of_args env sigma nparams args in + let args = lambda_of_args cache env sigma nparams args in Retroknowledge.get_native_constant_dynamic_info - (!global_env).retroknowledge f prefix c args + (env).retroknowledge f prefix c args with Not_found -> - let args = lambda_of_args env sigma nparams args in - makeblock !global_env c u tag args + let args = lambda_of_args cache env sigma nparams args in + makeblock env c u tag args else - let args = lambda_of_args env sigma 0 args in + let args = lambda_of_args cache env sigma 0 args in (try Retroknowledge.get_native_constant_dynamic_info - (!global_env).retroknowledge f prefix c args + (env).retroknowledge f prefix c args with Not_found -> mkLapp (Lconstruct (prefix, (c,u))) args) | _ -> - let f = lambda_of_constr env sigma f in - let args = lambda_of_args env sigma 0 args in + let f = lambda_of_constr cache env sigma f in + let args = lambda_of_args cache env sigma 0 args in mkLapp f args -and lambda_of_args env sigma start args = +and lambda_of_args cache env sigma start args = let nargs = Array.length args in if start < nargs then Array.init (nargs - start) - (fun i -> lambda_of_constr env sigma args.(start + i)) + (fun i -> lambda_of_constr cache env sigma args.(start + i)) else empty_args let optimize lam = @@ -657,11 +606,8 @@ let optimize lam = lam let lambda_of_constr env sigma c = - set_global_env env; - let env = Renv.make () in - let ids = List.rev_map RelDecl.get_name (rel_context !global_env) in - Renv.push_rels env (Array.of_list ids); - let lam = lambda_of_constr env sigma c in + let cache = Cache.ConstrTable.create 91 in + let lam = lambda_of_constr cache env sigma c in (* if Flags.vm_draw_opt () then begin (msgerrnl (str "Constr = \n" ++ pr_constr c);flush_all()); (msgerrnl (str "Lambda = \n" ++ pp_lam lam);flush_all()); diff --git a/kernel/nativelambda.mli b/kernel/nativelambda.mli index 26bfeb7e0e..efe1700cd7 100644 --- a/kernel/nativelambda.mli +++ b/kernel/nativelambda.mli @@ -23,7 +23,7 @@ val empty_evars : evars val decompose_Llam : lambda -> Name.t array * lambda val decompose_Llam_Llet : lambda -> (Name.t * lambda option) array * lambda -val is_lazy : prefix -> constr -> bool +val is_lazy : env -> prefix -> constr -> bool val mk_lazy : lambda -> lambda val get_mind_prefix : env -> MutInd.t -> string diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml index 31ad364911..f784509b6f 100644 --- a/kernel/nativelib.ml +++ b/kernel/nativelib.ml @@ -67,6 +67,7 @@ let warn_native_compiler_failed = CWarnings.create ~name:"native-compiler-failed" ~category:"native-compiler" print let call_compiler ?profile:(profile=false) ml_filename = + let () = assert Coq_config.native_compiler in let load_path = !get_load_paths () in let load_path = List.map (fun dn -> dn / output_dir) load_path in let include_dirs = List.flatten (List.map (fun x -> ["-I"; x]) (include_dirs () @ load_path)) in diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml index 3901cb9ce4..91f6add1c3 100644 --- a/kernel/nativevalues.ml +++ b/kernel/nativevalues.ml @@ -68,28 +68,29 @@ type atom = let accumulate_tag = 0 -let accumulate_code (k:accumulator) (x:t) = - let o = Obj.repr k in - let osize = Obj.size o in - let r = Obj.new_block accumulate_tag (osize + 1) in - for i = 0 to osize - 1 do - Obj.set_field r i (Obj.field o i) - done; - Obj.set_field r osize (Obj.repr x); - (Obj.obj r:t) - -let rec accumulate (x:t) = - accumulate_code (Obj.magic accumulate) x - -let mk_accu_gen rcode (a:atom) = -(* Format.eprintf "size rcode =%i\n" (Obj.size (Obj.magic rcode)); *) - let r = Obj.new_block 0 3 in - Obj.set_field r 0 (Obj.field (Obj.magic rcode) 0); - Obj.set_field r 1 (Obj.field (Obj.magic rcode) 1); - Obj.set_field r 2 (Obj.magic a); - (Obj.magic r:t);; - -let mk_accu (a:atom) = mk_accu_gen accumulate a +(** Unique pointer used to drive the accumulator function *) +let ret_accu = Obj.repr (ref ()) + +type accu_val = { mutable acc_atm : atom; acc_arg : Obj.t list } + +let mk_accu (a : atom) : t = + let rec accumulate data x = + if x == ret_accu then Obj.repr data + else + let data = { data with acc_arg = x :: data.acc_arg } in + let ans = Obj.repr (accumulate data) in + let () = Obj.set_tag ans accumulate_tag in + ans + in + let acc = { acc_atm = a; acc_arg = [] } in + let ans = Obj.repr (accumulate acc) in + (** FIXME: use another representation for accumulators, this causes naked + pointers. *) + let () = Obj.set_tag ans accumulate_tag in + (Obj.obj ans : t) + +let get_accu (k : accumulator) = + (Obj.magic k : Obj.t -> accu_val) ret_accu let mk_rel_accu i = mk_accu (Arel i) @@ -141,31 +142,27 @@ let mk_proj_accu kn c = mk_accu (Aproj (kn,c)) let atom_of_accu (k:accumulator) = - (Obj.magic (Obj.field (Obj.magic k) 2) : atom) + (get_accu k).acc_atm let set_atom_of_accu (k:accumulator) (a:atom) = - Obj.set_field (Obj.magic k) 2 (Obj.magic a) + (get_accu k).acc_atm <- a let accu_nargs (k:accumulator) = - let nargs = Obj.size (Obj.magic k) - 3 in -(* if nargs < 0 then Format.eprintf "nargs = %i\n" nargs; *) - assert (nargs >= 0); - nargs + List.length (get_accu k).acc_arg let args_of_accu (k:accumulator) = - let nargs = accu_nargs k in - let f i = (Obj.magic (Obj.field (Obj.magic k) (nargs-i+2)) : t) in - Array.init nargs f + let acc = (get_accu k).acc_arg in + (Obj.magic (Array.of_list acc) : t array) let is_accu x = let o = Obj.repr x in Obj.is_block o && Int.equal (Obj.tag o) accumulate_tag let mk_fix_accu rec_pos pos types bodies = - mk_accu_gen accumulate (Afix(types,bodies,rec_pos, pos)) + mk_accu (Afix(types,bodies,rec_pos, pos)) let mk_cofix_accu pos types norm = - mk_accu_gen accumulate (Acofix(types,norm,pos,(Obj.magic 0 : t))) + mk_accu (Acofix(types,norm,pos,(Obj.magic 0 : t))) let upd_cofix (cofix :t) (cofix_fun : t) = let atom = atom_of_accu (Obj.magic cofix) in diff --git a/kernel/nativevalues.mli b/kernel/nativevalues.mli index 649853f069..6bbf15160c 100644 --- a/kernel/nativevalues.mli +++ b/kernel/nativevalues.mli @@ -110,9 +110,6 @@ type kind_of_value = val kind_of_value : t -> kind_of_value -(* *) -val is_accu : t -> bool - val str_encode : 'a -> string val str_decode : string -> 'a diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 3228a155f3..c701b53fe4 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -53,7 +53,7 @@ let compare_stack_shape stk1 stk2 = | (_, (Zupdate _|Zshift _)::s2) -> compare_rec bal stk1 s2 | (Zapp l1::s1, _) -> compare_rec (bal+Array.length l1) s1 stk2 | (_, Zapp l2::s2) -> compare_rec (bal-Array.length l2) stk1 s2 - | (Zproj (n1,m1,p1)::s1, Zproj (n2,m2,p2)::s2) -> + | (Zproj p1::s1, Zproj p2::s2) -> Int.equal bal 0 && compare_rec 0 s1 s2 | (ZcaseT(c1,_,_,_)::s1, ZcaseT(c2,_,_,_)::s2) -> Int.equal bal 0 (* && c1.ci_ind = c2.ci_ind *) && compare_rec 0 s1 s2 @@ -66,7 +66,7 @@ let compare_stack_shape stk1 stk2 = type lft_constr_stack_elt = Zlapp of (lift * fconstr) array - | Zlproj of Constant.t * lift + | Zlproj of Projection.Repr.t * lift | Zlfix of (lift * fconstr) * lft_constr_stack | Zlcase of case_info * lift * fconstr * fconstr array and lft_constr_stack = lft_constr_stack_elt list @@ -96,8 +96,8 @@ let pure_stack lfts stk = | (Zshift n,(l,pstk)) -> (el_shft n l, pstk) | (Zapp a, (l,pstk)) -> (l,zlapp (map_lift l a) pstk) - | (Zproj (n,m,c), (l,pstk)) -> - (l, Zlproj (c,l)::pstk) + | (Zproj p, (l,pstk)) -> + (l, Zlproj (p,l)::pstk) | (Zfix(fx,a),(l,pstk)) -> let (lfx,pa) = pure_rec l a in (l, Zlfix((lfx,fx),pa)::pstk) @@ -297,7 +297,7 @@ let compare_stacks f fmind lft1 stk1 lft2 stk2 cuniv = | (Zlapp a1,Zlapp a2) -> Array.fold_right2 f a1 a2 cu1 | (Zlproj (c1,l1),Zlproj (c2,l2)) -> - if not (Constant.equal c1 c2) then + if not (Projection.Repr.equal c1 c2) then raise NotConvertible else cu1 | (Zlfix(fx1,a1),Zlfix(fx2,a2)) -> @@ -408,7 +408,7 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = | Some s2 -> eqappr cv_pb l2r infos appr1 (lft2, (c2, (s2 :: v2))) cuniv | None -> - if Constant.equal (Projection.constant p1) (Projection.constant p2) + if Projection.Repr.equal (Projection.repr p1) (Projection.repr p2) && compare_stack_shape v1 v2 then let el1 = el_stack lft1 v1 in let el2 = el_stack lft2 v2 in diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 7c0057696e..7f36f3813f 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -296,13 +296,13 @@ let type_of_case env ci p pt c ct lf lft = rslty let type_of_projection env p c ct = - let pb = lookup_projection p env in + let pty = lookup_projection p env in let (ind,u), args = try find_rectype env ct with Not_found -> error_case_not_inductive env (make_judge c ct) in - assert(eq_ind pb.proj_ind ind); - let ty = Vars.subst_instance_constr u pb.Declarations.proj_type in + assert(eq_ind (Projection.inductive p) ind); + let ty = Vars.subst_instance_constr u pty in substl (c :: CList.rev args) ty diff --git a/kernel/vconv.ml b/kernel/vconv.ml index 4e4168922d..d19bea5199 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -139,7 +139,7 @@ and conv_stack env k stk1 stk2 cu = conv_stack env k stk1 stk2 !rcu else raise NotConvertible | Zproj p1 :: stk1, Zproj p2 :: stk2 -> - if Constant.equal p1 p2 then conv_stack env k stk1 stk2 cu + if Projection.Repr.equal p1 p2 then conv_stack env k stk1 stk2 cu else raise NotConvertible | [], _ | Zapp _ :: _, _ | Zfix _ :: _, _ | Zswitch _ :: _, _ | Zproj _ :: _, _ -> raise NotConvertible diff --git a/kernel/vmvalues.ml b/kernel/vmvalues.ml index 8524c44d21..d6d9312938 100644 --- a/kernel/vmvalues.ml +++ b/kernel/vmvalues.ml @@ -150,7 +150,7 @@ type zipper = | Zapp of arguments | Zfix of vfix*arguments (* Possibly empty *) | Zswitch of vswitch - | Zproj of Constant.t (* name of the projection *) + | Zproj of Projection.Repr.t (* name of the projection *) type stack = zipper list @@ -354,7 +354,7 @@ let val_of_constant c = val_of_idkey (ConstKey c) let val_of_evar evk = val_of_idkey (EvarKey evk) external val_of_annot_switch : annot_switch -> values = "%identity" -external val_of_proj_name : Constant.t -> values = "%identity" +external val_of_proj_name : Projection.Repr.t -> values = "%identity" (*************************************************) (** Operations manipulating data types ***********) @@ -553,4 +553,4 @@ and pr_zipper z = | Zapp args -> str "Zapp(len = " ++ int (nargs args) ++ str ")" | Zfix (f,args) -> str "Zfix(..., len=" ++ int (nargs args) ++ str ")" | Zswitch s -> str "Zswitch(...)" - | Zproj c -> str "Zproj(" ++ Constant.print c ++ str ")") + | Zproj c -> str "Zproj(" ++ Projection.Repr.print c ++ str ")") diff --git a/kernel/vmvalues.mli b/kernel/vmvalues.mli index 08d05a038c..6eedcf1d37 100644 --- a/kernel/vmvalues.mli +++ b/kernel/vmvalues.mli @@ -81,7 +81,7 @@ type zipper = | Zapp of arguments | Zfix of vfix * arguments (** might be empty *) | Zswitch of vswitch - | Zproj of Constant.t (* name of the projection *) + | Zproj of Projection.Repr.t (* name of the projection *) type stack = zipper list @@ -108,11 +108,11 @@ val val_of_rel : int -> values val val_of_named : Id.t -> values val val_of_constant : Constant.t -> values val val_of_evar : Evar.t -> values -val val_of_proj : Constant.t -> values -> values +val val_of_proj : Projection.Repr.t -> values -> values val val_of_atom : atom -> values external val_of_annot_switch : annot_switch -> values = "%identity" -external val_of_proj_name : Constant.t -> values = "%identity" +external val_of_proj_name : Projection.Repr.t -> values = "%identity" (** Destructors *) diff --git a/lib/lib.mllib b/lib/lib.mllib index 0891859423..41b3622a99 100644 --- a/lib/lib.mllib +++ b/lib/lib.mllib @@ -6,6 +6,7 @@ Control Util Pp +Pp_diff Stateid Loc Feedback @@ -139,7 +139,7 @@ let v n s = Ppcmd_box(Pp_vbox n,s) let hv n s = Ppcmd_box(Pp_hvbox n,s) let hov n s = Ppcmd_box(Pp_hovbox n,s) -(* Opening and closed of tags *) +(* Opening and closing of tags *) let tag t s = Ppcmd_tag(t,s) (* In new syntax only double quote char is escaped by repeating it *) @@ -167,6 +167,20 @@ let rec pr_com ft s = Some s2 -> Format.pp_force_newline ft (); pr_com ft s2 | None -> () +let start_pfx = "start." +let end_pfx = "end." + +let split_pfx pfx str = + let (str_len, pfx_len) = (String.length str, String.length pfx) in + if str_len >= pfx_len && (String.sub str 0 pfx_len) = pfx then + (pfx, String.sub str pfx_len (str_len - pfx_len)) else ("", str);; + +let split_tag tag = + let (pfx, ttag) = split_pfx start_pfx tag in + if pfx <> "" then (pfx, ttag) else + let (pfx, ttag) = split_pfx end_pfx tag in + (pfx, ttag);; + (* pretty printing functions *) let pp_with ft pp = let cpp_open_box = function @@ -297,3 +311,62 @@ let prvect_with_sep sep elem v = prvecti_with_sep sep (fun _ -> elem) v let prvect elem v = prvect_with_sep mt elem v let surround p = hov 1 (str"(" ++ p ++ str")") + +(*** DEBUG code ***) + +let db_print_pp fmt pp = + let open Format in + let block_type fmt btype = + let (bt, v) = + match btype with + | Pp_hbox v -> ("Pp_hbox", v) + | Pp_vbox v -> ("Pp_vbox", v) + | Pp_hvbox v -> ("Pp_hvbox", v) + | Pp_hovbox v -> ("Pp_hovbox", v) + in + fprintf fmt "%s %d" bt v + in + let rec db_print_pp_r indent pp = + let ind () = fprintf fmt "%s" (String.make (2 * indent) ' ') in + ind(); + match pp with + | Ppcmd_empty -> + fprintf fmt "Ppcmd_empty@;" + | Ppcmd_string str -> + fprintf fmt "Ppcmd_string '%s'@;" str + | Ppcmd_glue list -> + fprintf fmt "Ppcmd_glue@;"; + List.iter (fun x -> db_print_pp_r (indent + 1) (repr x)) list; + | Ppcmd_box (block, pp) -> + fprintf fmt "Ppcmd_box %a@;" block_type block; + db_print_pp_r (indent + 1) (repr pp); + | Ppcmd_tag (tag, pp) -> + fprintf fmt "Ppcmd_tag %s@;" tag; + db_print_pp_r (indent + 1) (repr pp); + | Ppcmd_print_break (i, j) -> + fprintf fmt "Ppcmd_print_break %d %d@;" i j + | Ppcmd_force_newline -> + fprintf fmt "Ppcmd_force_newline@;" + | Ppcmd_comment list -> + fprintf fmt "Ppcmd_comment@;"; + List.iter (fun x -> ind(); (fprintf fmt "%s@;" x)) list + in + pp_open_vbox fmt 0; + db_print_pp_r 0 pp; + pp_close_box fmt (); + pp_print_flush fmt () + +let db_string_of_pp pp = + Format.asprintf "%a" db_print_pp pp + +let rec flatten pp = + match pp with + | Ppcmd_glue l -> Ppcmd_glue (List.concat (List.map + (fun x -> let x = flatten x in + match x with + | Ppcmd_glue l2 -> l2 + | p -> [p]) + l)) + | Ppcmd_box (block, pp) -> Ppcmd_box (block, flatten pp) + | Ppcmd_tag (tag, pp) -> Ppcmd_tag (tag, flatten pp) + | p -> p diff --git a/lib/pp.mli b/lib/pp.mli index f3a0a29b8a..ed31daa561 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -189,3 +189,22 @@ val pr_vertical_list : ('b -> t) -> 'b list -> t val pp_with : Format.formatter -> t -> unit val string_of_ppcmds : t -> string + + +(** Tag prefix to start a multi-token diff span *) +val start_pfx : string + +(** Tag prefix to end a multi-token diff span *) +val end_pfx : string + +(** Split a tag into prefix and base tag *) +val split_tag : string -> string * string + +(** Print the Pp in tree form for debugging *) +val db_print_pp : Format.formatter -> t -> unit + +(** Print the Pp in tree form for debugging, return as a string *) +val db_string_of_pp : t -> string + +(** Combine nested Ppcmd_glues *) +val flatten : t -> t diff --git a/lib/pp_diff.ml b/lib/pp_diff.ml new file mode 100644 index 0000000000..7b4b1eab73 --- /dev/null +++ b/lib/pp_diff.ml @@ -0,0 +1,303 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* DEBUG/UNIT TEST *) +let cfprintf oc = Printf.(kfprintf (fun oc -> fprintf oc "") oc) +let log_out_ch = ref stdout +let cprintf s = cfprintf !log_out_ch s + + +module StringDiff = Diff2.Make(struct + type elem = String.t + type t = elem array + let get t i = Array.get t i + let length t = Array.length t +end) + +type diff_type = + [ `Removed + | `Added + | `Common + ] + +type diff_list = StringDiff.elem Diff2.edit list + +(* debug print diff data structure *) +let db_print_diffs fmt diffs = + let open Format in + let print_diff = function + | `Common (opos, npos, s) -> + fprintf fmt "Common '%s' opos = %d npos = %d\n" s opos npos; + | `Removed (pos, s) -> + fprintf fmt "Removed '%s' opos = %d\n" s pos; + | `Added (pos, s) -> + fprintf fmt "Added '%s' npos = %d\n" s pos; + in + pp_open_vbox fmt 0; + List.iter print_diff diffs; + pp_close_box fmt (); + pp_print_flush fmt () + +let string_of_diffs diffs = + Format.asprintf "%a" db_print_diffs diffs + +(* Adjust the diffs returned by the Myers algorithm to reduce the span of the +changes. This gives more natural-looking diffs. + +While the Myers algorithm minimizes the number of changes between two +sequences, it doesn't minimize the span of the changes. For example, +representing elements in common in lower case and inserted elements in upper +case (but ignoring case in the algorithm), ABabC and abABC both have 3 changes +(A, B and C). However the span of the first sequence is 5 elements (ABabC) +while the span of the second is 3 elements (ABC). + +The algorithm modifies the changes iteratively, for example ABabC -> aBAbC -> abABC + +dtype: identifies which of Added OR Removed to use; the other one is ignored. +diff_list: output from the Myers algorithm +*) +let shorten_diff_span dtype diff_list = + let changed = ref false in + let diffs = Array.of_list diff_list in + let len = Array.length diffs in + let vinfo index = + match diffs.(index) with + | `Common (opos, npos, s) -> (`Common, opos, npos, s) + | `Removed (pos, s) -> (`Removed, pos, 0, s) + | `Added (pos, s) -> (`Added, 0, pos, s) in + let get_variant index = + let (v, _, _, _) = vinfo index in + v in + let get_str index = + let (_, _, _, s) = vinfo index in + s in + + let iter start len lt incr = begin + let src = ref start in + let dst = ref start in + while (lt !src len) do + if (get_variant !src) = dtype then begin + if (lt !dst !src) then + dst := !src; + while (lt !dst len) && (get_variant !dst) <> `Common do + dst := !dst + incr; + done; + if (lt !dst len) && (get_str !src) = (get_str !dst) then begin + (* swap diff *) + let (_, c_opos, c_npos, str) = vinfo !dst + and (_, v_opos, v_npos, _) = vinfo !src in + changed := true; + if dtype = `Added then begin + diffs.(!src) <- `Common (c_opos, v_npos, str); + diffs.(!dst) <- `Added (c_npos, str); + end else begin + diffs.(!src) <- `Common (v_opos, c_npos, str); + diffs.(!dst) <- `Removed (c_opos, str) + end + end + end; + src := !src + incr + done + end in + + iter 0 len (<) 1; (* left to right *) + iter (len-1) (-1) (>) (-1); (* right to left *) + if !changed then Array.to_list diffs else diff_list;; + +let has_changes diffs = + let rec has_changes_r diffs added removed = + match diffs with + | `Added _ :: t -> has_changes_r t true removed + | `Removed _ :: t -> has_changes_r t added true + | h :: t -> has_changes_r t added removed + | [] -> (added, removed) in + has_changes_r diffs false false;; + +(* get the Myers diff of 2 lists of strings *) +let diff_strs old_strs new_strs = + let diffs = List.rev (StringDiff.diff old_strs new_strs) in + shorten_diff_span `Removed (shorten_diff_span `Added diffs);; + +(* Default string tokenizer. Makes each character a separate strin. +Whitespace is not ignored. Doesn't handle UTF-8 differences well. *) +let def_tokenize_string s = + let limit = (String.length s) - 1 in + let strs : string list ref = ref [] in + for i = 0 to limit do + strs := (String.make 1 s.[i]) :: !strs + done; + List.rev !strs + +(* get the Myers diff of 2 strings *) +let diff_str ?(tokenize_string=def_tokenize_string) old_str new_str = + let old_toks = Array.of_list (tokenize_string old_str) + and new_toks = Array.of_list (tokenize_string new_str) in + diff_strs old_toks new_toks;; + +let get_dinfo = function + | `Common (_, _, s) -> (`Common, s) + | `Removed (_, s) -> (`Removed, s) + | `Added (_, s) -> (`Added, s) + +[@@@ocaml.warning "-32"] +let string_of_diff_type = function + | `Common -> "Common" + | `Removed -> "Removed" + | `Added -> "Added" +[@@@ocaml.warning "+32"] + +let wrap_in_bg diff_tag pp = + let open Pp in + (tag (Pp.start_pfx ^ diff_tag ^ ".bg") (str "")) ++ pp ++ + (tag (Pp.end_pfx ^ diff_tag ^ ".bg") (str "")) + +exception Diff_Failure of string + +let add_diff_tags which pp diffs = + let open Pp in + let diff_tag = if which = `Added then "diff.added" else "diff.removed" in + let diffs : diff_list ref = ref diffs in + let in_diff = ref false in (* true = buf chars need a tag *) + let in_span = ref false in (* true = last pp had a start tag *) + let trans = ref false in (* true = this diff starts/ends highlight *) + let buf = Buffer.create 16 in + let acc_pp = ref [] in + let diff_str, diff_ind, diff_len = ref "", ref 0, ref 0 in + let prev_dtype, dtype, next_dtype = ref `Common, ref `Common, ref `Common in + let is_white c = List.mem c [' '; '\t'; '\n'; '\r'] in + + let skip () = + while !diffs <> [] && + (let (t, _) = get_dinfo (List.hd !diffs) in + t <> `Common && t <> which) + do + diffs := List.tl !diffs + done + in + + let put_tagged case = + if Buffer.length buf > 0 then begin + let pp = str (Buffer.contents buf) in + Buffer.clear buf; + let tagged = match case with + | "" -> pp + | "tag" -> tag diff_tag pp + | "start" -> in_span := true; tag (start_pfx ^ diff_tag) pp + | "end" -> in_span := false; tag (end_pfx ^ diff_tag) pp + | _ -> raise (Diff_Failure "invalid tag id in put_tagged, should be impossible") in + acc_pp := tagged :: !acc_pp + end + in + + let output_pps () = + let next_diff_char_hl = if !diff_ind < !diff_len then !dtype = which else !next_dtype = which in + let tag = if not !in_diff then "" + else if !in_span then + if next_diff_char_hl then "" else "end" + else + if next_diff_char_hl then "start" else "tag" in + put_tagged tag; (* flush any remainder *) + let l = !acc_pp in + acc_pp := []; + match List.length l with + | 0 -> str "" + | 1 -> List.hd l + | _ -> seq (List.rev l) + in + + let maybe_next_diff () = + if !diff_ind = !diff_len && (skip(); !diffs <> []) then begin + let (t, s) = get_dinfo (List.hd !diffs) in + diff_str := s; diff_ind := 0; diff_len := String.length !diff_str; + diffs := List.tl !diffs; skip(); + prev_dtype := !dtype; + dtype := t; + next_dtype := (match !diffs with + | diff2 :: _ -> let (nt, _) = get_dinfo diff2 in nt + | [] -> `Common); + trans := !dtype <> !prev_dtype + end; + in + + let s_char c = + maybe_next_diff (); + (* matching first should handle tokens with spaces, e.g. in comments/strings *) + if !diff_ind < !diff_len && c = !diff_str.[!diff_ind] then begin + if !dtype = which && !trans && !diff_ind = 0 then begin + put_tagged ""; + in_diff := true + end; + Buffer.add_char buf c; + diff_ind := !diff_ind + 1; + if !dtype = which && !dtype <> !next_dtype && !diff_ind = !diff_len then begin + put_tagged (if !in_span then "end" else "tag"); + in_diff := false + end + end else if is_white c then + Buffer.add_char buf c + else begin + cprintf "mismatch: expected '%c' but got '%c'\n" !diff_str.[!diff_ind] c; + raise (Diff_Failure "string mismatch, shouldn't happen") + end + in + + (* rearrange so existing tags are inside diff tags, provided that those tags + only contain Ppcmd_string's. Other cases (e.g. tag of a box) are not supported. *) + (* todo: Is there a better way to do this in OCaml without multiple 'repr's? *) + let reorder_tags child pp_tag pp = + match repr child with + | Ppcmd_tag (t1, pp) -> tag t1 (tag pp_tag pp) + | Ppcmd_glue l -> + if List.exists (fun x -> + match repr x with + | Ppcmd_tag (_, _) -> true + | _ -> false) l + then seq (List.map (fun x -> + match repr x with + | Ppcmd_tag (t2, pp2) -> tag t2 (tag pp_tag pp2) + | pp2 -> tag pp_tag (unrepr pp2)) l) + else child + | _ -> tag pp_tag child + in + + let rec add_tags_r pp = + let r_pp = repr pp in + match r_pp with + | Ppcmd_string s -> String.iter s_char s; output_pps () + | Ppcmd_glue l -> seq (List.map add_tags_r l) + | Ppcmd_box (block_type, pp) -> unrepr (Ppcmd_box (block_type, add_tags_r pp)) + | Ppcmd_tag (pp_tag, pp) -> reorder_tags (add_tags_r pp) pp_tag pp + | _ -> pp + in + let (has_added, has_removed) = has_changes !diffs in + let rv = add_tags_r pp in + skip (); + if !diffs <> [] then + raise (Diff_Failure "left-over diff info at end of Pp.t, should be impossible"); + if has_added || has_removed then wrap_in_bg diff_tag rv else rv;; + +let diff_pp ?(tokenize_string=def_tokenize_string) o_pp n_pp = + let open Pp in + let o_str = string_of_ppcmds o_pp in + let n_str = string_of_ppcmds n_pp in + let diffs = diff_str ~tokenize_string o_str n_str in + (add_diff_tags `Removed o_pp diffs, add_diff_tags `Added n_pp diffs);; + +let diff_pp_combined ?(tokenize_string=def_tokenize_string) ?(show_removed=false) o_pp n_pp = + let open Pp in + let o_str = string_of_ppcmds o_pp in + let n_str = string_of_ppcmds n_pp in + let diffs = diff_str ~tokenize_string o_str n_str in + let (_, has_removed) = has_changes diffs in + let added = add_diff_tags `Added n_pp diffs in + if show_removed && has_removed then + let removed = add_diff_tags `Removed o_pp diffs in + (v 0 (removed ++ cut() ++ added)) + else added;; diff --git a/lib/pp_diff.mli b/lib/pp_diff.mli new file mode 100644 index 0000000000..03468271d2 --- /dev/null +++ b/lib/pp_diff.mli @@ -0,0 +1,116 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** +Computes the differences between 2 Pp's and adds additional tags to a Pp +to highlight them. Strings are split into tokens using the Coq lexer, +then the lists of tokens are diffed using the Myers algorithm. A fixup routine, +shorten_diff_span, shortens the span of the diff result in some cases. + +Highlights use 4 tags to specify the color and underline/strikeout. These are +"diffs.added", "diffs.removed", "diffs.added.bg" and "diffs.removed.bg". The +first two are for added or removed text; the last two are for unmodified parts +of a modified item. Diffs that span multiple strings in the Pp are tagged with +"start.diff.*" and "end.diff.*", but only on the first and last strings of the span. + +If the inputs are not acceptable to the lexer, break the strings into +lists of tokens and call diff_strs, then add_diff_tags with a Pp.t that matches +the input lists of strings. Tokens that the lexer doesn't return exactly as they +appeared in the input will raise an exception in add_diff_tags (e.g. comments +and quoted strings). Fixing that requires tweaking the lexer. + +Limitations/Possible enhancements: + +- Make diff_pp immune to unlexable strings by adding a flag to the lexer. +*) + +(** Compute the diff between two Pp.t structures and return +versions of each with diffs highlighted as (old, new) *) +val diff_pp : ?tokenize_string:(string -> string list) -> Pp.t -> Pp.t -> Pp.t * Pp.t + +(** Compute the diff between two Pp.t structures and return +a highlighted Pp.t. If [show_removed] is true, show separate lines for +removals and additions, otherwise only show additions *) +val diff_pp_combined : ?tokenize_string:(string -> string list) -> ?show_removed:bool -> Pp.t -> Pp.t -> Pp.t + +(** Raised if the diff fails *) +exception Diff_Failure of string + +module StringDiff : +sig + type elem = String.t + type t = elem array +end + +type diff_type = + [ `Removed + | `Added + | `Common + ] + +type diff_list = StringDiff.elem Diff2.edit list + +(** Compute the difference between 2 strings in terms of tokens, using the +lexer to identify tokens. + +If the strings are not lexable, this routine will raise Diff_Failure. +(I expect to modify the lexer soon so this won't happen.) + +Therefore you should catch any exceptions. The workaround for now is for the +caller to tokenize the strings itself and then call diff_strs. +*) +val diff_str : ?tokenize_string:(string -> string list) -> string -> string -> StringDiff.elem Diff2.edit list + +(** Compute the differences between 2 lists of strings, treating the strings +in the lists as indivisible units. +*) +val diff_strs : StringDiff.t -> StringDiff.t -> StringDiff.elem Diff2.edit list + +(** Generate a new Pp that adds tags marking diffs to a Pp structure: +which: either `Added or `Removed, indicates which type of diffs to add +pp: the original structure. For `Added, must be the new pp passed to diff_pp + For `Removed, must be the old pp passed to diff_pp. Passing the wrong one + will likely raise Diff_Failure. +diffs: the diff list returned by diff_pp + +Diffs of single strings in the Pp are tagged with "diff.added" or "diff.removed". +Diffs that span multiple strings in the Pp are tagged with "start.diff.*" or +"end.diff.*", but only on the first and last strings of the span. + +Ppcmd_strings will be split into multiple Ppcmd_strings if a diff starts or ends +in the middle of the string. Whitespace just before or just after a diff will +not be part of the highlight. + +Prexisting tags in pp may contain only a single Ppcmd_string. Those tags will be +placed inside the diff tags to ensure proper nesting of tags within spans of +"start.diff.*" ... "end.diff.*". + +Under some "impossible" conditions, this routine may raise Diff_Failure. +If you want to make your call especially bulletproof, catch this +exception, print a user-visible message, then recall this routine with +the first argument set to None, which will skip the diff. +*) +val add_diff_tags : diff_type -> Pp.t -> StringDiff.elem Diff2.edit list -> Pp.t + +(** Returns a boolean pair (added, removed) for [diffs] where a true value +indicates that something was added/removed in the diffs. +*) +val has_changes : diff_list -> bool * bool + +val get_dinfo : StringDiff.elem Diff2.edit -> diff_type * string + +(** Returns a modified [pp] with the background highlighted with +"start.<diff_tag>.bg" and "end.<diff_tag>.bg" tags at the beginning +and end of the returned Pp.t +*) +val wrap_in_bg : string -> Pp.t -> Pp.t + +(** Displays the diffs to a printable format for debugging *) +val string_of_diffs : diff_list -> string diff --git a/library/goptions.ml b/library/goptions.ml index f14ad333e9..eafcb8fea6 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -318,26 +318,35 @@ let set_option_value ?(locality = OptDefault) check_and_cast key v = | Some (name, depr, (read,write,append)) -> write locality (check_and_cast v (read ())) -let bad_type_error () = user_err Pp.(str "Bad type of value for this option.") +let show_value_type = function + | BoolValue _ -> "bool" + | IntValue _ -> "int" + | StringValue _ -> "string" + | StringOptValue _ -> "string" + +let bad_type_error opt_value actual_type = + user_err Pp.(str "Bad type of value for this option:" ++ spc() ++ + str "expected " ++ str (show_value_type opt_value) ++ + str ", got " ++ str actual_type ++ str ".") let check_int_value v = function | IntValue _ -> IntValue v - | _ -> bad_type_error () + | optv -> bad_type_error optv "int" let check_bool_value v = function | BoolValue _ -> BoolValue v - | _ -> bad_type_error () + | optv -> bad_type_error optv "bool" let check_string_value v = function | StringValue _ -> StringValue v | StringOptValue _ -> StringOptValue (Some v) - | _ -> bad_type_error () + | optv -> bad_type_error optv "string" let check_unset_value v = function | BoolValue _ -> BoolValue false | IntValue _ -> IntValue None | StringOptValue _ -> StringOptValue None - | _ -> bad_type_error () + | optv -> bad_type_error optv "nothing" (* Nota: For compatibility reasons, some errors are treated as warning. This allows a script to refer to an option that doesn't diff --git a/library/lib.ml b/library/lib.ml index a20de55bf6..8ebe44890c 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -26,13 +26,11 @@ type node = | Leaf of obj | CompilingLibrary of object_prefix | OpenedModule of is_type * export * object_prefix * Summary.frozen - | ClosedModule of library_segment | OpenedSection of object_prefix * Summary.frozen - | ClosedSection of library_segment -and library_entry = object_name * node +type library_entry = object_name * node -and library_segment = library_entry list +type library_segment = library_entry list type lib_objects = (Names.Id.t * obj) list @@ -73,10 +71,6 @@ let classify_segment seg = clean ((id,o')::substl, keepl, anticipl) stk | Anticipate o' -> clean (substl, keepl, o'::anticipl) stk) - | (_,ClosedSection _) :: stk -> clean acc stk - (* LEM; TODO: Understand what this does and see if what I do is the - correct thing for ClosedMod(ule|type) *) - | (_,ClosedModule _) :: stk -> clean acc stk | (_,OpenedSection _) :: _ -> user_err Pp.(str "there are still opened sections") | (_,OpenedModule (ty,_,_,_)) :: _ -> user_err ~hdr:"Lib.classify_segment" @@ -307,7 +301,6 @@ let end_mod is_type = in let (after,mark,before) = split_lib_at_opening oname in lib_state := { !lib_state with lib_stk = before }; - add_entry oname (ClosedModule (List.rev (mark::after))); let prefix = !lib_state.path_prefix in recalc_path_prefix (); (oname, prefix, fs, after) @@ -555,7 +548,6 @@ let discharge_item ((sp,_ as oname),e) = match e with | Leaf lobj -> Option.map (fun o -> (basename sp,o)) (discharge_object (oname,lobj)) - | ClosedSection _ | ClosedModule _ -> None | OpenedSection _ | OpenedModule _ | CompilingLibrary _ -> anomaly (Pp.str "discharge_item.") @@ -570,7 +562,6 @@ let close_section () = let (secdecls,mark,before) = split_lib_at_opening oname in lib_state := { !lib_state with lib_stk = before }; pop_path_prefix (); - add_entry oname (ClosedSection (List.rev (mark::secdecls))); let newdecls = List.map discharge_item secdecls in Summary.unfreeze_summaries fs; List.iter (Option.iter (fun (id,o) -> add_discharged_leaf id o)) newdecls @@ -589,10 +580,8 @@ let freeze ~marshallable = | n, (CompilingLibrary _ as x) -> Some (n,x) | n, OpenedModule (it,e,op,_) -> Some(n,OpenedModule(it,e,op,Summary.empty_frozen)) - | n, ClosedModule _ -> Some (n,ClosedModule []) | n, OpenedSection (op, _) -> - Some(n,OpenedSection(op,Summary.empty_frozen)) - | n, ClosedSection _ -> Some (n,ClosedSection [])) + Some(n,OpenedSection(op,Summary.empty_frozen))) !lib_state.lib_stk in { !lib_state with lib_stk } | _ -> @@ -656,6 +645,14 @@ let discharge_kn kn = let discharge_con cst = if con_defined_in_sec cst then Globnames.pop_con cst else cst +let discharge_proj_repr = + Projection.Repr.map_npars (fun mind npars -> + if not (defined_in_sec mind) then mind, npars + else + let modlist = replacement_context () in + let _, newpars = Mindmap.find mind (snd modlist) in + Globnames.pop_kn mind, npars + Array.length newpars) + let discharge_inductive (kn,i) = (discharge_kn kn,i) diff --git a/library/lib.mli b/library/lib.mli index 5abfccfc7d..9933b762ba 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -23,11 +23,9 @@ type node = | Leaf of Libobject.obj | CompilingLibrary of Libnames.object_prefix | OpenedModule of is_type * export * Libnames.object_prefix * Summary.frozen - | ClosedModule of library_segment | OpenedSection of Libnames.object_prefix * Summary.frozen - | ClosedSection of library_segment -and library_segment = (Libnames.object_name * node) list +type library_segment = (Libnames.object_name * node) list type lib_objects = (Id.t * Libobject.obj) list @@ -189,6 +187,7 @@ val replacement_context : unit -> Opaqueproof.work_list val discharge_kn : MutInd.t -> MutInd.t val discharge_con : Constant.t -> Constant.t +val discharge_proj_repr : Projection.Repr.t -> Projection.Repr.t val discharge_global : GlobRef.t -> GlobRef.t val discharge_inductive : inductive -> inductive val discharge_abstract_universe_context : diff --git a/library/library.mllib b/library/library.mllib index 2ac4266fc0..9cacaba4a7 100644 --- a/library/library.mllib +++ b/library/library.mllib @@ -14,6 +14,5 @@ Kindops Dischargedhypsmap Goptions Decls -Heads Keys Coqlib diff --git a/plugins/.merlin b/plugins/.merlin.in index 2ba6169622..2ba6169622 100644 --- a/plugins/.merlin +++ b/plugins/.merlin.in diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 4a691e442c..ce620d5312 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -460,7 +460,7 @@ let rec canonize_name sigma c = mkApp (func ct,Array.Smart.map func l) | Proj(p,c) -> let p' = Projection.map (fun kn -> - Constant.make1 (Constant.canonical kn)) p in + MutInd.make1 (MutInd.canonical kn)) p in (mkProj (p', func c)) | _ -> c diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 04ff11fc49..2eaa6146e1 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -84,8 +84,8 @@ let rec decompose_term env sigma t= let canon_const = Constant.make1 (Constant.canonical c) in (Symb (Constr.mkConstU (canon_const,u))) | Proj (p, c) -> - let canon_const kn = Constant.make1 (Constant.canonical kn) in - let p' = Projection.map canon_const p in + let canon_mind kn = MutInd.make1 (MutInd.canonical kn) in + let p' = Projection.map canon_mind p in let c = Retyping.expand_projection env sigma p' c [] in decompose_term env sigma c | _ -> diff --git a/plugins/extraction/ExtrHaskellString.v b/plugins/extraction/ExtrHaskellString.v index ac1f6f9130..a4a40d3c5a 100644 --- a/plugins/extraction/ExtrHaskellString.v +++ b/plugins/extraction/ExtrHaskellString.v @@ -35,6 +35,8 @@ Extract Inductive ascii => "Prelude.Char" (Data.Bits.testBit (Data.Char.ord a) 6) (Data.Bits.testBit (Data.Char.ord a) 7))". Extract Inlined Constant Ascii.ascii_dec => "(Prelude.==)". +Extract Inlined Constant Ascii.eqb => "(Prelude.==)". Extract Inductive string => "Prelude.String" [ "([])" "(:)" ]. Extract Inlined Constant String.string_dec => "(Prelude.==)". +Extract Inlined Constant String.eqb => "(Prelude.==)". diff --git a/plugins/extraction/ExtrOcamlString.v b/plugins/extraction/ExtrOcamlString.v index 030b486b26..a2a6a8fe67 100644 --- a/plugins/extraction/ExtrOcamlString.v +++ b/plugins/extraction/ExtrOcamlString.v @@ -33,6 +33,7 @@ Extract Constant shift => "fun b c -> Char.chr (((Char.code c) lsl 1) land 255 + if b then 1 else 0)". Extract Inlined Constant ascii_dec => "(=)". +Extract Inlined Constant Ascii.eqb => "(=)". Extract Inductive string => "char list" [ "[]" "(::)" ]. diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 71e09992cc..67c605ea1d 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -1065,13 +1065,13 @@ let extract_constant env kn cb = (match cb.const_body with | Undef _ -> warn_info (); mk_typ_ax () | Def c -> - (match Environ.is_projection kn env with - | false -> mk_typ (get_body c) - | true -> - let pb = lookup_projection (Projection.make kn false) env in - let ind = pb.Declarations.proj_ind in + (match Recordops.find_primitive_projection kn with + | None -> mk_typ (get_body c) + | Some p -> + let p = Projection.make p false in + let ind = Projection.inductive p in let bodies = Inductiveops.legacy_match_projection env ind in - let body = bodies.(pb.Declarations.proj_arg) in + let body = bodies.(Projection.arg p) in mk_typ (EConstr.of_constr body)) | OpaqueDef c -> add_opaque r; @@ -1081,13 +1081,13 @@ let extract_constant env kn cb = (match cb.const_body with | Undef _ -> warn_info (); mk_ax () | Def c -> - (match Environ.is_projection kn env with - | false -> mk_def (get_body c) - | true -> - let pb = lookup_projection (Projection.make kn false) env in - let ind = pb.Declarations.proj_ind in + (match Recordops.find_primitive_projection kn with + | None -> mk_def (get_body c) + | Some p -> + let p = Projection.make p false in + let ind = Projection.inductive p in let bodies = Inductiveops.legacy_match_projection env ind in - let body = bodies.(pb.Declarations.proj_arg) in + let body = bodies.(Projection.arg p) in mk_def (EConstr.of_constr body)) | OpaqueDef c -> add_opaque r; diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml index 4e3ba57308..516b04ea21 100644 --- a/plugins/firstorder/ground.ml +++ b/plugins/firstorder/ground.ml @@ -13,23 +13,21 @@ open Formula open Sequent open Rules open Instances -open Constr open Tacmach.New open Tacticals.New +open Globnames let update_flags ()= - let predref=ref Names.Cpred.empty in - let f coe= - try - let kn= fst (destConst (Classops.get_coercion_value coe)) in - predref:=Names.Cpred.add kn !predref - with DestKO -> () + let f acc coe = + match coe.Classops.coe_value with + | ConstRef c -> Names.Cpred.add c acc + | _ -> acc in - List.iter f (Classops.coercions ()); + let pred = List.fold_left f Names.Cpred.empty (Classops.coercions ()) in red_flags:= CClosure.RedFlags.red_add_transparent CClosure.betaiotazeta - (Names.Id.Pred.full,Names.Cpred.complement !predref) + (Names.Id.Pred.full,Names.Cpred.complement pred) let ground_tac solver startseq = Proofview.Goal.enter begin fun gl -> diff --git a/plugins/fourier/Fourier.v b/plugins/fourier/Fourier.v deleted file mode 100644 index 07f32be8e6..0000000000 --- a/plugins/fourier/Fourier.v +++ /dev/null @@ -1,20 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(* "Fourier's method to solve linear inequations/equations systems.".*) - -Require Export Field. -Require Export DiscrR. -Require Export Fourier_util. -Declare ML Module "fourier_plugin". - -Ltac fourier := abstract (compute [IZR IPR IPR_2] in *; fourierz; field; discrR). - -Ltac fourier_eq := apply Rge_antisym; fourier. diff --git a/plugins/fourier/Fourier_util.v b/plugins/fourier/Fourier_util.v deleted file mode 100644 index d3159698b1..0000000000 --- a/plugins/fourier/Fourier_util.v +++ /dev/null @@ -1,222 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -Require Export Rbase. -Comments "Lemmas used by the tactic Fourier". - -Open Scope R_scope. - -Lemma Rfourier_lt : forall x1 y1 a:R, x1 < y1 -> 0 < a -> a * x1 < a * y1. -intros; apply Rmult_lt_compat_l; assumption. -Qed. - -Lemma Rfourier_le : forall x1 y1 a:R, x1 <= y1 -> 0 < a -> a * x1 <= a * y1. -red. -intros. -case H; auto with real. -Qed. - -Lemma Rfourier_lt_lt : - forall x1 y1 x2 y2 a:R, - x1 < y1 -> x2 < y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2. -intros x1 y1 x2 y2 a H H0 H1; try assumption. -apply Rplus_lt_compat. -try exact H. -apply Rfourier_lt. -try exact H0. -try exact H1. -Qed. - -Lemma Rfourier_lt_le : - forall x1 y1 x2 y2 a:R, - x1 < y1 -> x2 <= y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2. -intros x1 y1 x2 y2 a H H0 H1; try assumption. -case H0; intros. -apply Rplus_lt_compat. -try exact H. -apply Rfourier_lt; auto with real. -rewrite H2. -rewrite (Rplus_comm y1 (a * y2)). -rewrite (Rplus_comm x1 (a * y2)). -apply Rplus_lt_compat_l. -try exact H. -Qed. - -Lemma Rfourier_le_lt : - forall x1 y1 x2 y2 a:R, - x1 <= y1 -> x2 < y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2. -intros x1 y1 x2 y2 a H H0 H1; try assumption. -case H; intros. -apply Rfourier_lt_le; auto with real. -rewrite H2. -apply Rplus_lt_compat_l. -apply Rfourier_lt; auto with real. -Qed. - -Lemma Rfourier_le_le : - forall x1 y1 x2 y2 a:R, - x1 <= y1 -> x2 <= y2 -> 0 < a -> x1 + a * x2 <= y1 + a * y2. -intros x1 y1 x2 y2 a H H0 H1; try assumption. -case H0; intros. -red. -left; try assumption. -apply Rfourier_le_lt; auto with real. -rewrite H2. -case H; intros. -red. -left; try assumption. -rewrite (Rplus_comm x1 (a * y2)). -rewrite (Rplus_comm y1 (a * y2)). -apply Rplus_lt_compat_l. -try exact H3. -rewrite H3. -red. -right; try assumption. -auto with real. -Qed. - -Lemma Rlt_zero_pos_plus1 : forall x:R, 0 < x -> 0 < 1 + x. -intros x H; try assumption. -rewrite Rplus_comm. -apply Rle_lt_0_plus_1. -red; auto with real. -Qed. - -Lemma Rlt_mult_inv_pos : forall x y:R, 0 < x -> 0 < y -> 0 < x * / y. -intros x y H H0; try assumption. -replace 0 with (x * 0). -apply Rmult_lt_compat_l; auto with real. -ring. -Qed. - -Lemma Rlt_zero_1 : 0 < 1. -exact Rlt_0_1. -Qed. - -Lemma Rle_zero_pos_plus1 : forall x:R, 0 <= x -> 0 <= 1 + x. -intros x H; try assumption. -case H; intros. -red. -left; try assumption. -apply Rlt_zero_pos_plus1; auto with real. -rewrite <- H0. -replace (1 + 0) with 1. -red; left. -exact Rlt_zero_1. -ring. -Qed. - -Lemma Rle_mult_inv_pos : forall x y:R, 0 <= x -> 0 < y -> 0 <= x * / y. -intros x y H H0; try assumption. -case H; intros. -red; left. -apply Rlt_mult_inv_pos; auto with real. -rewrite <- H1. -red; right; ring. -Qed. - -Lemma Rle_zero_1 : 0 <= 1. -red; left. -exact Rlt_zero_1. -Qed. - -Lemma Rle_not_lt : forall n d:R, 0 <= n * / d -> ~ 0 < - n * / d. -intros n d H; red; intros H0; try exact H0. -generalize (Rgt_not_le 0 (n * / d)). -intros H1; elim H1; try assumption. -replace (n * / d) with (- - (n * / d)). -replace 0 with (- -0). -replace (- (n * / d)) with (- n * / d). -replace (-0) with 0. -red. -apply Ropp_gt_lt_contravar. -red. -exact H0. -ring. -ring. -ring. -ring. -Qed. - -Lemma Rnot_lt0 : forall x:R, ~ 0 < 0 * x. -intros x; try assumption. -replace (0 * x) with 0. -apply Rlt_irrefl. -ring. -Qed. - -Lemma Rlt_not_le_frac_opp : forall n d:R, 0 < n * / d -> ~ 0 <= - n * / d. -intros n d H; try assumption. -apply Rgt_not_le. -replace 0 with (-0). -replace (- n * / d) with (- (n * / d)). -apply Ropp_lt_gt_contravar. -try exact H. -ring. -ring. -Qed. - -Lemma Rnot_lt_lt : forall x y:R, ~ 0 < y - x -> ~ x < y. -unfold not; intros. -apply H. -apply Rplus_lt_reg_l with x. -replace (x + 0) with x. -replace (x + (y - x)) with y. -try exact H0. -ring. -ring. -Qed. - -Lemma Rnot_le_le : forall x y:R, ~ 0 <= y - x -> ~ x <= y. -unfold not; intros. -apply H. -case H0; intros. -left. -apply Rplus_lt_reg_l with x. -replace (x + 0) with x. -replace (x + (y - x)) with y. -try exact H1. -ring. -ring. -right. -rewrite H1; ring. -Qed. - -Lemma Rfourier_gt_to_lt : forall x y:R, y > x -> x < y. -unfold Rgt; intros; assumption. -Qed. - -Lemma Rfourier_ge_to_le : forall x y:R, y >= x -> x <= y. -intros x y; exact (Rge_le y x). -Qed. - -Lemma Rfourier_eqLR_to_le : forall x y:R, x = y -> x <= y. -exact Req_le. -Qed. - -Lemma Rfourier_eqRL_to_le : forall x y:R, y = x -> x <= y. -exact Req_le_sym. -Qed. - -Lemma Rfourier_not_ge_lt : forall x y:R, (x >= y -> False) -> x < y. -exact Rnot_ge_lt. -Qed. - -Lemma Rfourier_not_gt_le : forall x y:R, (x > y -> False) -> x <= y. -exact Rnot_gt_le. -Qed. - -Lemma Rfourier_not_le_gt : forall x y:R, (x <= y -> False) -> x > y. -exact Rnot_le_lt. -Qed. - -Lemma Rfourier_not_lt_ge : forall x y:R, (x < y -> False) -> x >= y. -exact Rnot_lt_ge. -Qed. diff --git a/plugins/fourier/fourier.ml b/plugins/fourier/fourier.ml deleted file mode 100644 index bee2b3b581..0000000000 --- a/plugins/fourier/fourier.ml +++ /dev/null @@ -1,204 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(* Méthode d'élimination de Fourier *) -(* Référence: -Auteur(s) : Fourier, Jean-Baptiste-Joseph - -Titre(s) : Oeuvres de Fourier [Document électronique]. Tome second. Mémoires publiés dans divers recueils / publ. par les soins de M. Gaston Darboux,... - -Publication : Numérisation BnF de l'édition de Paris : Gauthier-Villars, 1890 - -Pages: 326-327 - -http://gallica.bnf.fr/ -*) - -(* Un peu de calcul sur les rationnels... -Les opérations rendent des rationnels normalisés, -i.e. le numérateur et le dénominateur sont premiers entre eux. -*) -type rational = {num:int; - den:int} -;; -let print_rational x = - print_int x.num; - print_string "/"; - print_int x.den -;; - -let rec pgcd x y = if y = 0 then x else pgcd y (x mod y);; - - -let r0 = {num=0;den=1};; -let r1 = {num=1;den=1};; - -let rnorm x = let x = (if x.den<0 then {num=(-x.num);den=(-x.den)} else x) in - if x.num=0 then r0 - else (let d=pgcd x.num x.den in - let d= (if d<0 then -d else d) in - {num=(x.num)/d;den=(x.den)/d});; - -let rop x = rnorm {num=(-x.num);den=x.den};; - -let rplus x y = rnorm {num=x.num*y.den + y.num*x.den;den=x.den*y.den};; - -let rminus x y = rnorm {num=x.num*y.den - y.num*x.den;den=x.den*y.den};; - -let rmult x y = rnorm {num=x.num*y.num;den=x.den*y.den};; - -let rinv x = rnorm {num=x.den;den=x.num};; - -let rdiv x y = rnorm {num=x.num*y.den;den=x.den*y.num};; - -let rinf x y = x.num*y.den < y.num*x.den;; -let rinfeq x y = x.num*y.den <= y.num*x.den;; - -(* {coef;hist;strict}, où coef=[c1; ...; cn; d], représente l'inéquation -c1x1+...+cnxn < d si strict=true, <= sinon, -hist donnant les coefficients (positifs) d'une combinaison linéaire qui permet d'obtenir l'inéquation à partir de celles du départ. -*) - -type ineq = {coef:rational list; - hist:rational list; - strict:bool};; - -let pop x l = l:=x::(!l);; - -(* sépare la liste d'inéquations s selon que leur premier coefficient est -négatif, nul ou positif. *) -let partitionne s = - let lpos=ref [] in - let lneg=ref [] in - let lnul=ref [] in - List.iter (fun ie -> match ie.coef with - [] -> raise (Failure "empty ineq") - |(c::r) -> if rinf c r0 - then pop ie lneg - else if rinf r0 c then pop ie lpos - else pop ie lnul) - s; - [!lneg;!lnul;!lpos] -;; -(* initialise les histoires d'une liste d'inéquations données par leurs listes de coefficients et leurs strictitudes (!): -(add_hist [(equation 1, s1);...;(équation n, sn)]) -= -[{équation 1, [1;0;...;0], s1}; - {équation 2, [0;1;...;0], s2}; - ... - {équation n, [0;0;...;1], sn}] -*) -let add_hist le = - let n = List.length le in - let i = ref 0 in - List.map (fun (ie,s) -> - let h = ref [] in - for _k = 1 to (n - (!i) - 1) do pop r0 h; done; - pop r1 h; - for _k = 1 to !i do pop r0 h; done; - i:=!i+1; - {coef=ie;hist=(!h);strict=s}) - le -;; -(* additionne deux inéquations *) -let ie_add ie1 ie2 = {coef=List.map2 rplus ie1.coef ie2.coef; - hist=List.map2 rplus ie1.hist ie2.hist; - strict=ie1.strict || ie2.strict} -;; -(* multiplication d'une inéquation par un rationnel (positif) *) -let ie_emult a ie = {coef=List.map (fun x -> rmult a x) ie.coef; - hist=List.map (fun x -> rmult a x) ie.hist; - strict= ie.strict} -;; -(* on enlève le premier coefficient *) -let ie_tl ie = {coef=List.tl ie.coef;hist=ie.hist;strict=ie.strict} -;; -(* le premier coefficient: "tête" de l'inéquation *) -let hd_coef ie = List.hd ie.coef -;; - -(* calcule toutes les combinaisons entre inéquations de tête négative et inéquations de tête positive qui annulent le premier coefficient. -*) -let deduce_add lneg lpos = - let res=ref [] in - List.iter (fun i1 -> - List.iter (fun i2 -> - let a = rop (hd_coef i1) in - let b = hd_coef i2 in - pop (ie_tl (ie_add (ie_emult b i1) - (ie_emult a i2))) res) - lpos) - lneg; - !res -;; -(* élimination de la première variable à partir d'une liste d'inéquations: -opération qu'on itère dans l'algorithme de Fourier. -*) -let deduce1 s = - match (partitionne s) with - [lneg;lnul;lpos] -> - let lnew = deduce_add lneg lpos in - (List.map ie_tl lnul)@lnew - |_->assert false -;; -(* algorithme de Fourier: on élimine successivement toutes les variables. -*) -let deduce lie = - let n = List.length (fst (List.hd lie)) in - let lie=ref (add_hist lie) in - for _i = 1 to n - 1 do - lie:= deduce1 !lie; - done; - !lie -;; - -(* donne [] si le système a des solutions, -sinon donne [c,s,lc] -où lc est la combinaison linéaire des inéquations de départ -qui donne 0 < c si s=true - ou 0 <= c sinon -cette inéquation étant absurde. -*) - -exception Contradiction of (rational * bool * rational list) list - -let unsolvable lie = - let lr = deduce lie in - let check = function - | {coef=[c];hist=lc;strict=s} -> - if (rinf c r0 && (not s)) || (rinfeq c r0 && s) - then raise (Contradiction [c,s,lc]) - |_->assert false - in - try List.iter check lr; [] - with Contradiction l -> l - -(* Exemples: - -let test1=[[r1;r1;r0],true;[rop r1;r1;r1],false;[r0;rop r1;rop r1],false];; -deduce test1;; -unsolvable test1;; - -let test2=[ -[r1;r1;r0;r0;r0],false; -[r0;r1;r1;r0;r0],false; -[r0;r0;r1;r1;r0],false; -[r0;r0;r0;r1;r1],false; -[r1;r0;r0;r0;r1],false; -[rop r1;rop r1;r0;r0;r0],false; -[r0;rop r1;rop r1;r0;r0],false; -[r0;r0;rop r1;rop r1;r0],false; -[r0;r0;r0;rop r1;rop r1],false; -[rop r1;r0;r0;r0;rop r1],false -];; -deduce test2;; -unsolvable test2;; - -*) diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml deleted file mode 100644 index 96be1d8934..0000000000 --- a/plugins/fourier/fourierR.ml +++ /dev/null @@ -1,644 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - - - -(* La tactique Fourier ne fonctionne de manière sûre que si les coefficients -des inéquations et équations sont entiers. En attendant la tactique Field. -*) - -open Constr -open Tactics -open Names -open Globnames -open Fourier -open Contradiction -open Proofview.Notations - -(****************************************************************************** -Opérations sur les combinaisons linéaires affines. -La partie homogène d'une combinaison linéaire est en fait une table de hash -qui donne le coefficient d'un terme du calcul des constructions, -qui est zéro si le terme n'y est pas. -*) - -module Constrhash = Hashtbl.Make(Constr) - -type flin = {fhom: rational Constrhash.t; - fcste:rational};; - -let flin_zero () = {fhom=Constrhash.create 50;fcste=r0};; - -let flin_coef f x = try Constrhash.find f.fhom x with Not_found -> r0;; - -let flin_add f x c = - let cx = flin_coef f x in - Constrhash.replace f.fhom x (rplus cx c); - f -;; -let flin_add_cste f c = - {fhom=f.fhom; - fcste=rplus f.fcste c} -;; - -let flin_one () = flin_add_cste (flin_zero()) r1;; - -let flin_plus f1 f2 = - let f3 = flin_zero() in - Constrhash.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom; - Constrhash.iter (fun x c -> let _=flin_add f3 x c in ()) f2.fhom; - flin_add_cste (flin_add_cste f3 f1.fcste) f2.fcste; -;; - -let flin_minus f1 f2 = - let f3 = flin_zero() in - Constrhash.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom; - Constrhash.iter (fun x c -> let _=flin_add f3 x (rop c) in ()) f2.fhom; - flin_add_cste (flin_add_cste f3 f1.fcste) (rop f2.fcste); -;; -let flin_emult a f = - let f2 = flin_zero() in - Constrhash.iter (fun x c -> let _=flin_add f2 x (rmult a c) in ()) f.fhom; - flin_add_cste f2 (rmult a f.fcste); -;; - -(*****************************************************************************) - -type ineq = Rlt | Rle | Rgt | Rge - -let string_of_R_constant kn = - match Constant.repr3 kn with - | ModPath.MPfile dir, sec_dir, id when - sec_dir = DirPath.empty && - DirPath.to_string dir = "Coq.Reals.Rdefinitions" - -> Label.to_string id - | _ -> "constant_not_of_R" - -let rec string_of_R_constr c = - match Constr.kind c with - Cast (c,_,_) -> string_of_R_constr c - |Const (c,_) -> string_of_R_constant c - | _ -> "not_of_constant" - -exception NoRational - -let rec rational_of_constr c = - match Constr.kind c with - | Cast (c,_,_) -> (rational_of_constr c) - | App (c,args) -> - (match (string_of_R_constr c) with - | "Ropp" -> - rop (rational_of_constr args.(0)) - | "Rinv" -> - rinv (rational_of_constr args.(0)) - | "Rmult" -> - rmult (rational_of_constr args.(0)) - (rational_of_constr args.(1)) - | "Rdiv" -> - rdiv (rational_of_constr args.(0)) - (rational_of_constr args.(1)) - | "Rplus" -> - rplus (rational_of_constr args.(0)) - (rational_of_constr args.(1)) - | "Rminus" -> - rminus (rational_of_constr args.(0)) - (rational_of_constr args.(1)) - | _ -> raise NoRational) - | Const (kn,_) -> - (match (string_of_R_constant kn) with - "R1" -> r1 - |"R0" -> r0 - | _ -> raise NoRational) - | _ -> raise NoRational -;; - -exception NoLinear - -let rec flin_of_constr c = - try( - match Constr.kind c with - | Cast (c,_,_) -> (flin_of_constr c) - | App (c,args) -> - (match (string_of_R_constr c) with - "Ropp" -> - flin_emult (rop r1) (flin_of_constr args.(0)) - | "Rplus"-> - flin_plus (flin_of_constr args.(0)) - (flin_of_constr args.(1)) - | "Rminus"-> - flin_minus (flin_of_constr args.(0)) - (flin_of_constr args.(1)) - | "Rmult"-> - (try - let a = rational_of_constr args.(0) in - try - let b = rational_of_constr args.(1) in - flin_add_cste (flin_zero()) (rmult a b) - with NoRational -> - flin_add (flin_zero()) args.(1) a - with NoRational -> - flin_add (flin_zero()) args.(0) - (rational_of_constr args.(1))) - | "Rinv"-> - let a = rational_of_constr args.(0) in - flin_add_cste (flin_zero()) (rinv a) - | "Rdiv"-> - (let b = rational_of_constr args.(1) in - try - let a = rational_of_constr args.(0) in - flin_add_cste (flin_zero()) (rdiv a b) - with NoRational -> - flin_add (flin_zero()) args.(0) (rinv b)) - |_-> raise NoLinear) - | Const (c,_) -> - (match (string_of_R_constant c) with - "R1" -> flin_one () - |"R0" -> flin_zero () - |_-> raise NoLinear) - |_-> raise NoLinear) - with NoRational | NoLinear -> flin_add (flin_zero()) c r1 -;; - -let flin_to_alist f = - let res=ref [] in - Constrhash.iter (fun x c -> res:=(c,x)::(!res)) f; - !res -;; - -(* Représentation des hypothèses qui sont des inéquations ou des équations. -*) -type hineq={hname:constr; (* le nom de l'hypothèse *) - htype:string; (* Rlt, Rgt, Rle, Rge, eqTLR ou eqTRL *) - hleft:constr; - hright:constr; - hflin:flin; - hstrict:bool} -;; - -(* Transforme une hypothese h:t en inéquation flin<0 ou flin<=0 -*) - -exception NoIneq - -let ineq1_of_constr (h,t) = - let h = EConstr.Unsafe.to_constr h in - let t = EConstr.Unsafe.to_constr t in - match (Constr.kind t) with - | App (f,args) -> - (match Constr.kind f with - | Const (c,_) when Array.length args = 2 -> - let t1= args.(0) in - let t2= args.(1) in - (match (string_of_R_constant c) with - |"Rlt" -> [{hname=h; - htype="Rlt"; - hleft=t1; - hright=t2; - hflin= flin_minus (flin_of_constr t1) - (flin_of_constr t2); - hstrict=true}] - |"Rgt" -> [{hname=h; - htype="Rgt"; - hleft=t2; - hright=t1; - hflin= flin_minus (flin_of_constr t2) - (flin_of_constr t1); - hstrict=true}] - |"Rle" -> [{hname=h; - htype="Rle"; - hleft=t1; - hright=t2; - hflin= flin_minus (flin_of_constr t1) - (flin_of_constr t2); - hstrict=false}] - |"Rge" -> [{hname=h; - htype="Rge"; - hleft=t2; - hright=t1; - hflin= flin_minus (flin_of_constr t2) - (flin_of_constr t1); - hstrict=false}] - |_-> raise NoIneq) - | Ind ((kn,i),_) -> - if not (GlobRef.equal (IndRef(kn,i)) Coqlib.glob_eq) then raise NoIneq; - let t0= args.(0) in - let t1= args.(1) in - let t2= args.(2) in - (match (Constr.kind t0) with - | Const (c,_) -> - (match (string_of_R_constant c) with - | "R"-> - [{hname=h; - htype="eqTLR"; - hleft=t1; - hright=t2; - hflin= flin_minus (flin_of_constr t1) - (flin_of_constr t2); - hstrict=false}; - {hname=h; - htype="eqTRL"; - hleft=t2; - hright=t1; - hflin= flin_minus (flin_of_constr t2) - (flin_of_constr t1); - hstrict=false}] - |_-> raise NoIneq) - |_-> raise NoIneq) - |_-> raise NoIneq) - |_-> raise NoIneq -;; - -(* Applique la méthode de Fourier à une liste d'hypothèses (type hineq) -*) - -let fourier_lineq lineq1 = - let nvar=ref (-1) in - let hvar=Constrhash.create 50 in (* la table des variables des inéquations *) - List.iter (fun f -> - Constrhash.iter (fun x _ -> if not (Constrhash.mem hvar x) then begin - nvar:=(!nvar)+1; - Constrhash.add hvar x (!nvar) - end) - f.hflin.fhom) - lineq1; - let sys= List.map (fun h-> - let v=Array.make ((!nvar)+1) r0 in - Constrhash.iter (fun x c -> v.(Constrhash.find hvar x)<-c) - h.hflin.fhom; - ((Array.to_list v)@[rop h.hflin.fcste],h.hstrict)) - lineq1 in - unsolvable sys -;; - -(*********************************************************************) -(* Defined constants *) - -let get = Lazy.force -let cget = get -let eget c = EConstr.of_constr (Lazy.force c) -let constant path s = UnivGen.constr_of_global @@ - Coqlib.coq_reference "Fourier" path s - -(* Standard library *) -open Coqlib -let coq_sym_eqT = lazy (build_coq_eq_sym ()) -let coq_False = lazy (UnivGen.constr_of_global @@ build_coq_False ()) -let coq_not = lazy (UnivGen.constr_of_global @@ build_coq_not ()) -let coq_eq = lazy (UnivGen.constr_of_global @@ build_coq_eq ()) - -(* Rdefinitions *) -let constant_real = constant ["Reals";"Rdefinitions"] - -let coq_Rlt = lazy (constant_real "Rlt") -let coq_Rgt = lazy (constant_real "Rgt") -let coq_Rle = lazy (constant_real "Rle") -let coq_Rge = lazy (constant_real "Rge") -let coq_R = lazy (constant_real "R") -let coq_Rminus = lazy (constant_real "Rminus") -let coq_Rmult = lazy (constant_real "Rmult") -let coq_Rplus = lazy (constant_real "Rplus") -let coq_Ropp = lazy (constant_real "Ropp") -let coq_Rinv = lazy (constant_real "Rinv") -let coq_R0 = lazy (constant_real "R0") -let coq_R1 = lazy (constant_real "R1") - -(* RIneq *) -let coq_Rinv_1 = lazy (constant ["Reals";"RIneq"] "Rinv_1") - -(* Fourier_util *) -let constant_fourier = constant ["fourier";"Fourier_util"] - -let coq_Rlt_zero_1 = lazy (constant_fourier "Rlt_zero_1") -let coq_Rlt_zero_pos_plus1 = lazy (constant_fourier "Rlt_zero_pos_plus1") -let coq_Rle_zero_pos_plus1 = lazy (constant_fourier "Rle_zero_pos_plus1") -let coq_Rlt_mult_inv_pos = lazy (constant_fourier "Rlt_mult_inv_pos") -let coq_Rle_zero_zero = lazy (constant_fourier "Rle_zero_zero") -let coq_Rle_zero_1 = lazy (constant_fourier "Rle_zero_1") -let coq_Rle_mult_inv_pos = lazy (constant_fourier "Rle_mult_inv_pos") -let coq_Rnot_lt0 = lazy (constant_fourier "Rnot_lt0") -let coq_Rle_not_lt = lazy (constant_fourier "Rle_not_lt") -let coq_Rfourier_gt_to_lt = lazy (constant_fourier "Rfourier_gt_to_lt") -let coq_Rfourier_ge_to_le = lazy (constant_fourier "Rfourier_ge_to_le") -let coq_Rfourier_eqLR_to_le = lazy (constant_fourier "Rfourier_eqLR_to_le") -let coq_Rfourier_eqRL_to_le = lazy (constant_fourier "Rfourier_eqRL_to_le") - -let coq_Rfourier_not_ge_lt = lazy (constant_fourier "Rfourier_not_ge_lt") -let coq_Rfourier_not_gt_le = lazy (constant_fourier "Rfourier_not_gt_le") -let coq_Rfourier_not_le_gt = lazy (constant_fourier "Rfourier_not_le_gt") -let coq_Rfourier_not_lt_ge = lazy (constant_fourier "Rfourier_not_lt_ge") -let coq_Rfourier_lt = lazy (constant_fourier "Rfourier_lt") -let coq_Rfourier_le = lazy (constant_fourier "Rfourier_le") -let coq_Rfourier_lt_lt = lazy (constant_fourier "Rfourier_lt_lt") -let coq_Rfourier_lt_le = lazy (constant_fourier "Rfourier_lt_le") -let coq_Rfourier_le_lt = lazy (constant_fourier "Rfourier_le_lt") -let coq_Rfourier_le_le = lazy (constant_fourier "Rfourier_le_le") -let coq_Rnot_lt_lt = lazy (constant_fourier "Rnot_lt_lt") -let coq_Rnot_le_le = lazy (constant_fourier "Rnot_le_le") -let coq_Rlt_not_le_frac_opp = lazy (constant_fourier "Rlt_not_le_frac_opp") - -(****************************************************************************** -Construction de la preuve en cas de succès de la méthode de Fourier, -i.e. on obtient une contradiction. -*) -let is_int x = (x.den)=1 -;; - -(* fraction = couple (num,den) *) -let rational_to_fraction x= (x.num,x.den) -;; - -(* traduction -3 -> (Ropp (Rplus R1 (Rplus R1 R1))) -*) -let int_to_real n = - let nn=abs n in - if nn=0 - then get coq_R0 - else - (let s=ref (get coq_R1) in - for _i = 1 to (nn-1) do s:=mkApp (get coq_Rplus,[|get coq_R1;!s|]) done; - if n<0 then mkApp (get coq_Ropp, [|!s|]) else !s) -;; -(* -1/2 -> (Rmult (Ropp R1) (Rinv (Rplus R1 R1))) -*) -let rational_to_real x = - let (n,d)=rational_to_fraction x in - mkApp (get coq_Rmult, - [|int_to_real n;mkApp(get coq_Rinv,[|int_to_real d|])|]) -;; - -(* preuve que 0<n*1/d -*) -let tac_zero_inf_pos gl (n,d) = - let get = eget in - let tacn=ref (apply (get coq_Rlt_zero_1)) in - let tacd=ref (apply (get coq_Rlt_zero_1)) in - for _i = 1 to n - 1 do - tacn:=(Tacticals.New.tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacn); done; - for _i = 1 to d - 1 do - tacd:=(Tacticals.New.tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacd); done; - (Tacticals.New.tclTHENS (apply (get coq_Rlt_mult_inv_pos)) [!tacn;!tacd]) -;; - -(* preuve que 0<=n*1/d -*) -let tac_zero_infeq_pos gl (n,d)= - let get = eget in - let tacn=ref (if n=0 - then (apply (get coq_Rle_zero_zero)) - else (apply (get coq_Rle_zero_1))) in - let tacd=ref (apply (get coq_Rlt_zero_1)) in - for _i = 1 to n - 1 do - tacn:=(Tacticals.New.tclTHEN (apply (get coq_Rle_zero_pos_plus1)) !tacn); done; - for _i = 1 to d - 1 do - tacd:=(Tacticals.New.tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacd); done; - (Tacticals.New.tclTHENS (apply (get coq_Rle_mult_inv_pos)) [!tacn;!tacd]) -;; - -(* preuve que 0<(-n)*(1/d) => False -*) -let tac_zero_inf_false gl (n,d) = - let get = eget in -if n=0 then (apply (get coq_Rnot_lt0)) - else - (Tacticals.New.tclTHEN (apply (get coq_Rle_not_lt)) - (tac_zero_infeq_pos gl (-n,d))) -;; - -(* preuve que 0<=(-n)*(1/d) => False -*) -let tac_zero_infeq_false gl (n,d) = - let get = eget in - (Tacticals.New.tclTHEN (apply (get coq_Rlt_not_le_frac_opp)) - (tac_zero_inf_pos gl (-n,d))) -;; - -let exact = exact_check;; - -let tac_use h = - let get = eget in - let tac = exact (EConstr.of_constr h.hname) in - match h.htype with - "Rlt" -> tac - |"Rle" -> tac - |"Rgt" -> (Tacticals.New.tclTHEN (apply (get coq_Rfourier_gt_to_lt)) tac) - |"Rge" -> (Tacticals.New.tclTHEN (apply (get coq_Rfourier_ge_to_le)) tac) - |"eqTLR" -> (Tacticals.New.tclTHEN (apply (get coq_Rfourier_eqLR_to_le)) tac) - |"eqTRL" -> (Tacticals.New.tclTHEN (apply (get coq_Rfourier_eqRL_to_le)) tac) - |_->assert false -;; - -(* -let is_ineq (h,t) = - match (Constr.kind t) with - App (f,args) -> - (match (string_of_R_constr f) with - "Rlt" -> true - | "Rgt" -> true - | "Rle" -> true - | "Rge" -> true -(* Wrong:not in Rdefinitions: *) | "eqT" -> - (match (string_of_R_constr args.(0)) with - "R" -> true - | _ -> false) - | _ ->false) - |_->false -;; -*) - -let list_of_sign s = - let open Context.Named.Declaration in - List.map (function LocalAssum (name, typ) -> name, typ - | LocalDef (name, _, typ) -> name, typ) - s;; - -let mkAppL a = - let l = Array.to_list a in - mkApp(List.hd l, Array.of_list (List.tl l)) -;; - -exception GoalDone - -(* Résolution d'inéquations linéaires dans R *) -let rec fourier () = - Proofview.Goal.nf_enter begin fun gl -> - let concl = Proofview.Goal.concl gl in - let sigma = Tacmach.New.project gl in - Coqlib.check_required_library ["Coq";"fourier";"Fourier"]; - let goal = Termops.strip_outer_cast sigma concl in - let goal = EConstr.Unsafe.to_constr goal in - let fhyp=Id.of_string "new_hyp_for_fourier" in - (* si le but est une inéquation, on introduit son contraire, - et le but à prouver devient False *) - try - match (Constr.kind goal) with - App (f,args) -> - let get = eget in - (match (string_of_R_constr f) with - "Rlt" -> - (Tacticals.New.tclTHEN - (Tacticals.New.tclTHEN (apply (get coq_Rfourier_not_ge_lt)) - (intro_using fhyp)) - (fourier ())) - |"Rle" -> - (Tacticals.New.tclTHEN - (Tacticals.New.tclTHEN (apply (get coq_Rfourier_not_gt_le)) - (intro_using fhyp)) - (fourier ())) - |"Rgt" -> - (Tacticals.New.tclTHEN - (Tacticals.New.tclTHEN (apply (get coq_Rfourier_not_le_gt)) - (intro_using fhyp)) - (fourier ())) - |"Rge" -> - (Tacticals.New.tclTHEN - (Tacticals.New.tclTHEN (apply (get coq_Rfourier_not_lt_ge)) - (intro_using fhyp)) - (fourier ())) - |_-> raise GoalDone) - |_-> raise GoalDone - with GoalDone -> - (* les hypothèses *) - let hyps = List.map (fun (h,t)-> (EConstr.mkVar h,t)) - (list_of_sign (Proofview.Goal.hyps gl)) in - let lineq =ref [] in - List.iter (fun h -> try (lineq:=(ineq1_of_constr h)@(!lineq)) - with NoIneq -> ()) - hyps; - (* lineq = les inéquations découlant des hypothèses *) - if !lineq=[] then CErrors.user_err Pp.(str "No inequalities"); - let res=fourier_lineq (!lineq) in - let tac=ref (Proofview.tclUNIT ()) in - if res=[] - then CErrors.user_err Pp.(str "fourier failed") - (* l'algorithme de Fourier a réussi: on va en tirer une preuve Coq *) - else (match res with - [(cres,sres,lc)]-> - (* lc=coefficients multiplicateurs des inéquations - qui donnent 0<cres ou 0<=cres selon sres *) - (*print_string "Fourier's method can prove the goal...";flush stdout;*) - let lutil=ref [] in - List.iter - (fun (h,c) -> - if c<>r0 - then (lutil:=(h,c)::(!lutil)(*; - print_rational(c);print_string " "*))) - (List.combine (!lineq) lc); - (* on construit la combinaison linéaire des inéquation *) - (match (!lutil) with - (h1,c1)::lutil -> - let s=ref (h1.hstrict) in - let t1=ref (mkAppL [|get coq_Rmult; - rational_to_real c1; - h1.hleft|]) in - let t2=ref (mkAppL [|get coq_Rmult; - rational_to_real c1; - h1.hright|]) in - List.iter (fun (h,c) -> - s:=(!s)||(h.hstrict); - t1:=(mkAppL [|get coq_Rplus; - !t1; - mkAppL [|get coq_Rmult; - rational_to_real c; - h.hleft|] |]); - t2:=(mkAppL [|get coq_Rplus; - !t2; - mkAppL [|get coq_Rmult; - rational_to_real c; - h.hright|] |])) - lutil; - let ineq=mkAppL [|if (!s) then get coq_Rlt else get coq_Rle; - !t1; - !t2 |] in - let tc=rational_to_real cres in - (* puis sa preuve *) - let get = eget in - let tac1=ref (if h1.hstrict - then (Tacticals.New.tclTHENS (apply (get coq_Rfourier_lt)) - [tac_use h1; - tac_zero_inf_pos gl - (rational_to_fraction c1)]) - else (Tacticals.New.tclTHENS (apply (get coq_Rfourier_le)) - [tac_use h1; - tac_zero_inf_pos gl - (rational_to_fraction c1)])) in - s:=h1.hstrict; - List.iter (fun (h,c)-> - (if (!s) - then (if h.hstrict - then tac1:=(Tacticals.New.tclTHENS (apply (get coq_Rfourier_lt_lt)) - [!tac1;tac_use h; - tac_zero_inf_pos gl - (rational_to_fraction c)]) - else tac1:=(Tacticals.New.tclTHENS (apply (get coq_Rfourier_lt_le)) - [!tac1;tac_use h; - tac_zero_inf_pos gl - (rational_to_fraction c)])) - else (if h.hstrict - then tac1:=(Tacticals.New.tclTHENS (apply (get coq_Rfourier_le_lt)) - [!tac1;tac_use h; - tac_zero_inf_pos gl - (rational_to_fraction c)]) - else tac1:=(Tacticals.New.tclTHENS (apply (get coq_Rfourier_le_le)) - [!tac1;tac_use h; - tac_zero_inf_pos gl - (rational_to_fraction c)]))); - s:=(!s)||(h.hstrict)) - lutil; - let tac2= if sres - then tac_zero_inf_false gl (rational_to_fraction cres) - else tac_zero_infeq_false gl (rational_to_fraction cres) - in - tac:=(Tacticals.New.tclTHENS (cut (EConstr.of_constr ineq)) - [Tacticals.New.tclTHEN (change_concl - (EConstr.of_constr (mkAppL [| cget coq_not; ineq|] - ))) - (Tacticals.New.tclTHEN (apply (if sres then get coq_Rnot_lt_lt - else get coq_Rnot_le_le)) - (Tacticals.New.tclTHENS (Equality.replace - (EConstr.of_constr (mkAppL [|cget coq_Rminus;!t2;!t1|] - )) - (EConstr.of_constr tc)) - [tac2; - (Tacticals.New.tclTHENS - (Equality.replace - (EConstr.of_constr (mkApp (cget coq_Rinv, - [|cget coq_R1|]))) - (get coq_R1)) -(* en attendant Field, ça peut aider Ring de remplacer 1/1 par 1 ... *) - - [Tacticals.New.tclORELSE - (* TODO : Ring.polynom []*) (Proofview.tclUNIT ()) - (Proofview.tclUNIT ()); - Tacticals.New.pf_constr_of_global (cget coq_sym_eqT) >>= fun symeq -> - (Tacticals.New.tclTHEN (apply symeq) - (apply (get coq_Rinv_1)))] - - ) - ])); - !tac1]); - tac:=(Tacticals.New.tclTHENS (cut (get coq_False)) - [Tacticals.New.tclTHEN intro (contradiction None); - !tac]) - |_-> assert false) |_-> assert false - ); -(* ((tclTHEN !tac (tclFAIL 1 (* 1 au hasard... *))) gl) *) - !tac -(* ((tclABSTRACT None !tac) gl) *) - end -;; - -(* -let fourier_tac x gl = - fourier gl -;; - -let v_fourier = add_tactic "Fourier" fourier_tac -*) - diff --git a/plugins/fourier/fourier_plugin.mlpack b/plugins/fourier/fourier_plugin.mlpack deleted file mode 100644 index b6262f8aeb..0000000000 --- a/plugins/fourier/fourier_plugin.mlpack +++ /dev/null @@ -1,3 +0,0 @@ -Fourier -FourierR -G_fourier diff --git a/plugins/fourier/g_fourier.mlg b/plugins/fourier/g_fourier.mlg deleted file mode 100644 index 703e29f964..0000000000 --- a/plugins/fourier/g_fourier.mlg +++ /dev/null @@ -1,22 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -{ - -open Ltac_plugin -open FourierR - -} - -DECLARE PLUGIN "fourier_plugin" - -TACTIC EXTEND fourier -| [ "fourierz" ] -> { fourier () } -END diff --git a/plugins/funind/recdef.mli b/plugins/funind/recdef.mli index b95d64ce9e..549f1fc0e4 100644 --- a/plugins/funind/recdef.mli +++ b/plugins/funind/recdef.mli @@ -14,6 +14,6 @@ bool -> int -> Constrexpr.constr_expr -> (pconstant -> Indfun_common.tcc_lemma_value ref -> pconstant -> - pconstant -> int -> EConstr.types -> int -> EConstr.constr -> 'a) -> Constrexpr.constr_expr list -> unit + pconstant -> int -> EConstr.types -> int -> EConstr.constr -> unit) -> Constrexpr.constr_expr list -> unit diff --git a/plugins/ltac/extratactics.ml4 b/plugins/ltac/extratactics.ml4 index f24ab2bddb..dc027c4041 100644 --- a/plugins/ltac/extratactics.ml4 +++ b/plugins/ltac/extratactics.ml4 @@ -604,8 +604,11 @@ let subst_var_with_hole occ tid t = else (incr locref; DAst.make ~loc:(Loc.make_loc (!locref,0)) @@ - GHole (Evar_kinds.QuestionMark(Evar_kinds.Define true,Anonymous), - IntroAnonymous, None))) + GHole (Evar_kinds.QuestionMark { + Evar_kinds.qm_obligation=Evar_kinds.Define true; + Evar_kinds.qm_name=Anonymous; + Evar_kinds.qm_record_field=None; + }, IntroAnonymous, None))) else x | _ -> map_glob_constr_left_to_right substrec x in let t' = substrec t @@ -616,13 +619,21 @@ let subst_hole_with_term occ tc t = let locref = ref 0 in let occref = ref occ in let rec substrec c = match DAst.get c with - | GHole (Evar_kinds.QuestionMark(Evar_kinds.Define true,Anonymous),IntroAnonymous,s) -> + | GHole (Evar_kinds.QuestionMark { + Evar_kinds.qm_obligation=Evar_kinds.Define true; + Evar_kinds.qm_name=Anonymous; + Evar_kinds.qm_record_field=None; + }, IntroAnonymous, s) -> decr occref; if Int.equal !occref 0 then tc else (incr locref; DAst.make ~loc:(Loc.make_loc (!locref,0)) @@ - GHole (Evar_kinds.QuestionMark(Evar_kinds.Define true,Anonymous),IntroAnonymous,s)) + GHole (Evar_kinds.QuestionMark { + Evar_kinds.qm_obligation=Evar_kinds.Define true; + Evar_kinds.qm_name=Anonymous; + Evar_kinds.qm_record_field=None; + },IntroAnonymous,s)) | _ -> map_glob_constr_left_to_right substrec c in substrec t diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index 4b834d66d3..636cb8ebf8 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -594,15 +594,6 @@ let rec clause_of_sign : type a. a ty_sig -> Genarg.ArgT.any Extend.user_symbol let clause_of_ty_ml = function | TyML (t,_) -> clause_of_sign t -let rec prj : type a b c. (a,b,c) Extend.ty_user_symbol -> (a,b,c) genarg_type = function - | TUentry a -> ExtraArg a - | TUentryl (a,l) -> ExtraArg a - | TUopt(o) -> OptArg (prj o) - | TUlist1 l -> ListArg (prj l) - | TUlist1sep (l,_) -> ListArg (prj l) - | TUlist0 l -> ListArg (prj l) - | TUlist0sep (l,_) -> ListArg (prj l) - let rec eval_sign : type a. a ty_sig -> a -> Geninterp.Val.t list -> Geninterp.interp_sign -> unit Proofview.tactic = fun sign tac -> match sign with @@ -617,7 +608,7 @@ let rec eval_sign : type a. a ty_sig -> a -> Geninterp.Val.t list -> Geninterp.i begin fun tac vals ist -> match vals with | [] -> assert false | v :: vals -> - let v' = Taccoerce.Value.cast (topwit (prj a)) v in + let v' = Taccoerce.Value.cast (topwit (Egramml.proj_symbol a)) v in f (tac v') vals ist end tac | TyAnonArg (a, sig') -> eval_sign sig' tac diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 77b5b06d44..a0446bd6a0 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -141,16 +141,6 @@ let extract_trace ist = match TacStore.get ist.extra f_trace with | None -> [] | Some l -> l -module Value = struct - - include Taccoerce.Value - - let of_closure ist tac = - let closure = VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], tac) in - of_tacvalue closure - -end - let print_top_val env v = Pptactic.pr_value Pptactic.ltop v let catching_error call_trace fail (e, info) = @@ -1860,6 +1850,31 @@ let eval_tactic_ist ist t = Proofview.tclLIFT db_initialize <*> interp_tactic ist t +(** FFI *) + +module Value = struct + + include Taccoerce.Value + + let of_closure ist tac = + let closure = VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], tac) in + of_tacvalue closure + + (** Apply toplevel tactic values *) + let apply (f : value) (args: value list) = + let fold arg (i, vars, lfun) = + let id = Id.of_string ("x" ^ string_of_int i) in + let x = Reference (ArgVar CAst.(make id)) in + (succ i, x :: vars, Id.Map.add id arg lfun) + in + let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in + let lfun = Id.Map.add (Id.of_string "F") f lfun in + let ist = { (default_ist ()) with lfun = lfun; } in + let tac = TacArg(Loc.tag @@ TacCall (Loc.tag (ArgVar CAst.(make @@ Id.of_string "F"),args))) in + eval_tactic_ist ist tac + +end + (* globalization + interpretation *) diff --git a/plugins/ltac/tacinterp.mli b/plugins/ltac/tacinterp.mli index fd2d96bd62..f9883e4441 100644 --- a/plugins/ltac/tacinterp.mli +++ b/plugins/ltac/tacinterp.mli @@ -28,6 +28,7 @@ sig val to_list : t -> t list option val of_closure : Geninterp.interp_sign -> glob_tactic_expr -> t val cast : 'a typed_abstract_argument_type -> Geninterp.Val.t -> 'a + val apply : t -> t list -> unit Proofview.tactic end (** Values for interpretation *) diff --git a/plugins/micromega/Fourier.v b/plugins/micromega/Fourier.v new file mode 100644 index 0000000000..0153de1dab --- /dev/null +++ b/plugins/micromega/Fourier.v @@ -0,0 +1,5 @@ +Require Import Lra. +Require Export Fourier_util. + +#[deprecated(since = "8.9.0", note = "Use lra instead.")] +Ltac fourier := lra. diff --git a/plugins/micromega/Fourier_util.v b/plugins/micromega/Fourier_util.v new file mode 100644 index 0000000000..b62153dee4 --- /dev/null +++ b/plugins/micromega/Fourier_util.v @@ -0,0 +1,31 @@ +Require Export Rbase. +Require Import Lra. + +Open Scope R_scope. + +Lemma Rlt_mult_inv_pos : forall x y:R, 0 < x -> 0 < y -> 0 < x * / y. +intros x y H H0; try assumption. +replace 0 with (x * 0). +apply Rmult_lt_compat_l; auto with real. +ring. +Qed. + +Lemma Rlt_zero_pos_plus1 : forall x:R, 0 < x -> 0 < 1 + x. +intros x H; try assumption. +rewrite Rplus_comm. +apply Rle_lt_0_plus_1. +red; auto with real. +Qed. + +Lemma Rle_zero_pos_plus1 : forall x:R, 0 <= x -> 0 <= 1 + x. + intros; lra. +Qed. + +Lemma Rle_mult_inv_pos : forall x y:R, 0 <= x -> 0 < y -> 0 <= x * / y. +intros x y H H0; try assumption. +case H; intros. +red; left. +apply Rlt_mult_inv_pos; auto with real. +rewrite <- H1. +red; right; ring. +Qed. diff --git a/plugins/micromega/mutils.mli b/plugins/micromega/mutils.mli index 7b7a090de0..094429ea18 100644 --- a/plugins/micromega/mutils.mli +++ b/plugins/micromega/mutils.mli @@ -30,7 +30,7 @@ end module TagSet : CSig.SetS with type elt = Tag.t -val pp_list : (out_channel -> 'a -> 'b) -> out_channel -> 'a list -> unit +val pp_list : (out_channel -> 'a -> unit) -> out_channel -> 'a list -> unit module CamlToCoq : sig diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 8e0ca877a0..a736eec5e7 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -161,21 +161,6 @@ let decl_constant na univs c = let ltac_call tac (args:glob_tactic_arg list) = TacArg(Loc.tag @@ TacCall (Loc.tag (ArgArg(Loc.tag @@ Lazy.force tac),args))) -(* Calling a locally bound tactic *) -let ltac_lcall tac args = - TacArg(Loc.tag @@ TacCall (Loc.tag (ArgVar CAst.(make @@ Id.of_string tac),args))) - -let ltac_apply (f : Value.t) (args: Tacinterp.Value.t list) = - let fold arg (i, vars, lfun) = - let id = Id.of_string ("x" ^ string_of_int i) in - let x = Reference (ArgVar CAst.(make id)) in - (succ i, x :: vars, Id.Map.add id arg lfun) - in - let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in - let lfun = Id.Map.add (Id.of_string "F") f lfun in - let ist = { (Tacinterp.default_ist ()) with Tacinterp.lfun = lfun; } in - Tacinterp.eval_tactic_ist ist (ltac_lcall "F" args) - let dummy_goal env sigma = let (gl,_,sigma) = Goal.V82.mk_goal sigma (named_context_val env) EConstr.mkProp Evd.Store.empty in @@ -765,7 +750,7 @@ let ring_lookup (f : Value.t) lH rl t = let rl = Value.of_constr (make_term_list env evdref (EConstr.of_constr e.ring_carrier) rl) in let lH = carg (make_hyp_list env evdref lH) in let ring = ltac_ring_structure e in - Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (ltac_apply f (ring@[lH;rl])) + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (Value.apply f (ring@[lH;rl])) with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e end @@ -1051,6 +1036,6 @@ let field_lookup (f : Value.t) lH rl t = let rl = Value.of_constr (make_term_list env evdref (EConstr.of_constr e.field_carrier) rl) in let lH = carg (make_hyp_list env evdref lH) in let field = ltac_field_structure e in - Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (ltac_apply f (field@[lH;rl])) + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (Value.apply f (field@[lH;rl])) with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e end diff --git a/plugins/ssr/ssrbool.v b/plugins/ssr/ssrbool.v index 7d05b64384..0865f75ec5 100644 --- a/plugins/ssr/ssrbool.v +++ b/plugins/ssr/ssrbool.v @@ -61,8 +61,8 @@ Require Import ssreflect ssrfun. (* classically P <-> we can assume P when proving is_true b. *) (* := forall b : bool, (P -> b) -> b. *) (* This is equivalent to ~ (~ P) when P : Prop. *) -(* implies P Q == wrapper coinductive type that coerces to P -> Q *) -(* and can be used as a P -> Q view unambigously. *) +(* implies P Q == wrapper variant type that coerces to P -> Q and *) +(* can be used as a P -> Q view unambigously. *) (* Useful to avoid spurious insertion of <-> views *) (* when Q is a conjunction of foralls, as in Lemma *) (* all_and2 below; conversely, avoids confusion in *) @@ -456,7 +456,7 @@ Section BoolIf. Variables (A B : Type) (x : A) (f : A -> B) (b : bool) (vT vF : A). -CoInductive if_spec (not_b : Prop) : bool -> A -> Set := +Variant if_spec (not_b : Prop) : bool -> A -> Set := | IfSpecTrue of b : if_spec not_b true vT | IfSpecFalse of not_b : if_spec not_b false vF. @@ -585,7 +585,7 @@ Lemma rwP2 : reflect Q b -> (P <-> Q). Proof. by move=> Qb; split=> ?; [apply: appP | apply: elimT; case: Qb]. Qed. (* Predicate family to reflect excluded middle in bool. *) -CoInductive alt_spec : bool -> Type := +Variant alt_spec : bool -> Type := | AltTrue of P : alt_spec true | AltFalse of ~~ b : alt_spec false. @@ -603,7 +603,7 @@ Hint View for apply// equivPif|3 xorPif|3 equivPifn|3 xorPifn|3. (* Allow the direct application of a reflection lemma to a boolean assertion. *) Coercion elimT : reflect >-> Funclass. -CoInductive implies P Q := Implies of P -> Q. +Variant implies P Q := Implies of P -> Q. Lemma impliesP P Q : implies P Q -> P -> Q. Proof. by case. Qed. Lemma impliesPn (P Q : Prop) : implies P Q -> ~ Q -> ~ P. Proof. by case=> iP ? /iP. Qed. @@ -1119,7 +1119,7 @@ Proof. by move=> *; apply/orP; left. Qed. Lemma subrelUr r1 r2 : subrel r2 (relU r1 r2). Proof. by move=> *; apply/orP; right. Qed. -CoInductive mem_pred := Mem of pred T. +Variant mem_pred := Mem of pred T. Definition isMem pT topred mem := mem = (fun p : pT => Mem [eta topred p]). @@ -1329,7 +1329,7 @@ End simpl_mem. (* Qualifiers and keyed predicates. *) -CoInductive qualifier (q : nat) T := Qualifier of predPredType T. +Variant qualifier (q : nat) T := Qualifier of predPredType T. Coercion has_quality n T (q : qualifier n T) : pred_class := fun x => let: Qualifier _ p := q in p x. @@ -1376,7 +1376,7 @@ Notation "[ 'qualify' 'an' x : T | P ]" := (Qualifier 2 (fun x : T => P%B)) Section KeyPred. Variable T : Type. -CoInductive pred_key (p : predPredType T) := DefaultPredKey. +Variant pred_key (p : predPredType T) := DefaultPredKey. Variable p : predPredType T. Structure keyed_pred (k : pred_key p) := diff --git a/plugins/ssr/ssreflect.v b/plugins/ssr/ssreflect.v index b0a9441385..b4144aa45e 100644 --- a/plugins/ssr/ssreflect.v +++ b/plugins/ssr/ssreflect.v @@ -184,7 +184,7 @@ Inductive external_view : Type := tactic_view of Type. Module TheCanonical. -CoInductive put vT sT (v1 v2 : vT) (s : sT) := Put. +Variant put vT sT (v1 v2 : vT) (s : sT) := Put. Definition get vT sT v s (p : @put vT sT v v s) := let: Put _ _ _ := p in s. @@ -275,10 +275,10 @@ Notation "{ 'type' 'of' c 'for' s }" := (dependentReturnType c s) (* We also define a simpler version ("phant" / "Phant") of phantom for the *) (* common case where p_type is Type. *) -CoInductive phantom T (p : T) := Phantom. +Variant phantom T (p : T) := Phantom. Arguments phantom : clear implicits. Arguments Phantom : clear implicits. -CoInductive phant (p : Type) := Phant. +Variant phant (p : Type) := Phant. (* Internal tagging used by the implementation of the ssreflect elim. *) diff --git a/plugins/ssr/ssrfun.v b/plugins/ssr/ssrfun.v index ac2c78249b..b2d5143e36 100644 --- a/plugins/ssr/ssrfun.v +++ b/plugins/ssr/ssrfun.v @@ -326,7 +326,7 @@ Section SimplFun. Variables aT rT : Type. -CoInductive simpl_fun := SimplFun of aT -> rT. +Variant simpl_fun := SimplFun of aT -> rT. Definition fun_of_simpl f := fun x => let: SimplFun lam := f in lam x. @@ -684,7 +684,7 @@ Section Bijections. Variables (A B : Type) (f : B -> A). -CoInductive bijective : Prop := Bijective g of cancel f g & cancel g f. +Variant bijective : Prop := Bijective g of cancel f g & cancel g f. Hypothesis bijf : bijective. diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml index 7fe2421f90..e367cd32d6 100644 --- a/plugins/ssr/ssrfwd.ml +++ b/plugins/ssr/ssrfwd.ml @@ -68,20 +68,14 @@ open Ssripats let ssrhaveNOtcresolution = Summary.ref ~name:"SSR:havenotcresolution" false -let inHaveTCResolution = Libobject.declare_object { - (Libobject.default_object "SSRHAVETCRESOLUTION") with - Libobject.cache_function = (fun (_,v) -> ssrhaveNOtcresolution := v); - Libobject.load_function = (fun _ (_,v) -> ssrhaveNOtcresolution := v); - Libobject.classify_function = (fun v -> Libobject.Keep v); -} let _ = Goptions.declare_bool_option { Goptions.optname = "have type classes"; Goptions.optkey = ["SsrHave";"NoTCResolution"]; Goptions.optread = (fun _ -> !ssrhaveNOtcresolution); Goptions.optdepr = false; - Goptions.optwrite = (fun b -> - Lib.add_anonymous_leaf (inHaveTCResolution b)) } + Goptions.optwrite = (fun b -> ssrhaveNOtcresolution := b); + } open Constrexpr diff --git a/plugins/ssr/ssrvernac.ml4 b/plugins/ssr/ssrvernac.ml4 index 7ce2dd64af..8ce0316f53 100644 --- a/plugins/ssr/ssrvernac.ml4 +++ b/plugins/ssr/ssrvernac.ml4 @@ -24,7 +24,6 @@ open Ltac_plugin open Notation_ops open Notation_term open Glob_term -open Globnames open Stdarg open Genarg open Decl_kinds @@ -359,13 +358,12 @@ let coerce_search_pattern_to_sort hpat = true, cp with _ -> false, [] in let coerce hp coe_index = - let coe = Classops.get_coercion_value coe_index in + let coe_ref = coe_index.Classops.coe_value in try - let coe_ref = global_of_constr coe in let n_imps = Option.get (Classops.hide_coercion coe_ref) in mkPApp (Pattern.PRef coe_ref) n_imps [|hp|] - with _ -> - errorstrm (str "need explicit coercion " ++ pr_constr_env env sigma coe ++ spc () + with Not_found | Option.IsNone -> + errorstrm (str "need explicit coercion " ++ pr_global coe_ref ++ spc () ++ str "to interpret head search pattern as type") in filter_head, List.fold_left coerce hpat' coe_path diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 2d72b9db67..ad33297f0a 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -373,6 +373,11 @@ let ltac_interp_realnames lvar = function | t, IsInd (ty,ind,realnal) -> t, IsInd (ty,ind,List.map (ltac_interp_name lvar) realnal) | _ as x -> x +let is_patvar pat = + match DAst.get pat with + | PatVar _ -> true + | _ -> false + let coerce_row typing_fun evdref env lvar pats (tomatch,(na,indopt)) = let loc = loc_of_glob_constr tomatch in let tycon,realnames = find_tomatch_tycon evdref env loc indopt in @@ -381,6 +386,7 @@ let coerce_row typing_fun evdref env lvar pats (tomatch,(na,indopt)) = let typ = nf_evar !evdref j.uj_type in lvar := make_return_predicate_ltac_lvar !evdref na tomatch j.uj_val !lvar; let t = + if realnames = None && pats <> [] && List.for_all is_patvar pats then NotInd (None,typ) else try try_find_ind env !evdref typ realnames with Not_found -> unify_tomatch_with_patterns evdref env loc typ pats realnames in @@ -2104,7 +2110,10 @@ let mk_JMeq_refl evdref typ x = papp evdref coq_JMeq_refl [| typ; x |] let hole na = DAst.make @@ - GHole (Evar_kinds.QuestionMark (Evar_kinds.Define false,na), + GHole (Evar_kinds.QuestionMark { + Evar_kinds.qm_obligation= Evar_kinds.Define false; + Evar_kinds.qm_name=na; + Evar_kinds.qm_record_field=None}, IntroAnonymous, None) let constr_of_pat env evdref arsign pat avoid = diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index cb0fc32575..da6e26cc4b 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -71,7 +71,7 @@ and cbv_stack = | TOP | APP of cbv_value array * cbv_stack | CASE of constr * constr array * case_info * cbv_value subs * cbv_stack - | PROJ of Projection.t * Declarations.projection_body * cbv_stack + | PROJ of Projection.t * cbv_stack (* les vars pourraient etre des constr, cela permet de retarder les lift: utile ?? *) @@ -126,7 +126,7 @@ let rec stack_concat stk1 stk2 = TOP -> stk2 | APP(v,stk1') -> APP(v,stack_concat stk1' stk2) | CASE(c,b,i,s,stk1') -> CASE(c,b,i,s,stack_concat stk1' stk2) - | PROJ (p,pinfo,stk1') -> PROJ (p,pinfo,stack_concat stk1' stk2) + | PROJ (p,stk1') -> PROJ (p,stack_concat stk1' stk2) (* merge stacks when there is no shifts in between *) let mkSTACK = function @@ -200,7 +200,7 @@ let rec reify_stack t = function reify_stack (mkCase (ci, ty, t,br)) st - | PROJ (p, pinfo, st) -> + | PROJ (p, st) -> reify_stack (mkProj (p, t)) st and reify_value = function (* reduction under binders *) @@ -265,8 +265,7 @@ let rec norm_head info env t stack = then Projection.unfold p else p in - let pinfo = Environ.lookup_projection p (info_env info.infos) in - norm_head info env c (PROJ (p', pinfo, stack)) + norm_head info env c (PROJ (p', stack)) (* constants, axioms * the first pattern is CRUCIAL, n=0 happens very often: @@ -281,8 +280,9 @@ let rec norm_head info env t stack = | Var id -> norm_head_ref 0 info env stack (VarKey id) | Const sp -> - Reductionops.reduction_effect_hook (env_of_infos info.infos) info.sigma t (lazy (reify_stack t stack)); - norm_head_ref 0 info env stack (ConstKey sp) + Reductionops.reduction_effect_hook (env_of_infos info.infos) info.sigma + (fst sp) (lazy (reify_stack t stack)); + norm_head_ref 0 info env stack (ConstKey sp) | LetIn (_, b, _, c) -> (* zeta means letin are contracted; delta without zeta means we *) @@ -380,9 +380,9 @@ and cbv_stack_value info env = function cbv_stack_term info stk env br.(n-1) (* constructor in a Projection -> IOTA *) - | (CONSTR(((sp,n),u),[||]), APP(args,PROJ(p,pi,stk))) + | (CONSTR(((sp,n),u),[||]), APP(args,PROJ(p,stk))) when red_set (info_flags info.infos) fMATCH && Projection.unfolded p -> - let arg = args.(pi.Declarations.proj_npars + pi.Declarations.proj_arg) in + let arg = args.(Projection.npars p + Projection.arg p) in cbv_stack_value info env (strip_appl arg stk) (* may be reduced later by application *) @@ -407,7 +407,7 @@ let rec apply_stack info t = function (mkCase (ci, cbv_norm_term info env ty, t, Array.map (cbv_norm_term info env) br)) st - | PROJ (p, pinfo, st) -> + | PROJ (p, st) -> apply_stack info (mkProj (p, t)) st (* performs the reduction on a constr, and returns a constr *) diff --git a/pretyping/cbv.mli b/pretyping/cbv.mli index cdaa39c53c..83844c95a7 100644 --- a/pretyping/cbv.mli +++ b/pretyping/cbv.mli @@ -41,7 +41,7 @@ and cbv_stack = | TOP | APP of cbv_value array * cbv_stack | CASE of constr * constr array * case_info * cbv_value subs * cbv_stack - | PROJ of Projection.t * Declarations.projection_body * cbv_stack + | PROJ of Projection.t * cbv_stack val shift_value : int -> cbv_value -> cbv_value diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 7dbef01c22..542fb5456c 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -31,7 +31,7 @@ type cl_typ = | CL_SECVAR of variable | CL_CONST of Constant.t | CL_IND of inductive - | CL_PROJ of Constant.t + | CL_PROJ of Projection.Repr.t type cl_info_typ = { cl_param : int @@ -42,18 +42,15 @@ type coe_typ = GlobRef.t module CoeTypMap = Refmap_env type coe_info_typ = { - coe_value : constr; - coe_type : types; + coe_value : GlobRef.t; coe_local : bool; - coe_context : Univ.ContextSet.t; coe_is_identity : bool; - coe_is_projection : bool; - coe_param : int } + coe_is_projection : Projection.Repr.t option; + coe_param : int; +} let coe_info_typ_equal c1 c2 = - let eq_constr c1 c2 = Termops.eq_constr Evd.empty (EConstr.of_constr c1) (EConstr.of_constr c2) in - eq_constr c1.coe_value c2.coe_value && - eq_constr c1.coe_type c2.coe_type && + GlobRef.equal c1.coe_value c2.coe_value && c1.coe_local == c2.coe_local && c1.coe_is_identity == c2.coe_is_identity && c1.coe_is_projection == c2.coe_is_projection && @@ -62,7 +59,7 @@ let coe_info_typ_equal c1 c2 = let cl_typ_ord t1 t2 = match t1, t2 with | CL_SECVAR v1, CL_SECVAR v2 -> Id.compare v1 v2 | CL_CONST c1, CL_CONST c2 -> Constant.CanOrd.compare c1 c2 - | CL_PROJ c1, CL_PROJ c2 -> Constant.CanOrd.compare c1 c2 + | CL_PROJ c1, CL_PROJ c2 -> Projection.Repr.CanOrd.compare c1 c2 | CL_IND i1, CL_IND i2 -> ind_ord i1 i2 | _ -> Pervasives.compare t1 t2 (** OK *) @@ -77,9 +74,7 @@ module IntMap = Map.Make(Int) let cl_typ_eq t1 t2 = Int.equal (cl_typ_ord t1 t2) 0 -type coe_index = coe_info_typ - -type inheritance_path = coe_index list +type inheritance_path = coe_info_typ list (* table des classes, des coercions et graphe d'heritage *) @@ -199,7 +194,7 @@ let find_class_type sigma t = | Var id -> CL_SECVAR id, EInstance.empty, args | Const (sp,u) -> CL_CONST sp, u, args | Proj (p, c) when not (Projection.unfolded p) -> - CL_PROJ (Projection.constant p), EInstance.empty, (c :: args) + CL_PROJ (Projection.repr p), EInstance.empty, (c :: args) | Ind (ind_sp,u) -> CL_IND ind_sp, u, args | Prod (_,_,_) -> CL_FUN, EInstance.empty, [] | Sort _ -> CL_SORT, EInstance.empty, [] @@ -211,7 +206,7 @@ let subst_cl_typ subst ct = match ct with | CL_FUN | CL_SECVAR _ -> ct | CL_PROJ c -> - let c',t = subst_con_kn subst c in + let c' = subst_proj_repr subst c in if c' == c then ct else CL_PROJ c' | CL_CONST c -> let c',t = subst_con_kn subst c in @@ -248,8 +243,11 @@ let class_args_of env sigma c = pi3 (find_class_type sigma c) let string_of_class = function | CL_FUN -> "Funclass" | CL_SORT -> "Sortclass" - | CL_CONST sp | CL_PROJ sp -> - string_of_qualid (shortest_qualid_of_global Id.Set.empty (ConstRef sp)) + | CL_CONST sp -> + string_of_qualid (shortest_qualid_of_global Id.Set.empty (ConstRef sp)) + | CL_PROJ sp -> + let sp = Projection.Repr.constant sp in + string_of_qualid (shortest_qualid_of_global Id.Set.empty (ConstRef sp)) | CL_IND sp -> string_of_qualid (shortest_qualid_of_global Id.Set.empty (IndRef sp)) | CL_SECVAR sp -> @@ -297,31 +295,25 @@ let lookup_path_to_fun_from env sigma s = let lookup_path_to_sort_from env sigma s = apply_on_class_of env sigma s lookup_path_to_sort_from_class +let mkNamed = function + | GlobRef.ConstRef c -> EConstr.mkConst c + | VarRef v -> EConstr.mkVar v + | ConstructRef c -> EConstr.mkConstruct c + | IndRef i -> EConstr.mkInd i + let get_coercion_constructor env coe = - let c, _ = - Reductionops.whd_all_stack env Evd.empty (EConstr.of_constr coe.coe_value) - in - match EConstr.kind Evd.empty (** FIXME *) c with - | Construct (cstr,u) -> - (cstr, Inductiveops.constructor_nrealargs cstr -1) - | _ -> - raise Not_found + let evd = Evd.from_env env in + let red x = fst (Reductionops.whd_all_stack env evd x) in + match EConstr.kind evd (red (mkNamed coe.coe_value)) with + | Constr.Construct (c, _) -> + c, Inductiveops.constructor_nrealargs c -1 + | _ -> raise Not_found let lookup_pattern_path_between env (s,t) = let i = inductive_class_of s in let j = inductive_class_of t in List.map (get_coercion_constructor env) (ClPairMap.find (i,j) !inheritance_graph) -(* coercion_value : coe_index -> unsafe_judgment * bool *) - -let coercion_value { coe_value = c; coe_type = t; coe_context = ctx; - coe_is_identity = b; coe_is_projection = b' } = - let subst, ctx = UnivGen.fresh_universe_context_set_instance ctx in - let c' = Vars.subst_univs_level_constr subst c - and t' = Vars.subst_univs_level_constr subst t in - (make_judge (EConstr.of_constr c') (EConstr.of_constr t'), b, b'), ctx - -(* pretty-print functions are now in Pretty *) (* rajouter une coercion dans le graphe *) let path_printer : (env -> Evd.evar_map -> (Bijint.Index.t * Bijint.Index.t) * inheritance_path -> Pp.t) ref = @@ -395,7 +387,7 @@ type coercion = { coercion_type : coe_typ; coercion_local : bool; coercion_is_id : bool; - coercion_is_proj : bool; + coercion_is_proj : Projection.Repr.t option; coercion_source : cl_typ; coercion_target : cl_typ; coercion_params : int; @@ -408,9 +400,8 @@ let reference_arity_length ref = List.length (fst (Reductionops.splay_arity (Global.env()) Evd.empty (EConstr.of_constr t))) (** FIXME *) let projection_arity_length p = - let len = reference_arity_length (ConstRef p) in - let pb = Environ.lookup_projection (Projection.make p false) (Global.env ()) in - len - pb.Declarations.proj_npars + let len = reference_arity_length (ConstRef (Projection.Repr.constant p)) in + len - Projection.Repr.npars p let class_params = function | CL_FUN | CL_SORT -> 0 @@ -440,17 +431,13 @@ let cache_coercion env sigma (_, c) = let () = add_class c.coercion_target in let is, _ = class_info c.coercion_source in let it, _ = class_info c.coercion_target in - let value, ctx = UnivGen.fresh_global_instance env c.coercion_type in - let typ = Retyping.get_type_of env sigma (EConstr.of_constr value) in - let typ = EConstr.Unsafe.to_constr typ in let xf = - { coe_value = value; - coe_type = typ; - coe_context = ctx; + { coe_value = c.coercion_type; coe_local = c.coercion_local; coe_is_identity = c.coercion_is_id; coe_is_projection = c.coercion_is_proj; - coe_param = c.coercion_params } in + coe_param = c.coercion_params; + } in let () = add_new_coercion c.coercion_type xf in add_coercion_in_graph env sigma (xf,is,it) @@ -466,13 +453,17 @@ let subst_coercion (subst, c) = let coe = subst_coe_typ subst c.coercion_type in let cls = subst_cl_typ subst c.coercion_source in let clt = subst_cl_typ subst c.coercion_target in - if c.coercion_type == coe && c.coercion_source == cls && c.coercion_target == clt then c - else { c with coercion_type = coe; coercion_source = cls; coercion_target = clt } + let clp = Option.Smart.map (subst_proj_repr subst) c.coercion_is_proj in + if c.coercion_type == coe && c.coercion_source == cls && + c.coercion_target == clt && c.coercion_is_proj == clp + then c + else { c with coercion_type = coe; coercion_source = cls; + coercion_target = clt; coercion_is_proj = clp; } let discharge_cl = function | CL_CONST kn -> CL_CONST (Lib.discharge_con kn) | CL_IND ind -> CL_IND (Lib.discharge_inductive ind) - | CL_PROJ p -> CL_PROJ (Lib.discharge_con p) + | CL_PROJ p -> CL_PROJ (Lib.discharge_proj_repr p) | cl -> cl let discharge_coercion (_, c) = @@ -489,6 +480,7 @@ let discharge_coercion (_, c) = coercion_source = discharge_cl c.coercion_source; coercion_target = discharge_cl c.coercion_target; coercion_params = n + c.coercion_params; + coercion_is_proj = Option.map Lib.discharge_proj_repr c.coercion_is_proj; } in Some nc @@ -509,8 +501,8 @@ let inCoercion : coercion -> obj = let declare_coercion coef ?(local = false) ~isid ~src:cls ~target:clt ~params:ps = let isproj = match coef with - | ConstRef c -> Environ.is_projection c (Global.env ()) - | _ -> false + | ConstRef c -> Recordops.find_primitive_projection c + | _ -> None in let c = { coercion_type = coef; @@ -524,8 +516,6 @@ let declare_coercion coef ?(local = false) ~isid ~src:cls ~target:clt ~params:ps Lib.add_anonymous_leaf (inCoercion c) (* For printing purpose *) -let get_coercion_value v = v.coe_value - let pr_cl_index = Bijint.Index.print let classes () = Bijint.dom !class_tab diff --git a/pretyping/classops.mli b/pretyping/classops.mli index 35691ea37a..af00c0a8dc 100644 --- a/pretyping/classops.mli +++ b/pretyping/classops.mli @@ -21,7 +21,7 @@ type cl_typ = | CL_SECVAR of variable | CL_CONST of Constant.t | CL_IND of inductive - | CL_PROJ of Constant.t + | CL_PROJ of Projection.Repr.t (** Equality over [cl_typ] *) val cl_typ_eq : cl_typ -> cl_typ -> bool @@ -39,16 +39,19 @@ type cl_info_typ = { type coe_typ = GlobRef.t (** This is the type of infos for declared coercions *) -type coe_info_typ +type coe_info_typ = { + coe_value : GlobRef.t; + coe_local : bool; + coe_is_identity : bool; + coe_is_projection : Projection.Repr.t option; + coe_param : int; +} (** [cl_index] is the type of class keys *) type cl_index -(** [coe_index] is the type of coercion keys *) -type coe_index - (** This is the type of paths from a class to another *) -type inheritance_path = coe_index list +type inheritance_path = coe_info_typ list (** {6 Access to classes infos } *) @@ -79,8 +82,6 @@ val declare_coercion : (** {6 Access to coercions infos } *) val coercion_exists : coe_typ -> bool -val coercion_value : coe_index -> (unsafe_judgment * bool * bool) Univ.in_universe_context_set - (** {6 Lookup functions for coercion paths } *) (** @raise Not_found in the following functions when no path exists *) @@ -105,10 +106,9 @@ val install_path_printer : val string_of_class : cl_typ -> string val pr_class : cl_typ -> Pp.t val pr_cl_index : cl_index -> Pp.t -val get_coercion_value : coe_index -> Constr.t val inheritance_graph : unit -> ((cl_index * cl_index) * inheritance_path) list val classes : unit -> cl_typ list -val coercions : unit -> coe_index list +val coercions : unit -> coe_info_typ list (** [hide_coercion] returns the number of params to skip if the coercion must be hidden, [None] otherwise; it raises [Not_found] if not a coercion *) diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 5c4cbefad8..5e3821edf1 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -52,17 +52,17 @@ exception NoCoercionNoUnifier of evar_map * unification_error let apply_coercion_args env sigma check isproj argl funj = let rec apply_rec sigma acc typ = function | [] -> - if isproj then - let cst = fst (destConst sigma (j_val funj)) in - let p = Projection.make cst false in - let pb = lookup_projection p env in - let args = List.skipn pb.Declarations.proj_npars argl in - let hd, tl = match args with hd :: tl -> hd, tl | [] -> assert false in - sigma, { uj_val = applist (mkProj (p, hd), tl); - uj_type = typ } - else - sigma, { uj_val = applist (j_val funj,argl); - uj_type = typ } + (match isproj with + | Some p -> + let npars = Projection.Repr.npars p in + let p = Projection.make p false in + let args = List.skipn npars argl in + let hd, tl = match args with hd :: tl -> hd, tl | [] -> assert false in + sigma, { uj_val = applist (mkProj (p, hd), tl); + uj_type = typ } + | None -> + sigma, { uj_val = applist (j_val funj,argl); + uj_type = typ }) | h::restl -> (* On devrait pouvoir s'arranger pour qu'on n'ait pas a faire hnf_constr *) match EConstr.kind sigma (whd_all env sigma typ) with | Prod (_,c1,c2) -> @@ -98,7 +98,11 @@ let inh_pattern_coerce_to ?loc env pat ind1 ind2 = open Program let make_existential ?loc ?(opaque = not (get_proofs_transparency ())) na env evdref c = - let src = Loc.tag ?loc (Evar_kinds.QuestionMark (Evar_kinds.Define opaque,na)) in + let src = Loc.tag ?loc (Evar_kinds.QuestionMark { + Evar_kinds.default_question_mark with + Evar_kinds.qm_obligation=Evar_kinds.Define opaque; + Evar_kinds.qm_name=na; + }) in let evd, v = Evarutil.new_evar env !evdref ~src c in evdref := evd; v @@ -365,8 +369,11 @@ let apply_coercion env sigma p hj typ_cl = let j,t,evd = List.fold_left (fun (ja,typ_cl,sigma) i -> - let ((fv,isid,isproj),ctx) = coercion_value i in - let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in + let isid = i.coe_is_identity in + let isproj = i.coe_is_projection in + let sigma, c = new_global sigma i.coe_value in + let typ = Retyping.get_type_of env sigma c in + let fv = make_judge c typ in let argl = (class_args_of env sigma typ_cl)@[ja.uj_val] in let sigma, jres = apply_coercion_args env sigma true isproj argl fv diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index d0de2f8c0c..6a9a042f57 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -689,10 +689,9 @@ and detype_r d flags avoid env sigma t = (** Print the compatibility match version *) let c' = try - let pb = Environ.lookup_projection p (snd env) in - let ind = pb.Declarations.proj_ind in + let ind = Projection.inductive p in let bodies = Inductiveops.legacy_match_projection (snd env) ind in - let body = bodies.(pb.Declarations.proj_arg) in + let body = bodies.(Projection.arg p) in let ty = Retyping.get_type_of (snd env) sigma c in let ((ind,u), args) = Inductiveops.find_mrectype (snd env) sigma ty in let body' = strip_lam_assum body in @@ -1032,11 +1031,9 @@ let rec subst_glob_constr subst = DAst.map (function if r1' == r1 && k' == k then raw else GCast (r1',k') | GProj (p,c) as raw -> - let kn = Projection.constant p in - let b = Projection.unfolded p in - let kn' = subst_constant subst kn in + let p' = subst_proj subst p in let c' = subst_glob_constr subst c in - if kn' == kn && c' == c then raw else GProj(Projection.make kn' b, c') + if p' == p && c' == c then raw else GProj(p', c') ) (* Utilities to transform kernel cases to simple pattern-matching problem *) diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index a71ef65081..984fa92c0e 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -71,7 +71,7 @@ let coq_unit_judge = let unfold_projection env evd ts p c = let cst = Projection.constant p in if is_transparent_constant ts cst then - Some (mkProj (Projection.make cst true, c)) + Some (mkProj (Projection.unfold p, c)) else None let eval_flexible_term ts env evd c = @@ -292,8 +292,8 @@ let ise_stack2 no_app env evd f sk1 sk2 = | Success i'' -> ise_stack2 true i'' q1 q2 | UnifFailure _ as x -> fail x) | UnifFailure _ as x -> fail x) - | Stack.Proj (n1,a1,p1,_)::q1, Stack.Proj (n2,a2,p2,_)::q2 -> - if Constant.equal (Projection.constant p1) (Projection.constant p2) + | Stack.Proj (p1,_)::q1, Stack.Proj (p2,_)::q2 -> + if Projection.Repr.equal (Projection.repr p1) (Projection.repr p2) then ise_stack2 true i q1 q2 else fail (UnifFailure (i, NotSameHead)) | Stack.Fix (((li1, i1),(_,tys1,bds1 as recdef1)),a1,_)::q1, @@ -334,8 +334,8 @@ let exact_ise_stack2 env evd f sk1 sk2 = (fun i -> ise_array2 i (fun ii -> f (push_rec_types recdef1 env) ii CONV) bds1 bds2); (fun i -> ise_stack2 i a1 a2)] else UnifFailure (i,NotSameHead) - | Stack.Proj (n1,a1,p1,_)::q1, Stack.Proj (n2,a2,p2,_)::q2 -> - if Constant.equal (Projection.constant p1) (Projection.constant p2) + | Stack.Proj (p1,_)::q1, Stack.Proj (p2,_)::q2 -> + if Projection.Repr.equal (Projection.repr p1) (Projection.repr p2) then ise_stack2 i q1 q2 else (UnifFailure (i, NotSameHead)) | Stack.App _ :: _, Stack.App _ :: _ -> @@ -986,10 +986,9 @@ and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2) and eta_constructor ts env evd sk1 ((ind, i), u) sk2 term2 = let open Declarations in let mib = lookup_mind (fst ind) env in - match mib.Declarations.mind_record with - | PrimRecord info when mib.Declarations.mind_finite == Declarations.BiFinite -> - let (_, projs, _) = info.(snd ind) in - let pars = mib.Declarations.mind_nparams in + match get_projections env ind with + | Some projs when mib.mind_finite == BiFinite -> + let pars = mib.mind_nparams in (try let l1' = Stack.tail pars sk1 in let l2' = diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index 4dfa789ba5..24eb666828 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -562,7 +562,9 @@ let rec glob_constr_of_cases_pattern_aux isclosed x = DAst.map_with_loc (fun ?lo | PatVar (Name id) when not isclosed -> GVar id | PatVar Anonymous when not isclosed -> - GHole (Evar_kinds.QuestionMark (Define false,Anonymous),Namegen.IntroAnonymous,None) + GHole (Evar_kinds.QuestionMark { + Evar_kinds.default_question_mark with Evar_kinds.qm_obligation=Define false; + },Namegen.IntroAnonymous,None) | _ -> raise Not_found ) x diff --git a/library/heads.ml b/pretyping/heads.ml index d9d650ac07..7d9debce34 100644 --- a/library/heads.ml +++ b/pretyping/heads.ml @@ -128,8 +128,8 @@ let compute_head = function let env = Global.env() in let cb = Environ.lookup_constant cst env in let is_Def = function Declarations.Def _ -> true | _ -> false in - let body = - if not (Environ.is_projection cst env) && is_Def cb.Declarations.const_body + let body = + if not (Recordops.is_primitive_projection cst) && is_Def cb.Declarations.const_body then Global.body_of_constant cst else None in (match body with diff --git a/library/heads.mli b/pretyping/heads.mli index 421242996c..421242996c 100644 --- a/library/heads.mli +++ b/pretyping/heads.mli diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index 551cc67b60..dc900ab814 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -79,7 +79,7 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = let lnamespar = Vars.subst_instance_context u mib.mind_params_ctxt in let indf = make_ind_family(pind, Context.Rel.to_extended_list mkRel 0 lnamespar) in let constrs = get_constructors env indf in - let projs = get_projections env indf in + let projs = get_projections env ind in let () = if Option.is_empty projs then check_privacy_block mib in let () = diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 5760733442..b379cdf410 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -51,7 +51,7 @@ let arities_of_constructors env (ind,u as indu) = type inductive_family = pinductive * constr list let make_ind_family (mis, params) = (mis,params) -let dest_ind_family (mis,params) = (mis,params) +let dest_ind_family (mis,params) : inductive_family = (mis,params) let map_ind_family f (mis,params) = (mis, List.map f params) @@ -269,11 +269,9 @@ let allowed_sorts env (kn,i as ind) = let (mib,mip) = Inductive.lookup_mind_specif env ind in mip.mind_kelim -let projection_nparams_env env p = - let pb = lookup_projection p env in - pb.proj_npars +let projection_nparams_env _ p = Projection.npars p -let projection_nparams p = projection_nparams_env (Global.env ()) p +let projection_nparams p = Projection.npars p let has_dependent_elim mib = match mib.mind_record with @@ -343,17 +341,11 @@ let get_constructors env (ind,params) = Array.init (Array.length mip.mind_consnames) (fun j -> get_constructor (ind,mib,mip,params) (j+1)) -let get_projections env (ind,params) = - let (mib,mip) = Inductive.lookup_mind_specif env (fst ind) in - match mib.mind_record with - | PrimRecord infos -> - let (_, projs, _) = infos.(snd (fst ind)) in - Some projs - | NotRecord | FakeRecord -> None +let get_projections = Environ.get_projections let make_case_or_project env sigma indf ci pred c branches = let open EConstr in - let projs = get_projections env indf in + let projs = get_projections env (fst (fst indf)) in match projs with | None -> (mkCase (ci, pred, c, branches)) | Some ps -> @@ -481,7 +473,6 @@ let compute_projections env (kn, i as ind) = let subst = List.init mib.mind_ntypes (fun i -> mkIndU ((kn, mib.mind_ntypes - i - 1), u)) in let rctx, _ = decompose_prod_assum (substl subst pkt.mind_nf_lc.(0)) in let ctx, paramslet = List.chop pkt.mind_consnrealdecls.(0) rctx in - let mp, dp, l = MutInd.repr3 kn in (** We build a substitution smashing the lets in the record parameters so that typechecking projections requires just a substitution and not matching with a parameter context. *) @@ -512,7 +503,7 @@ let compute_projections env (kn, i as ind) = let body = mkCase (ci, p, mkRel 1, [|lift 1 branch|]) in it_mkLambda_or_LetIn (mkLambda (x,indty,body)) params in - let projections decl (j, pbs, subst) = + let projections decl (proj_arg, j, pbs, subst) = match decl with | LocalDef (na,c,t) -> (* From [params, field1,..,fieldj |- c(params,field1,..,fieldj)] @@ -525,11 +516,12 @@ let compute_projections env (kn, i as ind) = to [params, x:I |- subst:field1,..,fieldj+1] where [subst] is represented with instance of field1 last *) let subst = c1 :: subst in - (j+1, pbs, subst) + (proj_arg, j+1, pbs, subst) | LocalAssum (na,t) -> match na with | Name id -> - let kn = Constant.make1 (KerName.make mp dp (Label.of_id id)) in + let lab = Label.of_id id in + let kn = Projection.Repr.make ind ~proj_npars:mib.mind_nparams ~proj_arg lab in (* from [params, field1,..,fieldj |- t(params,field1,..,fieldj)] to [params, x:I, field1,..,fieldj |- t(params,field1,..,fieldj] *) let t = liftn 1 j t in @@ -544,12 +536,12 @@ let compute_projections env (kn, i as ind) = let etab = it_mkLambda_or_LetIn (mkLambda (x, indty, term)) params in let etat = it_mkProd_or_LetIn (mkProd (x, indty, ty)) params in let body = (etab, etat, compat) in - (j + 1, body :: pbs, fterm :: subst) + (proj_arg + 1, j + 1, body :: pbs, fterm :: subst) | Anonymous -> anomaly Pp.(str "Trying to build primitive projections for a non-primitive record") in - let (_, pbs, subst) = - List.fold_right projections ctx (1, [], []) + let (_, _, pbs, subst) = + List.fold_right projections ctx (0, 1, [], []) in Array.rev_of_list pbs @@ -738,8 +730,8 @@ let type_of_inductive_knowing_conclusion env sigma ((mib,mip),u) conclty = !evdref, EConstr.of_constr (mkArity (List.rev ctx,scl)) let type_of_projection_constant env (p,u) = - let pb = lookup_projection p env in - Vars.subst_instance_constr u pb.proj_type + let pty = lookup_projection p env in + Vars.subst_instance_constr u pty let type_of_projection_knowing_arg env sigma p c ty = let c = EConstr.Unsafe.to_constr c in diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index 8eaef24c48..ea34707bfc 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -130,7 +130,10 @@ val has_dependent_elim : mutual_inductive_body -> bool (** Primitive projections *) val projection_nparams : Projection.t -> int +[@@ocaml.deprecated "Use [Projection.npars]"] val projection_nparams_env : env -> Projection.t -> int +[@@ocaml.deprecated "Use [Projection.npars]"] + val type_of_projection_knowing_arg : env -> evar_map -> Projection.t -> EConstr.t -> EConstr.types -> types @@ -149,7 +152,8 @@ val get_constructor : pinductive * mutual_inductive_body * one_inductive_body * constr list -> int -> constructor_summary val get_constructors : env -> inductive_family -> constructor_summary array -val get_projections : env -> inductive_family -> Constant.t array option +val get_projections : env -> inductive -> Projection.Repr.t array option +[@@ocaml.deprecated "Use [Environ.get_projections]"] (** [get_arity] returns the arity of the inductive family instantiated with the parameters; if recursively non-uniform parameters are not diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index 21c2022057..5df41ef76a 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -185,14 +185,13 @@ let branch_of_switch lvl ans bs = bs ci in Array.init (Array.length tbl) branch -let get_proj env ((mind, n), i) = - let mib = Environ.lookup_mind mind env in - match mib.mind_record with - | NotRecord | FakeRecord -> +let get_proj env (ind, proj_arg) = + let mib = Environ.lookup_mind (fst ind) env in + match Declareops.inductive_make_projection ind mib ~proj_arg with + | None -> CErrors.anomaly (Pp.strbrk "Return type is not a primitive record") - | PrimRecord info -> - let _, projs, _ = info.(n) in - Projection.make projs.(i) true + | Some p -> + Projection.make p true let rec nf_val env sigma v typ = match kind_of_value v with diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index 685aa400b8..f7fea22c0f 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -287,8 +287,7 @@ let rec subst_pattern subst pat = | PEvar _ | PRel _ -> pat | PProj (p,c) -> - let p' = Projection.map (fun p -> - destConstRef (fst (subst_global subst (ConstRef p)))) p in + let p' = Projection.map (subst_mind subst) p in let c' = subst_pattern subst c in if p' == p && c' == c then pat else PProj(p',c') diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 57c4d363b2..3b9a8e6a1d 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -381,8 +381,16 @@ let adjust_evar_source evdref na c = | Name id, Evar (evk,args) -> let evi = Evd.find !evdref evk in begin match evi.evar_source with - | loc, Evar_kinds.QuestionMark (b,Anonymous) -> - let src = (loc,Evar_kinds.QuestionMark (b,na)) in + | loc, Evar_kinds.QuestionMark { + Evar_kinds.qm_obligation=b; + Evar_kinds.qm_name=Anonymous; + Evar_kinds.qm_record_field=recfieldname; + } -> + let src = (loc,Evar_kinds.QuestionMark { + Evar_kinds.qm_obligation=b; + Evar_kinds.qm_name=na; + Evar_kinds.qm_record_field=recfieldname; + }) in let (evd, evk') = restrict_evar !evdref evk (evar_filter evi) ~src None in evdref := evd; mkEvar (evk',args) @@ -765,11 +773,11 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre in let app_f = match EConstr.kind !evdref fj.uj_val with - | Const (p, u) when Environ.is_projection p env.ExtraEnv.env -> + | Const (p, u) when Recordops.is_primitive_projection p -> + let p = Option.get @@ Recordops.find_primitive_projection p in let p = Projection.make p false in - let pb = Environ.lookup_projection p env.ExtraEnv.env in - let npars = pb.Declarations.proj_npars in - fun n -> + let npars = Projection.npars p in + fun n -> if n == npars + 1 then fun _ v -> mkProj (p, v) else fun f v -> applist (f, [v]) | _ -> fun _ f v -> applist (f, [v]) @@ -897,6 +905,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let cloc = loc_of_glob_constr c in error_case_not_inductive ?loc:cloc env.ExtraEnv.env !evdref cj in + let ind = fst (fst (dest_ind_family indf)) in let cstrs = get_constructors env.ExtraEnv.env indf in if not (Int.equal (Array.length cstrs) 1) then user_err ?loc (str "Destructing let is only for inductive types" ++ @@ -907,7 +916,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre int cs.cs_nargs ++ str " variables."); let fsign, record = let set_name na d = set_name na (map_rel_decl EConstr.of_constr d) in - match get_projections env.ExtraEnv.env indf with + match Environ.get_projections env.ExtraEnv.env ind with | None -> List.map2 set_name (List.rev nal) cs.cs_args, false | Some ps -> diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib index 3d9b5d3cfc..5da5aff449 100644 --- a/pretyping/pretyping.mllib +++ b/pretyping/pretyping.mllib @@ -14,6 +14,7 @@ Find_subterm Evardefine Evarsolve Recordops +Heads Evarconv Typing Miscops diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 56a8830991..2f861c117b 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -44,7 +44,7 @@ type struc_typ = { let structure_table = Summary.ref (Indmap.empty : struc_typ Indmap.t) ~name:"record-structs" let projection_table = - Summary.ref Cmap.empty ~name:"record-projs" + Summary.ref (Cmap.empty : struc_typ Cmap.t) ~name:"record-projs" (* TODO: could be unify struc_typ and struc_tuple ? in particular, is the inductive always (fst constructor) ? It seems so... *) @@ -53,7 +53,9 @@ type struc_tuple = inductive * constructor * (Name.t * bool) list * Constant.t option list let load_structure i (_,(ind,id,kl,projs)) = - let n = (fst (Global.lookup_inductive ind)).Declarations.mind_nparams in + let open Declarations in + let mib, mip = Global.lookup_inductive ind in + let n = mib.mind_nparams in let struc = { s_CONST = id; s_EXPECTEDPARAM = n; s_PROJ = projs; s_PROJKIND = kl } in structure_table := Indmap.add ind struc !structure_table; @@ -107,6 +109,34 @@ let find_projection = function | ConstRef cst -> Cmap.find cst !projection_table | _ -> raise Not_found +let prim_table = + Summary.ref (Cmap_env.empty : Projection.Repr.t Cmap_env.t) ~name:"record-prim-projs" + +let load_prim i (_,p) = + prim_table := Cmap_env.add (Projection.Repr.constant p) p !prim_table + +let cache_prim p = load_prim 1 p + +let subst_prim (subst,p) = subst_proj_repr subst p + +let discharge_prim (_,p) = Some (Lib.discharge_proj_repr p) + +let inPrim : Projection.Repr.t -> obj = + declare_object { + (default_object "PRIMPROJS") with + cache_function = cache_prim ; + load_function = load_prim; + subst_function = subst_prim; + classify_function = (fun x -> Substitute x); + discharge_function = discharge_prim } + +let declare_primitive_projection p = Lib.add_anonymous_leaf (inPrim p) + +let is_primitive_projection c = Cmap_env.mem c !prim_table + +let find_primitive_projection c = + try Some (Cmap_env.find c !prim_table) with Not_found -> None + (************************************************************************) (*s A canonical structure declares "canonical" conversion hints between *) (* the effective components of a structure and the projections of the *) diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli index 748f053b2f..415b964168 100644 --- a/pretyping/recordops.mli +++ b/pretyping/recordops.mli @@ -44,6 +44,13 @@ val find_projection_nparams : GlobRef.t -> int (** raise [Not_found] if not a projection *) val find_projection : GlobRef.t -> struc_typ +(** Sets up the mapping from constants to primitive projections *) +val declare_primitive_projection : Projection.Repr.t -> unit + +val is_primitive_projection : Constant.t -> bool + +val find_primitive_projection : Constant.t -> Projection.Repr.t option + (** {6 Canonical structures } *) (** A canonical structure declares "canonical" conversion hints between the effective components of a structure and the projections of the diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 7fb1a0a578..ba40262815 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -47,29 +47,28 @@ open Libobject type effect_name = string (** create a persistent set to store effect functions *) -module ConstrMap = Map.Make (Constr) (* Table bindings a constant to an effect *) -let constant_effect_table = Summary.ref ~name:"reduction-side-effect" ConstrMap.empty +let constant_effect_table = Summary.ref ~name:"reduction-side-effect" Cmap.empty (* Table bindings function key to effective functions *) let effect_table = Summary.ref ~name:"reduction-function-effect" String.Map.empty (** a test to know whether a constant is actually the effect function *) -let reduction_effect_hook env sigma termkey c = +let reduction_effect_hook env sigma con c = try - let funkey = ConstrMap.find termkey !constant_effect_table in + let funkey = Cmap.find con !constant_effect_table in let effect = String.Map.find funkey !effect_table in effect env sigma (Lazy.force c) with Not_found -> () -let cache_reduction_effect (_,(termkey,funkey)) = - constant_effect_table := ConstrMap.add termkey funkey !constant_effect_table +let cache_reduction_effect (_,(con,funkey)) = + constant_effect_table := Cmap.add con funkey !constant_effect_table -let subst_reduction_effect (subst,(termkey,funkey)) = - (subst_mps subst termkey,funkey) +let subst_reduction_effect (subst,(con,funkey)) = + (subst_constant subst con,funkey) -let inReductionEffect : Constr.constr * string -> obj = +let inReductionEffect : Constant.t * string -> obj = declare_object {(default_object "REDUCTION-EFFECT") with cache_function = cache_reduction_effect; open_function = (fun i o -> if Int.equal i 1 then cache_reduction_effect o); @@ -83,8 +82,7 @@ let declare_reduction_effect funkey f = (** A function to set the value of the print function *) let set_reduction_effect x funkey = - let termkey = UnivGen.constr_of_global x in - Lib.add_anonymous_leaf (inReductionEffect (termkey,funkey)) + Lib.add_anonymous_leaf (inReductionEffect (x,funkey)) (** Machinery to custom the behavior of the reduction *) @@ -280,7 +278,7 @@ sig type 'a member = | App of 'a app_node | Case of case_info * 'a * 'a array * Cst_stack.t - | Proj of int * int * Projection.t * Cst_stack.t + | Proj of Projection.t * Cst_stack.t | Fix of ('a, 'a) pfixpoint * 'a t * Cst_stack.t | Cst of cst_member * int * int list * 'a t * Cst_stack.t and 'a t = 'a member list @@ -337,7 +335,7 @@ struct type 'a member = | App of 'a app_node | Case of case_info * 'a * 'a array * Cst_stack.t - | Proj of int * int * Projection.t * Cst_stack.t + | Proj of Projection.t * Cst_stack.t | Fix of ('a, 'a) pfixpoint * 'a t * Cst_stack.t | Cst of cst_member * int * int list * 'a t * Cst_stack.t and 'a t = 'a member list @@ -351,9 +349,8 @@ struct str "ZCase(" ++ prvect_with_sep (pr_bar) pr_c br ++ str ")" - | Proj (n,m,p,cst) -> - str "ZProj(" ++ int n ++ pr_comma () ++ int m ++ - pr_comma () ++ Constant.print (Projection.constant p) ++ str ")" + | Proj (p,cst) -> + str "ZProj(" ++ Constant.print (Projection.constant p) ++ str ")" | Fix (f,args,cst) -> str "ZFix(" ++ Termops.pr_fix pr_c f ++ pr_comma () ++ pr pr_c args ++ str ")" @@ -413,10 +410,9 @@ struct (f t1 t2) && (equal_rec s1' s2') | Case (_,t1,a1,_) :: s1, Case (_,t2,a2,_) :: s2 -> f t1 t2 && CArray.equal (fun x y -> f x y) a1 a2 && equal_rec s1 s2 - | (Proj (n1,m1,p,_)::s1, Proj(n2,m2,p2,_)::s2) -> - Int.equal n1 n2 && Int.equal m1 m2 - && Constant.equal (Projection.constant p) (Projection.constant p2) - && equal_rec s1 s2 + | (Proj (p,_)::s1, Proj(p2,_)::s2) -> + Projection.Repr.equal (Projection.repr p) (Projection.repr p2) + && equal_rec s1 s2 | Fix (f1,s1,_) :: s1', Fix (f2,s2,_) :: s2' -> f_fix f1 f2 && equal_rec (List.rev s1) (List.rev s2) @@ -436,7 +432,7 @@ struct | (_, App (i,_,j)::s2) -> compare_rec (bal - j - 1 + i) stk1 s2 | (Case(c1,_,_,_)::s1, Case(c2,_,_,_)::s2) -> Int.equal bal 0 (* && c1.ci_ind = c2.ci_ind *) && compare_rec 0 s1 s2 - | (Proj (n1,m1,p,_)::s1, Proj(n2,m2,p2,_)::s2) -> + | (Proj (p,_)::s1, Proj(p2,_)::s2) -> Int.equal bal 0 && compare_rec 0 s1 s2 | (Fix(_,a1,_)::s1, Fix(_,a2,_)::s2) -> Int.equal bal 0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2 @@ -456,7 +452,7 @@ struct aux (f o t1 t2) l1 l2 | Case (_,t1,a1,_) :: q1, Case (_,t2,a2,_) :: q2 -> aux (Array.fold_left2 f (f o t1 t2) a1 a2) q1 q2 - | Proj (n1,m1,p1,_) :: q1, Proj (n2,m2,p2,_) :: q2 -> + | Proj (p1,_) :: q1, Proj (p2,_) :: q2 -> aux o q1 q2 | Fix ((_,(_,a1,b1)),s1,_) :: q1, Fix ((_,(_,a2,b2)),s2,_) :: q2 -> let o' = aux (Array.fold_left2 f (Array.fold_left2 f o b1 b2) a1 a2) (List.rev s1) (List.rev s2) in @@ -469,7 +465,7 @@ struct in aux o (List.rev sk1) (List.rev sk2) let rec map f x = List.map (function - | (Proj (_,_,_,_)) as e -> e + | (Proj (_,_)) as e -> e | App (i,a,j) -> let le = j - i + 1 in App (0,Array.map f (Array.sub a i le), le-1) @@ -513,7 +509,7 @@ struct let will_expose_iota args = List.exists (function (Fix (_,_,l) | Case (_,_,_,l) | - Proj (_,_,_,l) | Cst (_,_,_,_,l)) when Cst_stack.is_empty l -> true | _ -> false) + Proj (_,l) | Cst (_,_,_,_,l)) when Cst_stack.is_empty l -> true | _ -> false) args let list_of_app_stack s = @@ -590,9 +586,9 @@ struct zip (best_state sigma (constr_of_cst_member cst (params @ (append_app [|f|] s))) cst_l) | f, (Cst (cst,_,_,params,_)::s) -> zip (constr_of_cst_member cst (params @ (append_app [|f|] s))) - | f, (Proj (n,m,p,cst_l)::s) when refold -> + | f, (Proj (p,cst_l)::s) when refold -> zip (best_state sigma (mkProj (p,f),s) cst_l) - | f, (Proj (n,m,p,_)::s) -> zip (mkProj (p,f),s) + | f, (Proj (p,_)::s) -> zip (mkProj (p,f),s) in zip s @@ -874,7 +870,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = | Some body -> whrec cst_l (body, stack) | None -> fold ()) | Const (c,u as const) -> - reduction_effect_hook env sigma (EConstr.to_constr sigma x) + reduction_effect_hook env sigma c (lazy (EConstr.to_constr sigma (Stack.zip sigma (x,stack)))); if CClosure.RedFlags.red_set flags (CClosure.RedFlags.fCONST c) then let u' = EInstance.kind sigma u in @@ -920,16 +916,13 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = (arg,Stack.Cst(Stack.Cst_const (fst const, u'),curr,remains,bef,cst_l)::s') ) else fold () | Proj (p, c) when CClosure.RedFlags.red_projection flags p -> - (let pb = lookup_projection p env in - let kn = Projection.constant p in - let npars = pb.Declarations.proj_npars - and arg = pb.Declarations.proj_arg in - if not tactic_mode then - let stack' = (c, Stack.Proj (npars, arg, p, Cst_stack.empty (*cst_l*)) :: stack) in + (let npars = Projection.npars p in + if not tactic_mode then + let stack' = (c, Stack.Proj (p, Cst_stack.empty (*cst_l*)) :: stack) in whrec Cst_stack.empty stack' - else match ReductionBehaviour.get (Globnames.ConstRef kn) with + else match ReductionBehaviour.get (Globnames.ConstRef (Projection.constant p)) with | None -> - let stack' = (c, Stack.Proj (npars, arg, p, cst_l) :: stack) in + let stack' = (c, Stack.Proj (p, cst_l) :: stack) in let stack'', csts = whrec Cst_stack.empty stack' in if equal_stacks sigma stack' stack'' then fold () else stack'', csts @@ -946,7 +939,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = |[] -> (* if nargs has been specified *) (* CAUTION : the constant is NEVER refold (even when it hides a (co)fix) *) - let stack' = (c, Stack.Proj (npars, arg, p, cst_l) :: stack) in + let stack' = (c, Stack.Proj (p, cst_l) :: stack) in whrec Cst_stack.empty(* cst_l *) stack' | curr::remains -> if curr == 0 then (* Try to reduce the record argument *) @@ -1005,8 +998,8 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = match Stack.strip_app stack with |args, (Stack.Case(ci, _, lf,_)::s') when use_match -> whrec Cst_stack.empty (lf.(c-1), (Stack.tail ci.ci_npar args) @ s') - |args, (Stack.Proj (n,m,p,_)::s') when use_match -> - whrec Cst_stack.empty (Stack.nth args (n+m), s') + |args, (Stack.Proj (p,_)::s') when use_match -> + whrec Cst_stack.empty (Stack.nth args (Projection.npars p + Projection.arg p), s') |args, (Stack.Fix (f,s',cst_l)::s'') when use_fix -> let x' = Stack.zip sigma (x, args) in let out_sk = s' @ (Stack.append_app [|x'|] s'') in @@ -1025,14 +1018,11 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = whrec (if refold then Cst_stack.add_cst (mkConstU const) cst_l else cst_l) (body, s' @ (Stack.append_app [|x'|] s''))) | Stack.Cst_proj p -> - let pb = lookup_projection p env in - let npars = pb.Declarations.proj_npars in - let narg = pb.Declarations.proj_arg in - let stack = s' @ (Stack.append_app [|x'|] s'') in + let stack = s' @ (Stack.append_app [|x'|] s'') in match Stack.strip_n_app 0 stack with | None -> assert false | Some (_,arg,s'') -> - whrec Cst_stack.empty (arg, Stack.Proj (npars,narg,p,cst_l) :: s'')) + whrec Cst_stack.empty (arg, Stack.Proj (p,cst_l) :: s'')) | next :: remains' -> match Stack.strip_n_app (next-curr-1) s'' with | None -> fold () | Some (bef,arg,s''') -> @@ -1090,10 +1080,7 @@ let local_whd_state_gen flags sigma = | _ -> s) | Proj (p,c) when CClosure.RedFlags.red_projection flags p -> - (let pb = lookup_projection p (Global.env ()) in - whrec (c, Stack.Proj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, - p, Cst_stack.empty) - :: stack)) + (whrec (c, Stack.Proj (p, Cst_stack.empty) :: stack)) | Case (ci,p,d,lf) -> whrec (d, Stack.Case (ci,p,lf,Cst_stack.empty) :: stack) @@ -1116,8 +1103,8 @@ let local_whd_state_gen flags sigma = match Stack.strip_app stack with |args, (Stack.Case(ci, _, lf,_)::s') when use_match -> whrec (lf.(c-1), (Stack.tail ci.ci_npar args) @ s') - |args, (Stack.Proj (n,m,p,_) :: s') when use_match -> - whrec (Stack.nth args (n+m), s') + |args, (Stack.Proj (p,_) :: s') when use_match -> + whrec (Stack.nth args (Projection.npars p + Projection.arg p), s') |args, (Stack.Fix (f,s',cst)::s'') when use_fix -> let x' = Stack.zip sigma (x,args) in whrec (contract_fix sigma f, s' @ (Stack.append_app [|x'|] s'')) @@ -1576,11 +1563,11 @@ let whd_betaiota_deltazeta_for_iota_state ts env sigma csts s = let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' ~refold ~tactic_mode (CClosure.RedFlags.red_add_transparent CClosure.all ts) env sigma (t,args) in if isConstruct sigma t_o then whrec csts_o (t_o, stack_o@stack') else s,csts' - |args, (Stack.Proj (n,m,p,_) :: stack'') -> + |args, (Stack.Proj (p,_) :: stack'') -> let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' ~refold ~tactic_mode (CClosure.RedFlags.red_add_transparent CClosure.all ts) env sigma (t,args) in if isConstruct sigma t_o then - whrec Cst_stack.empty (Stack.nth stack_o (n+m), stack'') + whrec Cst_stack.empty (Stack.nth stack_o (Projection.npars p + Projection.arg p), stack'') else s,csts' |_, ((Stack.App _|Stack.Cst _) :: _|[]) -> s,csts' in whrec csts s diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 9256fa7ce6..07eeec9276 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -41,10 +41,10 @@ val declare_reduction_effect : effect_name -> (Environ.env -> Evd.evar_map -> Constr.constr -> unit) -> unit (* [set_reduction_effect cst name] declares effect [name] to be called when [cst] is found *) -val set_reduction_effect : GlobRef.t -> effect_name -> unit +val set_reduction_effect : Constant.t -> effect_name -> unit (* [effect_hook env sigma key term] apply effect associated to [key] on [term] *) -val reduction_effect_hook : Environ.env -> Evd.evar_map -> Constr.constr -> +val reduction_effect_hook : Environ.env -> Evd.evar_map -> Constant.t -> Constr.constr Lazy.t -> unit (** {6 Machinery about a stack of unfolded constant } @@ -75,7 +75,7 @@ module Stack : sig type 'a member = | App of 'a app_node | Case of case_info * 'a * 'a array * Cst_stack.t - | Proj of int * int * Projection.t * Cst_stack.t + | Proj of Projection.t * Cst_stack.t | Fix of ('a, 'a) pfixpoint * 'a t * Cst_stack.t | Cst of cst_member * int (** current foccussed arg *) * int list (** remaining args *) * 'a t * Cst_stack.t diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 40c4cfaa45..8911a2f343 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -49,7 +49,7 @@ let error_not_evaluable r = let is_evaluable_const env cst = is_transparent env (ConstKey cst) && - (evaluable_constant cst env || is_projection cst env) + evaluable_constant cst env let is_evaluable_var env id = is_transparent env (VarKey id) && evaluable_named id env @@ -539,7 +539,7 @@ let reduce_mind_case_use_function func env sigma mia = let match_eval_ref env sigma constr stack = match EConstr.kind sigma constr with | Const (sp, u) -> - reduction_effect_hook env sigma (EConstr.to_constr sigma constr) + reduction_effect_hook env sigma sp (lazy (EConstr.to_constr sigma (applist (constr,stack)))); if is_evaluable env (EvalConstRef sp) then Some (EvalConst sp, u) else None | Var id when is_evaluable env (EvalVarRef id) -> Some (EvalVar id, EInstance.empty) @@ -550,7 +550,7 @@ let match_eval_ref env sigma constr stack = let match_eval_ref_value env sigma constr stack = match EConstr.kind sigma constr with | Const (sp, u) -> - reduction_effect_hook env sigma (EConstr.to_constr sigma constr) + reduction_effect_hook env sigma sp (lazy (EConstr.to_constr sigma (applist (constr,stack)))); if is_evaluable env (EvalConstRef sp) then let u = EInstance.kind sigma u in @@ -558,8 +558,6 @@ let match_eval_ref_value env sigma constr stack = else None | Proj (p, c) when not (Projection.unfolded p) -> - reduction_effect_hook env sigma (EConstr.to_constr ~abort_on_undefined_evars:false sigma constr) - (lazy (EConstr.to_constr sigma (applist (constr,stack)))); if is_evaluable env (EvalConstRef (Projection.constant p)) then Some (mkProj (Projection.unfold p, c)) else None @@ -597,12 +595,11 @@ let recargs = function | EvalVar _ | EvalRel _ | EvalEvar _ -> None | EvalConst c -> ReductionBehaviour.get (ConstRef c) -let reduce_projection env sigma pb (recarg'hd,stack') stack = +let reduce_projection env sigma p ~npars (recarg'hd,stack') stack = (match EConstr.kind sigma recarg'hd with | Construct _ -> - let proj_narg = - pb.Declarations.proj_npars + pb.Declarations.proj_arg - in Reduced (List.nth stack' proj_narg, stack) + let proj_narg = npars + Projection.arg p in + Reduced (List.nth stack' proj_narg, stack) | _ -> NotReducible) let reduce_proj env sigma whfun whfun' c = @@ -613,10 +610,8 @@ let reduce_proj env sigma whfun whfun' c = let constr, cargs = whfun c' in (match EConstr.kind sigma constr with | Construct _ -> - let proj_narg = - let pb = lookup_projection proj env in - pb.Declarations.proj_npars + pb.Declarations.proj_arg - in List.nth cargs proj_narg + let proj_narg = Projection.npars proj + Projection.arg proj in + List.nth cargs proj_narg | _ -> raise Redelimination) | Case (n,p,c,brs) -> let c' = redrec c in @@ -765,22 +760,22 @@ and whd_simpl_stack env sigma = (try let unf = Projection.unfolded p in if unf || is_evaluable env (EvalConstRef (Projection.constant p)) then - let pb = lookup_projection p env in + let npars = Projection.npars p in (match unf, ReductionBehaviour.get (ConstRef (Projection.constant p)) with | false, Some (l, n, f) when List.mem `ReductionNeverUnfold f -> (* simpl never *) s' | false, Some (l, n, f) when not (List.is_empty l) -> let l' = List.map_filter (fun i -> - let idx = (i - (pb.Declarations.proj_npars + 1)) in + let idx = (i - (npars + 1)) in if idx < 0 then None else Some idx) l in let stack = reduce_params env sigma stack l' in - (match reduce_projection env sigma pb + (match reduce_projection env sigma p ~npars (whd_construct_stack env sigma c) stack with | Reduced s' -> redrec (applist s') | NotReducible -> s') | _ -> - match reduce_projection env sigma pb (whd_construct_stack env sigma c) stack with + match reduce_projection env sigma p ~npars (whd_construct_stack env sigma c) stack with | Reduced s' -> redrec (applist s') | NotReducible -> s') else s' @@ -852,8 +847,8 @@ let try_red_product env sigma c = | Construct _ -> c | _ -> redrec env c in - let pb = lookup_projection p env in - (match reduce_projection env sigma pb (whd_betaiotazeta_stack sigma c') [] with + let npars = Projection.npars p in + (match reduce_projection env sigma p ~npars (whd_betaiotazeta_stack sigma c') [] with | Reduced s -> simpfun (applist s) | NotReducible -> raise Redelimination) | _ -> @@ -946,8 +941,8 @@ let whd_simpl_orelse_delta_but_fix env sigma c = (match EConstr.kind sigma constr with | Const (c', _) -> Constant.equal (Projection.constant p) c' | _ -> false) -> - let pb = Environ.lookup_projection p env in - if List.length stack <= pb.Declarations.proj_npars then + let npars = Projection.npars p in + if List.length stack <= npars then (** Do not show the eta-expanded form *) s' else redrec (applist (c, stack)) diff --git a/pretyping/typing.ml b/pretyping/typing.ml index ca2702d741..4ba715f0d5 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -253,16 +253,16 @@ let judge_of_variable env id = Termops.on_judgment EConstr.of_constr (judge_of_variable env id) let judge_of_projection env sigma p cj = - let pb = lookup_projection p env in + let pty = lookup_projection p env in let (ind,u), args = try find_mrectype env sigma cj.uj_type with Not_found -> error_case_not_inductive env sigma cj in let u = EInstance.kind sigma u in - let ty = EConstr.of_constr (CVars.subst_instance_constr u pb.Declarations.proj_type) in - let ty = substl (cj.uj_val :: List.rev args) ty in - {uj_val = EConstr.mkProj (p,cj.uj_val); - uj_type = ty} + let ty = EConstr.of_constr (CVars.subst_instance_constr u pty) in + let ty = substl (cj.uj_val :: List.rev args) ty in + {uj_val = EConstr.mkProj (p,cj.uj_val); + uj_type = ty} let judge_of_abstraction env name var j = { uj_val = mkLambda (name, var.utj_val, j.uj_val); diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 4ba5d27947..fc1f6fc81e 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -478,12 +478,8 @@ let expand_table_key env = function | RelKey _ -> None let unfold_projection env p stk = - (match try Some (lookup_projection p env) with Not_found -> None with - | Some pb -> - let s = Stack.Proj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, - p, Cst_stack.empty) in - s :: stk - | None -> assert false) + let s = Stack.Proj (p, Cst_stack.empty) in + s :: stk let expand_key ts env sigma = function | Some (IsKey k) -> Option.map EConstr.of_constr (expand_table_key env k) @@ -512,7 +508,7 @@ let key_of env sigma b flags f = match EConstr.kind sigma f with | Const (cst, u) when is_transparent env (ConstKey cst) && (Cpred.mem cst (snd flags.modulo_delta) - || Environ.is_projection cst env) -> + || Recordops.is_primitive_projection cst) -> let u = EInstance.kind sigma u in Some (IsKey (ConstKey (cst, u))) | Var id when is_transparent env (VarKey id) && @@ -669,17 +665,15 @@ let is_eta_constructor_app env sigma ts f l1 term = | _ -> false let eta_constructor_app env sigma f l1 term = - let open Declarations in match EConstr.kind sigma f with | Construct (((_, i as ind), j), u) -> let mib = lookup_mind (fst ind) env in - (match mib.Declarations.mind_record with - | PrimRecord info -> - let (_, projs, _) = info.(i) in + (match get_projections env ind with + | Some projs -> let npars = mib.Declarations.mind_nparams in let pars, l1' = Array.chop npars l1 in let arg = Array.append pars [|term|] in - let l2 = Array.map (fun p -> mkApp (mkConstU (p,u), arg)) projs in + let l2 = Array.map (fun p -> mkApp (mkConstU (Projection.Repr.constant p,u), arg)) projs in l1', l2 | _ -> assert false) | _ -> assert false diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index c944080503..255707dc7b 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -209,6 +209,9 @@ and nf_evar env sigma evk stk = | Zapp args :: stk -> (** We assume that there is no consecutive Zapp nodes in a VM stack. Is that really an invariant? *) + (** Let-bound arguments are present in the evar arguments but not in the + type, so we turn the let into a product. *) + let hyps = Context.Named.drop_bodies hyps in let fold accu d = Term.mkNamedProd_or_LetIn d accu in let t = List.fold_left fold concl hyps in let t, args = nf_args env sigma args t in diff --git a/printing/prettyp.ml b/printing/prettyp.ml index fd7135b6a6..1810cc6588 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -98,7 +98,8 @@ let print_ref reduce ref udecl = (Array.to_list (Univ.Instance.to_array inst)) udecl in let sigma = Evd.from_ctx (UState.of_binders bl) in let inst = - if Global.is_polymorphic ref then Printer.pr_universe_instance sigma univs + if Global.is_polymorphic ref + then Printer.pr_universe_instance sigma (Univ.UContext.instance univs) else mt () in hov 0 (pr_global ref ++ inst ++ str " :" ++ spc () ++ pr_letype_env env sigma typ ++ @@ -552,8 +553,7 @@ let print_instance sigma cb = if Declareops.constant_is_polymorphic cb then let univs = Declareops.constant_polymorphic_context cb in let inst = Univ.AUContext.instance univs in - let univs = Univ.UContext.make (inst, Univ.AUContext.instantiate inst univs) in - pr_universe_instance sigma univs + pr_universe_instance sigma inst else mt() let print_constant with_values sep sp udecl = @@ -657,14 +657,10 @@ let gallina_print_library_entry env sigma with_values ent = gallina_print_leaf_entry env sigma with_values (oname,lobj) | (oname,Lib.OpenedSection (dir,_)) -> Some (str " >>>>>>> Section " ++ pr_name oname) - | (oname,Lib.ClosedSection _) -> - Some (str " >>>>>>> Closed Section " ++ pr_name oname) | (_,Lib.CompilingLibrary { obj_dir; _ }) -> Some (str " >>>>>>> Library " ++ DirPath.print obj_dir) | (oname,Lib.OpenedModule _) -> Some (str " >>>>>>> Module " ++ pr_name oname) - | (oname,Lib.ClosedModule _) -> - Some (str " >>>>>>> Closed Module " ++ pr_name oname) let gallina_print_context env sigma with_values = let rec prec n = function @@ -793,9 +789,6 @@ let read_sec_context qid = let rec get_cxt in_cxt = function | (_,Lib.OpenedSection ({obj_dir;_},_) as hd)::rest -> if DirPath.equal dir obj_dir then (hd::in_cxt) else get_cxt (hd::in_cxt) rest - | (_,Lib.ClosedSection _)::rest -> - user_err Pp.(str "Cannot print the contents of a closed section.") - (* LEM: Actually, we could if we wanted to. *) | [] -> [] | hd::rest -> get_cxt (hd::in_cxt) rest in @@ -909,7 +902,7 @@ let inspect env sigma depth = open Classops -let print_coercion_value env sigma v = pr_lconstr_env env sigma (get_coercion_value v) +let print_coercion_value env sigma v = Printer.pr_global v.coe_value let print_class i = let cl,_ = class_info_from_index i in diff --git a/printing/printer.ml b/printing/printer.ml index 92224c992c..a77c1ced56 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -290,11 +290,13 @@ let pr_cumulativity_info sigma cumi = let pr_global_env = pr_global_env let pr_global = pr_global_env Id.Set.empty -let pr_puniverses f env (c,u) = - f env c ++ - (if !Constrextern.print_universes then - str"(*" ++ Univ.Instance.pr UnivNames.pr_with_global_universes u ++ str"*)" - else mt ()) +let pr_universe_instance evd inst = + str"@{" ++ Univ.Instance.pr (Termops.pr_evd_level evd) inst ++ str"}" + +let pr_puniverses f env sigma (c,u) = + if !Constrextern.print_universes + then f env c ++ pr_universe_instance sigma u + else f env c let pr_constant env cst = pr_global_env (Termops.vars_of_env env) (ConstRef cst) let pr_existential_key = Termops.pr_existential_key @@ -493,16 +495,23 @@ let pr_transparent_state (ids, csts) = hv 0 (str"VARIABLES: " ++ pr_idpred ids ++ fnl () ++ str"CONSTANTS: " ++ pr_cpred csts ++ fnl ()) -(* display complete goal *) -let pr_goal gs = +(* display complete goal + prev_gs has info on the previous proof step for diffs + gs has info on the current proof step + *) +let pr_goal ?(diffs=false) ?prev_gs gs = let g = sig_it gs in let sigma = project gs in let env = Goal.V82.env sigma g in let concl = Goal.V82.concl sigma g in let goal = - pr_context_of env sigma ++ cut () ++ - str "============================" ++ cut () ++ - pr_goal_concl_style_env env sigma concl in + if diffs then + Proof_diffs.diff_goals ?prev_gs (Some gs) + else + pr_context_of env sigma ++ cut () ++ + str "============================" ++ cut () ++ + pr_goal_concl_style_env env sigma concl + in str " " ++ v 0 goal (* display a goal tag *) @@ -695,7 +704,8 @@ let print_dependent_evars gl sigma seeds = (* spiwack: [seeds] is for printing dependent evars in emacs mode. *) (* spiwack: [pr_first] is true when the first goal must be singled out and printed in its entirety. *) -let pr_subgoals ?(pr_first=true) +(* [prev] is the previous proof step, used for diffs *) +let pr_subgoals ?(pr_first=true) ?(diffs=false) ?prev close_cmd sigma ~seeds ~shelf ~stack ~unfocused ~goals = (** Printing functions for the extra informations. *) let rec print_stack a = function @@ -729,7 +739,7 @@ let pr_subgoals ?(pr_first=true) if needed then str" focused " else str" " (* non-breakable space *) in - (** Main function *) + let rec pr_rec n = function | [] -> (mt ()) | g::rest -> @@ -739,7 +749,14 @@ let pr_subgoals ?(pr_first=true) in let print_multiple_goals g l = if pr_first then - pr_goal { it = g ; sigma = sigma; } + let prev_gs = + match prev with + | Some (prev_goals, prev_sigma) -> + if prev_goals = [] then None + else Some { it = List.hd prev_goals; sigma = prev_sigma} + | None -> None + in + pr_goal ~diffs ?prev_gs { it = g ; sigma = sigma } ++ (if l=[] then mt () else cut ()) ++ pr_rec 2 l else @@ -751,6 +768,8 @@ let pr_subgoals ?(pr_first=true) | Some cmd -> Feedback.msg_info cmd | None -> () in + + (** Main function *) match goals with | [] -> begin @@ -780,7 +799,7 @@ let pr_subgoals ?(pr_first=true) ++ print_dependent_evars (Some g1) sigma seeds ) -let pr_open_subgoals ~proof = +let pr_open_subgoals_diff ?(quiet=false) ?(diffs=false) ?prev_proof proof = (* spiwack: it shouldn't be the job of the printer to look up stuff in the [evar_map], I did stuff that way because it was more straightforward, but seriously, [Proof.proof] should return @@ -803,21 +822,33 @@ let pr_open_subgoals ~proof = fnl () ++ pr_subgoals ~pr_first:false None bsigma ~seeds ~shelf:[] ~stack:[] ~unfocused:[] ~goals:shelf | _ , _, _ -> - let end_cmd = - str "This subproof is complete, but there are some unfocused goals." ++ - (let s = Proof_bullet.suggest p in - if Pp.ismt s then s else fnl () ++ s) ++ - fnl () + let cmd = if quiet then None else + Some + (str "This subproof is complete, but there are some unfocused goals." ++ + (let s = Proof_bullet.suggest p in + if Pp.ismt s then s else fnl () ++ s) ++ + fnl ()) in - pr_subgoals ~pr_first:false (Some end_cmd) bsigma ~seeds ~shelf ~stack:[] ~unfocused:[] ~goals:bgoals + pr_subgoals ~pr_first:false cmd bsigma ~seeds ~shelf ~stack:[] ~unfocused:[] ~goals:bgoals end | _ -> let { Evd.it = bgoals ; sigma = bsigma } = Proof.V82.background_subgoals p in let bgoals_focused, bgoals_unfocused = List.partition (fun x -> List.mem x goals) bgoals in let unfocused_if_needed = if should_unfoc() then bgoals_unfocused else [] in - pr_subgoals ~pr_first:true None bsigma ~seeds ~shelf ~stack:[] ~unfocused:unfocused_if_needed ~goals:bgoals_focused + let prev = match prev_proof with + | Some op -> + let (ogoals , _, _, _, _) = Proof.proof op in + let { Evd.it = obgoals; sigma = osigma } = Proof.V82.background_subgoals op in + let obgoals_focused = List.filter (fun x -> List.mem x ogoals) obgoals in + Some (obgoals_focused, osigma) + | None -> None + in + pr_subgoals ~pr_first:true ~diffs ?prev None bsigma ~seeds ~shelf ~stack:[] ~unfocused:unfocused_if_needed ~goals:bgoals_focused end +let pr_open_subgoals ~proof = + pr_open_subgoals_diff proof + let pr_nth_open_subgoal ~proof n = let gls,_,_,_,sigma = Proof.proof proof in pr_subgoal n sigma gls @@ -987,6 +1018,29 @@ let pr_polymorphic b = if b then str"Polymorphic " else str"Monomorphic " else mt () -let pr_universe_instance evd ctx = - let inst = Univ.UContext.instance ctx in - str"@{" ++ Univ.Instance.pr (Termops.pr_evd_level evd) inst ++ str"}" +(* print the proof step, possibly with diffs highlighted, *) +let print_and_diff oldp newp = + match newp with + | None -> () + | Some proof -> + let output = + if Proof_diffs.show_diffs () then + try pr_open_subgoals_diff ~diffs:true ?prev_proof:oldp proof + with Pp_diff.Diff_Failure msg -> begin + (* todo: print the unparsable string (if we know it) *) + Feedback.msg_warning Pp.(str ("Diff failure:" ^ msg ^ "; showing results without diff highlighting" )); + pr_open_subgoals ~proof + end + else + pr_open_subgoals ~proof + in + Feedback.msg_notice output;; + +(* Do diffs on the first goal returning a Pp. *) +let diff_pr_open_subgoals ?(quiet=false) o_proof n_proof = + match n_proof with + | None -> Pp.mt () + | Some proof -> + try pr_open_subgoals_diff ~quiet ~diffs:true ?prev_proof:o_proof proof + with Pp_diff.Diff_Failure _ -> pr_open_subgoals ~proof + (* todo: print the unparsable string (if we know it) *) diff --git a/printing/printer.mli b/printing/printer.mli index eddfef6fad..971241d5f9 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -120,7 +120,7 @@ val pr_sort : evar_map -> Sorts.t -> Pp.t val pr_polymorphic : bool -> Pp.t val pr_cumulative : bool -> bool -> Pp.t -val pr_universe_instance : evar_map -> Univ.UContext.t -> Pp.t +val pr_universe_instance : evar_map -> Univ.Instance.t -> Pp.t val pr_universe_ctx : evar_map -> ?variance:Univ.Variance.t array -> Univ.UContext.t -> Pp.t val pr_universe_ctx_set : evar_map -> Univ.ContextSet.t -> Pp.t @@ -139,9 +139,9 @@ val pr_constructor : env -> constructor -> Pp.t val pr_inductive : env -> inductive -> Pp.t val pr_evaluable_reference : evaluable_global_reference -> Pp.t -val pr_pconstant : env -> pconstant -> Pp.t -val pr_pinductive : env -> pinductive -> Pp.t -val pr_pconstructor : env -> pconstructor -> Pp.t +val pr_pconstant : env -> evar_map -> pconstant -> Pp.t +val pr_pinductive : env -> evar_map -> pinductive -> Pp.t +val pr_pconstructor : env -> evar_map -> pconstructor -> Pp.t (** Contexts *) @@ -171,22 +171,26 @@ val pr_transparent_state : transparent_state -> Pp.t (** Proofs, these functions obey [Hyps Limit] and [Compact contexts]. *) -val pr_goal : goal sigma -> Pp.t +val pr_goal : ?diffs:bool -> ?prev_gs:(goal sigma) -> goal sigma -> Pp.t -(** [pr_subgoals ~pr_first pp sigma seeds shelf focus_stack unfocused goals] +(** [pr_subgoals ~pr_first ~prev_proof pp sigma seeds shelf focus_stack unfocused goals] prints the goals of the list [goals] followed by the goals in [unfocused], in a short way (typically only the conclusion) except - for the first goal if [pr_first] is true. This function can be - replaced by another one by calling [set_printer_pr] (see below), - typically by plugin writers. The default printer prints only the + for the first goal if [pr_first] is true. Also, if [diffs] is true + and [pr_first] is true, then highlight diffs relative to [prev] in the + output for first goal. This function prints only the focused goals unless the conrresponding option [enable_unfocused_goal_printing] is set. [seeds] is for printing dependent evars (mainly for emacs proof tree mode). *) -val pr_subgoals : ?pr_first:bool -> Pp.t option -> evar_map -> seeds:goal list -> shelf:goal list -> stack:int list -> unfocused:goal list -> goals:goal list -> Pp.t +val pr_subgoals : ?pr_first:bool -> ?diffs:bool -> ?prev:(goal list * evar_map) -> Pp.t option -> evar_map + -> seeds:goal list -> shelf:goal list -> stack:int list + -> unfocused: goal list -> goals:goal list -> Pp.t val pr_subgoal : int -> evar_map -> goal list -> Pp.t val pr_concl : int -> evar_map -> goal -> Pp.t +val pr_open_subgoals_diff : ?quiet:bool -> ?diffs:bool -> ?prev_proof:Proof.t -> Proof.t -> Pp.t +val diff_pr_open_subgoals : ?quiet:bool -> Proof.t option -> Proof.t option -> Pp.t val pr_open_subgoals : proof:Proof.t -> Pp.t val pr_nth_open_subgoal : proof:Proof.t -> int -> Pp.t val pr_evar : evar_map -> (Evar.t * evar_info) -> Pp.t @@ -197,6 +201,8 @@ val pr_ne_evar_set : Pp.t -> Pp.t -> evar_map -> val pr_prim_rule : prim_rule -> Pp.t +val print_and_diff : Proof.t option -> Proof.t option -> unit + (** Backwards compatibility *) val prterm : constr -> Pp.t (** = pr_lconstr *) diff --git a/printing/printing.mllib b/printing/printing.mllib index b69d8a9ef8..deb52ad270 100644 --- a/printing/printing.mllib +++ b/printing/printing.mllib @@ -1,6 +1,7 @@ Genprint Pputils Ppconstr +Proof_diffs Printer Printmod Prettyp diff --git a/printing/printmod.ml b/printing/printmod.ml index 3f95dcfb6d..e2d9850bf8 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -103,9 +103,7 @@ let print_one_inductive env sigma mib ((_,i) as ind) = let envpar = push_rel_context params env in let inst = if Declareops.inductive_is_polymorphic mib then - let ctx = Declareops.inductive_polymorphic_context mib in - let ctx = Univ.UContext.make (u, Univ.AUContext.instantiate u ctx) in - Printer.pr_universe_instance sigma ctx + Printer.pr_universe_instance sigma u else mt () in hov 0 ( diff --git a/printing/proof_diffs.ml b/printing/proof_diffs.ml new file mode 100644 index 0000000000..7131ced15b --- /dev/null +++ b/printing/proof_diffs.ml @@ -0,0 +1,339 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* +Displays the differences between successive proof steps in coqtop and CoqIDE. +Proof General requires minor changes to make the diffs visible, but this code +shouldn't break the existing version of PG. See pp_diff.ml for details on how +the diff works. + +Diffs are computed for the hypotheses and conclusion of the first goal between +the old and new proofs. + +Diffs can be enabled with the Coq commmand "Set Diffs on|off|removed." or +'-diffs "on"|"off"|"removed"' on the OS command line. The "on" option shows only the +new item with added text, while "removed" shows each modified item twice--once +with the old value showing removed text and once with the new value showing +added text. + +In CoqIDE, colors and highlights can be set in the Edit/Preferences/Tags panel. +For coqtop, these can be set through the COQ_COLORS environment variable. + +Limitations/Possible enhancements: + +- If you go back to a prior proof step, diffs are not shown on the new current +step. Diffs will be shown again once you do another proof step. + +- Diffs are done between the first active goal in the old and new proofs. +If, for example, the proof step completed a goal, then the new goal is a +different goal, not a transformation of the old goal, so a diff is probably +not appropriate. (There's currently no way to tell when this happens or to +accurately match goals across old and new proofs. +See https://github.com/coq/coq/issues/7653) This is also why only the +first goal is diffed. + +- "Set Diffs "xx"." should reprint the current goal using the new option. + +- coqtop colors were chosen for white text on a black background. They're +not the greatest. I didn't want to change the existing green highlight. +Suggestions welcome. + +- coqtop underlines removed text because (per Wikipedia) the ANSI escape code +for strikeout is not commonly supported (it didn't work on mine). CoqIDE +uses strikeout on removed text. +*) + +open Pp_diff + +let diff_option = ref `OFF + +(* todo: Is there a way to persist the setting between sessions? + Eg if the user wants this as a permanent config setting? *) +let read_diffs_option () = match !diff_option with +| `OFF -> "off" +| `ON -> "on" +| `REMOVED -> "removed" + +let write_diffs_option = function +| "off" -> diff_option := `OFF +| "on" -> diff_option := `ON +| "removed" -> diff_option := `REMOVED +| _ -> CErrors.user_err Pp.(str "Diffs option only accepts the following values: \"off\", \"on\", \"removed\".") + +let _ = + Goptions.(declare_string_option { + optdepr = false; + optname = "show diffs in proofs"; + optkey = ["Diffs"]; + optread = read_diffs_option; + optwrite = write_diffs_option + }) + +let show_diffs () = !diff_option <> `OFF;; +let show_removed () = !diff_option = `REMOVED;; + + +(* DEBUG/UNIT TEST *) +let cfprintf oc = Printf.(kfprintf (fun oc -> fprintf oc "") oc) +let log_out_ch = ref stdout +[@@@ocaml.warning "-32"] +let cprintf s = cfprintf !log_out_ch s +[@@@ocaml.warning "+32"] + +module StringMap = Map.Make(String);; + +let tokenize_string s = + (* todo: cLexer changes buff as it proceeds. Seems like that should be saved, too. + But I don't understand how it's used--it looks like things get appended to it but + it never gets cleared. *) + let rec stream_tok acc str = + let e = Stream.next str in + if Tok.(equal e EOI) then + List.rev acc + else + stream_tok ((Tok.extract_string e) :: acc) str + in + let st = CLexer.get_lexer_state () in + try + let istr = Stream.of_string s in + let lex = CLexer.lexer.Plexing.tok_func istr in + let toks = stream_tok [] (fst lex) in + CLexer.set_lexer_state st; + toks + with exn -> + CLexer.set_lexer_state st; + raise (Diff_Failure "Input string is not lexable");; + + +type hyp_info = { + idents: string list; + rhs_pp: Pp.t; + mutable done_: bool; +} + +(* Generate the diffs between the old and new hyps. + This works by matching lines with the hypothesis name and diffing the right-hand side. + Lines that have multiple names such as "n, m : nat" are handled specially to account + for, say, the addition of m to a pre-existing "n : nat". + *) +let diff_hyps o_line_idents o_map n_line_idents n_map = + let rv : Pp.t list ref = ref [] in + + let is_done ident map = (StringMap.find ident map).done_ in + let exists ident map = + try let _ = StringMap.find ident map in true + with Not_found -> false in + let contains l ident = try [List.find (fun x -> x = ident) l] with Not_found -> [] in + + let output old_ids_uo new_ids = + (* use the order from the old line in case it's changed in the new *) + let old_ids = if old_ids_uo = [] then [] else + let orig = (StringMap.find (List.hd old_ids_uo) o_map).idents in + List.concat (List.map (contains orig) old_ids_uo) in + + let setup ids map = if ids = [] then ("", Pp.mt ()) else + let open Pp in + let rhs_pp = (StringMap.find (List.hd ids) map).rhs_pp in + let pp_ids = List.map (fun x -> str x) ids in + let hyp_pp = List.fold_left (fun l1 l2 -> l1 ++ str ", " ++ l2) (List.hd pp_ids) (List.tl pp_ids) ++ rhs_pp in + (string_of_ppcmds hyp_pp, hyp_pp) + in + + let (o_line, o_pp) = setup old_ids o_map in + let (n_line, n_pp) = setup new_ids n_map in + + let hyp_diffs = diff_str ~tokenize_string o_line n_line in + let (has_added, has_removed) = has_changes hyp_diffs in + if show_removed () && has_removed then begin + let o_entry = StringMap.find (List.hd old_ids) o_map in + o_entry.done_ <- true; + rv := (add_diff_tags `Removed o_pp hyp_diffs) :: !rv; + end; + if n_line <> "" then begin + let n_entry = StringMap.find (List.hd new_ids) n_map in + n_entry.done_ <- true; + rv := (add_diff_tags `Added n_pp hyp_diffs) :: !rv + end + in + + (* process identifier level diff *) + let process_ident_diff diff = + let (dtype, ident) = get_dinfo diff in + match dtype with + | `Removed -> + if dtype = `Removed then begin + let o_idents = (StringMap.find ident o_map).idents in + (* only show lines that have all idents removed here; other removed idents appear later *) + if show_removed () && + List.for_all (fun x -> not (exists x n_map)) o_idents then + output (List.rev o_idents) [] + end + | _ -> begin (* Added or Common case *) + let n_idents = (StringMap.find ident n_map).idents in + + (* Process a new hyp line, possibly splitting it. Duplicates some of + process_ident iteration, but easier to understand this way *) + let process_line ident2 = + if not (is_done ident2 n_map) then begin + let n_ids_list : string list ref = ref [] in + let o_ids_list : string list ref = ref [] in + let fst_omap_idents = ref None in + let add ids id map = + ids := id :: !ids; + (StringMap.find id map).done_ <- true in + + (* get identifiers shared by one old and one new line, plus + other Added in new and other Removed in old *) + let process_split ident3 = + if not (is_done ident3 n_map) then begin + let this_omap_idents = try Some (StringMap.find ident3 o_map).idents + with Not_found -> None in + if !fst_omap_idents = None then + fst_omap_idents := this_omap_idents; + match (!fst_omap_idents, this_omap_idents) with + | (Some fst, Some this) when fst == this -> (* yes, == *) + add n_ids_list ident3 n_map; + (* include, in old order, all undone Removed idents in old *) + List.iter (fun x -> if x = ident3 || not (is_done x o_map) && not (exists x n_map) then + (add o_ids_list x o_map)) fst + | (_, None) -> + add n_ids_list ident3 n_map (* include all undone Added idents in new *) + | _ -> () + end in + List.iter process_split n_idents; + output (List.rev !o_ids_list) (List.rev !n_ids_list) + end in + List.iter process_line n_idents (* O(n^2), so sue me *) + end in + + let cvt s = Array.of_list (List.concat s) in + let ident_diffs = diff_strs (cvt o_line_idents) (cvt n_line_idents) in + List.iter process_ident_diff ident_diffs; + List.rev !rv;; + + +type 'a hyp = (Names.Id.t list * 'a option * 'a) +type 'a reified_goal = { name: string; ty: 'a; hyps: 'a hyp list; env : Environ.env; sigma: Evd.evar_map } + +(* XXX: Port to proofview, one day. *) +(* open Proofview *) +module CDC = Context.Compacted.Declaration + +let to_tuple : Constr.compacted_declaration -> (Names.Id.t list * 'pc option * 'pc) = + let open CDC in function + | LocalAssum(idl, tm) -> (idl, None, tm) + | LocalDef(idl,tdef,tm) -> (idl, Some tdef, tm);; + +(* XXX: Very unfortunately we cannot use the Proofview interface as + Proof is still using the "legacy" one. *) +let process_goal sigma g : Constr.t reified_goal = + let env = Goal.V82.env sigma g in + let hyps = Goal.V82.hyps sigma g in + let ty = Goal.V82.concl sigma g in + let name = Goal.uid g in + (* There is a Constr/Econstr mess here... *) + let ty = EConstr.to_constr sigma ty in + (* compaction is usually desired [eg for better display] *) + let hyps = Termops.compact_named_context (Environ.named_context_of_val hyps) in + let hyps = List.map to_tuple hyps in + { name; ty; hyps; env; sigma };; + +let pr_letype_core goal_concl_style env sigma t = + Ppconstr.pr_lconstr_expr (Constrextern.extern_type goal_concl_style env sigma t) + +let pp_of_type env sigma ty = + pr_letype_core true env sigma EConstr.(of_constr ty) + +(* fetch info from a goal, returning (idents, map, concl_pp) where +idents is a list with one entry for each hypothesis, each entry is the list of +idents on the lhs of the hypothesis. map is a map from ident to hyp_info +reoords. For example: for the hypotheses: + b : bool + n, m : nat + +list will be [ ["b"]; ["n"; "m"] ] + +map will contain: + "b" -> { ["b"], Pp.t for ": bool"; false } + "n" -> { ["n"; "m"], Pp.t for ": nat"; false } + "m" -> { ["n"; "m"], Pp.t for ": nat"; false } + where the last two entries share the idents list. + +concl_pp is the conclusion as a Pp.t +*) +let goal_info goal sigma = + let map = ref StringMap.empty in + let line_idents = ref [] in + let build_hyp_info env sigma hyp = + let (names, body, ty) = hyp in + let open Pp in + let idents = List.map (fun x -> Names.Id.to_string x) names in + + line_idents := idents :: !line_idents; + let mid = match body with + | Some x -> str " := " ++ pp_of_type env sigma ty ++ str " : " + | None -> str " : " in + let ts = pp_of_type env sigma ty in + let rhs_pp = mid ++ ts in + + let make_entry () = { idents; rhs_pp; done_ = false } in + List.iter (fun ident -> map := (StringMap.add ident (make_entry ()) !map); ()) idents + in + + try + let { ty=ty; hyps=hyps; env=env } = process_goal sigma goal in + List.iter (build_hyp_info env sigma) (List.rev hyps); + let concl_pp = pp_of_type env sigma ty in + ( List.rev !line_idents, !map, concl_pp ) + with _ -> ([], !map, Pp.mt ());; + +let diff_goal_info o_info n_info = + let (o_line_idents, o_hyp_map, o_concl_pp) = o_info in + let (n_line_idents, n_hyp_map, n_concl_pp) = n_info in + let show_removed = Some (show_removed ()) in + let concl_pp = diff_pp_combined ~tokenize_string ?show_removed o_concl_pp n_concl_pp in + + let hyp_diffs_list = diff_hyps o_line_idents o_hyp_map n_line_idents n_hyp_map in + (hyp_diffs_list, concl_pp) + +let hyp_list_to_pp hyps = + let open Pp in + match hyps with + | h :: tl -> List.fold_left (fun x y -> x ++ cut () ++ y) h tl + | [] -> mt ();; + +(* Special purpuse, use only for the IDE interface, *) +let diff_first_goal o_proof n_proof = + let first_goal_info proof = + match proof with + | None -> ([], StringMap.empty, Pp.mt ()) + | Some proof2 -> + let (goals,_,_,_,sigma) = Proof.proof proof2 in + match goals with + | hd :: tl -> goal_info hd sigma; + | _ -> ([], StringMap.empty, Pp.mt ()) + in + diff_goal_info (first_goal_info o_proof) (first_goal_info n_proof);; + +let diff_goals ?prev_gs n_gs = + let unwrap gs = + match gs with + | Some gs -> + let goal = Evd.sig_it gs in + let sigma = Refiner.project gs in + goal_info goal sigma + | None -> ([], StringMap.empty, Pp.mt ()) + in + let (hyps_pp_list, concl_pp) = diff_goal_info (unwrap prev_gs) (unwrap n_gs) in + let open Pp in + v 0 ( + (hyp_list_to_pp hyps_pp_list) ++ cut () ++ + str "============================" ++ cut () ++ + concl_pp);; diff --git a/printing/proof_diffs.mli b/printing/proof_diffs.mli new file mode 100644 index 0000000000..0d3b5821e5 --- /dev/null +++ b/printing/proof_diffs.mli @@ -0,0 +1,67 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* diff options *) + +(** Controls whether to show diffs. Takes values "on", "off", "removed" *) +val write_diffs_option : string -> unit +(** Returns true if the diffs option is "on" or "removed" *) +val show_diffs : unit -> bool + +(** Computes the diff between the first goal of two Proofs and returns +the highlighted hypotheses and conclusion. + +If the strings used to display the goal are not lexable (this is believed +unlikely), this routine will generate a Diff_Failure. This routine may also +raise Diff_Failure under some "impossible" conditions. + +If you want to make your call especially bulletproof, catch these +exceptions, print a user-visible message, then recall this routine with +the first argument set to None, which will skip the diff. +*) +val diff_first_goal : Proof.t option -> Proof.t option -> Pp.t list * Pp.t + +open Evd +open Proof_type + +(** Computes the diff between two goals + +If the strings used to display the goal are not lexable (this is believed +unlikely), this routine will generate a Diff_Failure. This routine may also +raise Diff_Failure under some "impossible" conditions. + +If you want to make your call especially bulletproof, catch these +exceptions, print a user-visible message, then recall this routine with +the first argument set to None, which will skip the diff. +*) +val diff_goals : ?prev_gs:(goal sigma) -> goal sigma option -> Pp.t + +(** Convert a string to a list of token strings using the lexer *) +val tokenize_string : string -> string list + +(* Exposed for unit test, don't use these otherwise *) +(* output channel for the test log file *) +val log_out_ch : out_channel ref + + +type hyp_info = { + idents: string list; + rhs_pp: Pp.t; + mutable done_: bool; +} + +module StringMap : +sig + type +'a t + val empty: hyp_info t + val add : string -> hyp_info -> hyp_info t -> hyp_info t +end + +val diff_hyps : string list list -> hyp_info StringMap.t -> string list list -> hyp_info StringMap.t -> Pp.t list diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 6be80d29a5..eca0c6674b 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -42,13 +42,6 @@ let string_of_vernac_when = function let string_of_vernac_classification (t,w) = string_of_vernac_type t ^ " " ^ string_of_vernac_when w -let classifiers = ref [] -let declare_vernac_classifier - (s : Vernacexpr.extend_name) - (f : Genarg.raw_generic_argument list -> unit -> vernac_classification) -= - classifiers := !classifiers @ [s,f] - let idents_of_name : Names.Name.t -> Names.Id.t list = function | Names.Anonymous -> [] @@ -194,7 +187,7 @@ let classify_vernac e = | VernacWriteState _ -> VtSideff [], VtNow (* Plugins should classify their commands *) | VernacExtend (s,l) -> - try List.assoc s !classifiers l () + try Vernacentries.get_vernac_classifier s l with Not_found -> anomaly(str"No classifier for"++spc()++str (fst s)++str".") in let rec static_control_classifier ~poly = function diff --git a/stm/vernac_classifier.mli b/stm/vernac_classifier.mli index 45fbfb42af..e82b191418 100644 --- a/stm/vernac_classifier.mli +++ b/stm/vernac_classifier.mli @@ -9,17 +9,12 @@ (************************************************************************) open Vernacexpr -open Genarg val string_of_vernac_classification : vernac_classification -> string (** What does a vernacular do *) val classify_vernac : vernac_control -> vernac_classification -(** Install a vernacular classifier for VernacExtend *) -val declare_vernac_classifier : - Vernacexpr.extend_name -> (raw_generic_argument list -> unit -> vernac_classification) -> unit - (** Standard constant classifiers *) val classify_as_query : vernac_classification val classify_as_sideeff : vernac_classification diff --git a/tactics/hints.ml b/tactics/hints.ml index 748e0362c4..43a450ea71 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -299,16 +299,16 @@ let strip_params env sigma c = match EConstr.kind sigma c with | App (f, args) -> (match EConstr.kind sigma f with - | Const (p,_) -> - let p = Projection.make p false in - (match lookup_projection p env with - | pb -> - let n = pb.Declarations.proj_npars in - if Array.length args > n then - mkApp (mkProj (p, args.(n)), - Array.sub args (n+1) (Array.length args - (n + 1))) + | Const (cst,_) -> + (match Recordops.find_primitive_projection cst with + | Some p -> + let p = Projection.make p false in + let npars = Projection.npars p in + if Array.length args > npars then + mkApp (mkProj (p, args.(npars)), + Array.sub args (npars+1) (Array.length args - (npars + 1))) else c - | exception Not_found -> c) + | None -> c) | _ -> c) | _ -> c @@ -886,20 +886,6 @@ let pr_hint_term env sigma ctx = function let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in pr_econstr_env env sigma c -(** We need an object to record the side-effect of registering - global universes associated with a hint. *) -let cache_context_set (_,c) = - Global.push_context_set false c - -let input_context_set : Univ.ContextSet.t -> Libobject.obj = - let open Libobject in - declare_object - { (default_object "Global universe context") with - cache_function = cache_context_set; - load_function = (fun _ -> cache_context_set); - discharge_function = (fun (_,a) -> Some a); - classify_function = (fun a -> Keep a) } - let warn_polymorphic_hint = CWarnings.create ~name:"polymorphic-hint" ~category:"automation" (fun hint -> strbrk"Using polymorphic hint " ++ hint ++ @@ -919,7 +905,7 @@ let fresh_global_or_constr env sigma poly cr = else begin if isgr then warn_polymorphic_hint (pr_hint_term env sigma ctx cr); - Lib.add_anonymous_leaf (input_context_set ctx); + Declare.declare_universe_context false ctx; (c, Univ.ContextSet.empty) end @@ -1315,7 +1301,7 @@ let prepare_hint check (poly,local) env init (sigma,c) = let diff = Univ.ContextSet.diff (Evd.universe_context_set sigma) (Evd.universe_context_set init) in if poly then IsConstr (c', diff) else if local then IsConstr (c', diff) - else (Lib.add_anonymous_leaf (input_context_set diff); + else (Declare.declare_universe_context false diff; IsConstr (c', Univ.ContextSet.empty)) let project_hint ~poly pri l2r r = diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index f9c4bed352..7da059ae35 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -263,7 +263,9 @@ open Evar_kinds let mkPattern c = snd (Patternops.pattern_of_glob_constr c) let mkGApp f args = DAst.make @@ GApp (f, args) let mkGHole = DAst.make @@ - GHole (QuestionMark (Define false,Anonymous), Namegen.IntroAnonymous, None) + GHole (QuestionMark { + Evar_kinds.default_question_mark with Evar_kinds.qm_obligation=Define false; + }, Namegen.IntroAnonymous, None) let mkGProd id c1 c2 = DAst.make @@ GProd (Name (Id.of_string id), Explicit, c1, c2) let mkGArrow c1 c2 = DAst.make @@ diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 3a09a0e00e..2a8ebe08ca 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1581,9 +1581,10 @@ let make_projection env sigma params cstr sign elim i n c u = | Some proj -> let args = Context.Rel.to_extended_vect mkRel 0 sign in let proj = - if Environ.is_projection proj env then + match Recordops.find_primitive_projection proj with + | Some proj -> mkProj (Projection.make proj false, mkApp (c, args)) - else + | None -> mkApp (mkConstU (proj,u), Array.append (Array.of_list params) [|mkApp (c, args)|]) in diff --git a/test-suite/Makefile b/test-suite/Makefile index 33b4023272..b8aac8b6f8 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -192,10 +192,6 @@ PRINT_LOGS?= TRAVIS?= # special because we want to print travis_fold directives ifdef APPVEYOR PRINT_LOGS:=APPVEYOR -else -ifdef CIRCLECI -PRINT_LOGS:=CIRCLECI -endif #CIRCLECI endif #APPVEYOR report: summary.log diff --git a/test-suite/bugs/closed/2733.v b/test-suite/bugs/closed/2733.v index 832de4f913..24dd30b32e 100644 --- a/test-suite/bugs/closed/2733.v +++ b/test-suite/bugs/closed/2733.v @@ -16,6 +16,21 @@ match k,l with |B,l' => Bcons true (Ncons 0 l') end. +(* At some time, the success of trullynul was dependent on the name of + the variables! *) + +Definition trullynul2 k {a} (l : alt_list k a) := +match k,l with + |N,l' => Ncons 0 (Bcons true l') + |B,l' => Bcons true (Ncons 0 l') +end. + +Definition trullynul3 k {z} (l : alt_list k z) := +match k,l with + |N,l' => Ncons 0 (Bcons true l') + |B,l' => Bcons true (Ncons 0 l') +end. + Fixpoint app (P : forall {k k'}, alt_list k k' -> alt_list k k') {t1 t2} (l : alt_list t1 t2) {struct l}: forall {t3}, alt_list t2 t3 -> alt_list t1 t3 := match l with diff --git a/test-suite/bugs/closed/7854.v b/test-suite/bugs/closed/7854.v new file mode 100644 index 0000000000..ab1a29b632 --- /dev/null +++ b/test-suite/bugs/closed/7854.v @@ -0,0 +1,10 @@ +Set Primitive Projections. + +CoInductive stream (A : Type) := cons { + hd : A; + tl : stream A; +}. + +CoFixpoint const {A} (x : A) := cons A x (const x). + +Check (@eq_refl _ (const tt) <<: tl unit (const tt) = const tt). diff --git a/test-suite/bugs/closed/8081.v b/test-suite/bugs/closed/8081.v new file mode 100644 index 0000000000..0f2501aaa8 --- /dev/null +++ b/test-suite/bugs/closed/8081.v @@ -0,0 +1,4 @@ +Section foo. +End foo. +Section foo. +End foo. diff --git a/test-suite/bugs/closed/8119.v b/test-suite/bugs/closed/8119.v new file mode 100644 index 0000000000..c6329a7328 --- /dev/null +++ b/test-suite/bugs/closed/8119.v @@ -0,0 +1,46 @@ +Require Import Coq.Strings.String. + +Section T. + Eval vm_compute in let x := tt in _. +(* Error: Anomaly "Uncaught exception Constr.DestKO." Please report at http://coq.inria.fr/bugs/. *) + Eval vm_compute in let _ := Set in _. +(* Error: Anomaly "Uncaught exception Constr.DestKO." Please report at http://coq.inria.fr/bugs/. *) + Eval vm_compute in let _ := Prop in _. +(* Error: Anomaly "Uncaught exception Constr.DestKO." Please report at http://coq.inria.fr/bugs/. *) +End T. + +Section U0. + Let n : unit := tt. + Eval vm_compute in _. +(* Error: Anomaly "Uncaught exception Constr.DestKO." Please report at http://coq.inria.fr/bugs/. *) + Goal exists tt : unit, tt = tt. eexists. vm_compute. Abort. +(* Error: Anomaly "Uncaught exception Constr.DestKO." Please report at http://coq.inria.fr/bugs/. *) +End U0. + +Section S0. + Let LF : string := String (Coq.Strings.Ascii.Ascii false true false true false false false false) "". + Eval vm_compute in _. +(* Error: Anomaly "Uncaught exception Constr.DestKO." Please report at http://coq.inria.fr/bugs/. *) + Goal exists tt : unit, tt = tt. eexists. vm_compute. Abort. +(* Error: Anomaly "Uncaught exception Constr.DestKO." Please report at http://coq.inria.fr/bugs/. *) +End S0. + +Class T := { }. +Section S1. + Context {p : T}. + Let LF : string := String (Coq.Strings.Ascii.Ascii false true false true false false false false) "". + Eval vm_compute in _. +(* Error: Anomaly "Uncaught exception Not_found." Please report at http://coq.inria.fr/bugs/. *) + Goal exists tt : unit, tt = tt. eexists. vm_compute. Abort. +(* Error: Anomaly "Uncaught exception Not_found." Please report at http://coq.inria.fr/bugs/. *) +End S1. + +Class M := { m : Type }. +Section S2. + Context {p : M}. + Let LF : string := String (Coq.Strings.Ascii.Ascii false true false true false false false false) "". + Eval vm_compute in _. +(* Error: Anomaly "File "pretyping/vnorm.ml", line 60, characters 9-15: Assertion failed." *) + Goal exists tt : unit, tt = tt. eexists. vm_compute. Abort. +(* Error: Anomaly "File "pretyping/vnorm.ml", line 60, characters 9-15: Assertion failed." *) +End S2. diff --git a/test-suite/bugs/closed/8126.v b/test-suite/bugs/closed/8126.v new file mode 100644 index 0000000000..f52dfc6b47 --- /dev/null +++ b/test-suite/bugs/closed/8126.v @@ -0,0 +1,13 @@ +(* See also output test Notations4.v *) + +Inductive foo := tt. +Bind Scope foo_scope with foo. +Delimit Scope foo_scope with foo. +Notation "'HI'" := tt : foo_scope. +Definition myfoo (x : nat) (y : nat) (z : foo) := y. +Notation myfoo0 := (@myfoo 0). +Notation myfoo01 := (@myfoo0 1). +Check myfoo 0 1 HI. (* prints [myfoo0 1 HI], but should print [myfoo01 HI] *) +Check myfoo0 1 HI. (* prints [myfoo0 1 HI], but should print [myfoo01 HI] *) +Check myfoo01 tt. (* prints [myfoo0 1 HI], but should print [myfoo01 HI] *) +Check myfoo01 HI. (* was failing *) diff --git a/test-suite/coqchk/include_primproj.v b/test-suite/coqchk/include_primproj.v new file mode 100644 index 0000000000..804ba1d378 --- /dev/null +++ b/test-suite/coqchk/include_primproj.v @@ -0,0 +1,13 @@ +(* #7329 *) +Set Primitive Projections. + +Module M. + Module Bar. + Record Box := box { unbox : Type }. + + Axiom foo : Box. + Axiom baz : forall _ : unbox foo, unbox foo. + End Bar. +End M. + +Include M. diff --git a/test-suite/output/BadOptionValueType.out b/test-suite/output/BadOptionValueType.out new file mode 100644 index 0000000000..34d8518a75 --- /dev/null +++ b/test-suite/output/BadOptionValueType.out @@ -0,0 +1,8 @@ +The command has indeed failed with message: +Bad type of value for this option: expected int, got string. +The command has indeed failed with message: +Bad type of value for this option: expected bool, got string. +The command has indeed failed with message: +Bad type of value for this option: expected bool, got int. +The command has indeed failed with message: +Bad type of value for this option: expected bool, got int. diff --git a/test-suite/output/BadOptionValueType.v b/test-suite/output/BadOptionValueType.v new file mode 100644 index 0000000000..b61c3757ba --- /dev/null +++ b/test-suite/output/BadOptionValueType.v @@ -0,0 +1,4 @@ +Fail Set Default Timeout "2". +Fail Set Debug Eauto "yes". +Fail Set Debug Eauto 1. +Fail Set Implicit Arguments 1. diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out index 419dcadb4c..dfab400baa 100644 --- a/test-suite/output/Cases.out +++ b/test-suite/output/Cases.out @@ -169,3 +169,5 @@ fun x : K => match x with | _ => 2 end : K -> nat +The command has indeed failed with message: +Pattern "S _, _" is redundant in this clause. diff --git a/test-suite/output/Cases.v b/test-suite/output/Cases.v index 4740c009a4..e4fa7044e7 100644 --- a/test-suite/output/Cases.v +++ b/test-suite/output/Cases.v @@ -217,3 +217,6 @@ Check fun x => match x with a3 | a4 => 3 | _ => 2 end. Check fun x => match x with a3 => 3 | a2 | a1 => 4 | _ => 2 end. Check fun x => match x with a4 => 3 | a2 | a1 => 4 | _ => 2 end. Check fun x => match x with a3 | a4 | a1 => 3 | _ => 2 end. + +(* Test redundant clause within a disjunctive pattern *) +Fail Check fun n m => match n, m with 0, 0 | _, S _ | S 0, _ | S (S _ | _), _ => false end. diff --git a/test-suite/output/Notations3.out b/test-suite/output/Notations3.out index 5ab616160a..d32cf67e28 100644 --- a/test-suite/output/Notations3.out +++ b/test-suite/output/Notations3.out @@ -246,3 +246,9 @@ Notation ============================ ##@% ^^^ +myfoo01 tt + : nat +myfoo01 tt + : nat +myfoo01 tt + : nat diff --git a/test-suite/output/Notations3.v b/test-suite/output/Notations3.v index 876aaa3944..180e8d337e 100644 --- a/test-suite/output/Notations3.v +++ b/test-suite/output/Notations3.v @@ -399,3 +399,14 @@ Show. Abort. End Issue7731. + +Module Issue8126. + +Definition myfoo (x : nat) (y : nat) (z : unit) := y. +Notation myfoo0 := (@myfoo 0). +Notation myfoo01 := (@myfoo0 1). +Check myfoo 0 1 tt. (* was printing [myfoo0 1 HI], but should print [myfoo01 HI] *) +Check myfoo0 1 tt. (* was printing [myfoo0 1 HI], but should print [myfoo01 HI] *) +Check myfoo01 tt. (* was printing [myfoo0 1 HI], but should print [myfoo01 HI] *) + +End Issue8126. diff --git a/test-suite/output/RecordMissingField.out b/test-suite/output/RecordMissingField.out new file mode 100644 index 0000000000..7c80a6065f --- /dev/null +++ b/test-suite/output/RecordMissingField.out @@ -0,0 +1,4 @@ +File "stdin", line 8, characters 5-22: +Error: Cannot infer field y2p of record point2d in environment: +p : point2d + diff --git a/test-suite/output/RecordMissingField.v b/test-suite/output/RecordMissingField.v new file mode 100644 index 0000000000..84f1748fa0 --- /dev/null +++ b/test-suite/output/RecordMissingField.v @@ -0,0 +1,8 @@ +(** Check for error message when missing a record field. Error message +should contain missing field, and the inferred type of the record **) + +Record point2d := mkPoint { x2p: nat; y2p: nat }. + + +Definition increment_x (p: point2d) : point2d := + {| x2p := x2p p + 1; |}. diff --git a/test-suite/success/Fourier.v b/test-suite/success/LraTest.v index b63bead477..bf3a87da25 100644 --- a/test-suite/success/Fourier.v +++ b/test-suite/success/LraTest.v @@ -1,12 +1,14 @@ -Require Import Rfunctions. -Require Import Fourier. +Require Import Reals. +Require Import Lra. + +Open Scope R_scope. Lemma l1 : forall x y z : R, Rabs (x - z) <= Rabs (x - y) + Rabs (y - z). -intros; split_Rabs; fourier. +intros; split_Rabs; lra. Qed. Lemma l2 : forall x y : R, x < Rabs y -> y < 1 -> x >= 0 -> - y <= 1 -> Rabs x <= 1. intros. -split_Rabs; fourier. +split_Rabs; lra. Qed. diff --git a/test-suite/success/primitiveproj.v b/test-suite/success/primitiveproj.v index 7ca2767a53..299b08bdd1 100644 --- a/test-suite/success/primitiveproj.v +++ b/test-suite/success/primitiveproj.v @@ -193,12 +193,13 @@ Set Primitive Projections. Record s (x:nat) (y:=S x) := {c:=x; d:x=c}. Lemma f : 0=1. Proof. -Fail apply d. + Fail apply d. (* split. reflexivity. Qed. *) +Abort. (* Primitive projection match compilation *) Require Import List. @@ -220,3 +221,9 @@ Fixpoint split_at {A} (l : list A) (n : nat) : prod (list A) (list A) := Time Eval vm_compute in split_at (repeat 0 20) 10. (* Takes 0s *) Time Eval vm_compute in split_at (repeat 0 40) 20. (* Takes 0.001s *) Timeout 1 Time Eval vm_compute in split_at (repeat 0 60) 30. (* Used to take 60s, now takes 0.001s *) + +Check (@eq_refl _ 0 <: 0 = fst (pair 0 1)). +Fail Check (@eq_refl _ 0 <: 0 = snd (pair 0 1)). + +Check (@eq_refl _ 0 <<: 0 = fst (pair 0 1)). +Fail Check (@eq_refl _ 0 <<: 0 = snd (pair 0 1)). diff --git a/test-suite/unit-tests/.merlin b/test-suite/unit-tests/.merlin.in index b2279de74e..b2279de74e 100644 --- a/test-suite/unit-tests/.merlin +++ b/test-suite/unit-tests/.merlin.in diff --git a/test-suite/unit-tests/clib/inteq.ml b/test-suite/unit-tests/clib/inteq.ml index c07ec293f0..89717c79d5 100644 --- a/test-suite/unit-tests/clib/inteq.ml +++ b/test-suite/unit-tests/clib/inteq.ml @@ -1,5 +1,7 @@ open Utest +let log_out_ch = open_log_out_ch __FILE__ + let eq0 = mk_bool_test "clib-inteq0" "Int.equal on 0" (Int.equal 0 0) @@ -10,4 +12,4 @@ let eq42 = mk_bool_test "clib-inteq42" let tests = [ eq0; eq42 ] -let _ = run_tests __FILE__ tests +let _ = run_tests __FILE__ log_out_ch tests diff --git a/test-suite/unit-tests/clib/unicode_tests.ml b/test-suite/unit-tests/clib/unicode_tests.ml index 9ae405977b..95316ad3aa 100644 --- a/test-suite/unit-tests/clib/unicode_tests.ml +++ b/test-suite/unit-tests/clib/unicode_tests.ml @@ -1,5 +1,7 @@ open Utest +let log_out_ch = open_log_out_ch __FILE__ + let unicode0 = mk_eq_test "clib-unicode0" "split_at_first_letter, first letter is character" None @@ -12,4 +14,4 @@ let unicode1 = mk_eq_test "clib-unicode1" let tests = [ unicode0; unicode1 ] -let _ = run_tests __FILE__ tests +let _ = run_tests __FILE__ log_out_ch tests diff --git a/test-suite/unit-tests/printing/proof_diffs_test.ml b/test-suite/unit-tests/printing/proof_diffs_test.ml new file mode 100644 index 0000000000..526cefec44 --- /dev/null +++ b/test-suite/unit-tests/printing/proof_diffs_test.ml @@ -0,0 +1,333 @@ +open OUnit +open Utest +open Pp_diff +open Proof_diffs + +let tokenize_string = Proof_diffs.tokenize_string +let diff_pp = diff_pp ~tokenize_string +let diff_str = diff_str ~tokenize_string + +let tests = ref [] +let add_test name test = tests := (mk_test name (TestCase test)) :: !tests + +let log_out_ch = open_log_out_ch __FILE__ +let cfprintf oc = Printf.(kfprintf (fun oc -> fprintf oc "") oc) +let cprintf s = cfprintf log_out_ch s +let _ = Proof_diffs.log_out_ch := log_out_ch + +let string_of_string s : string = "\"" ^ s ^ "\"" + +(* todo: OCaml: why can't the body of the test function be given in the add_test line? *) + +let t () = + let expected : diff_list = [] in + let diffs = diff_str "" " " in + + assert_equal ~msg:"empty" ~printer:string_of_diffs expected diffs; + let (has_added, has_removed) = has_changes diffs in + assert_equal ~msg:"has `Added" ~printer:string_of_bool false has_added; + assert_equal ~msg:"has `Removed" ~printer:string_of_bool false has_removed +let _ = add_test "diff_str empty" t + + +let t () = + let expected : diff_list = + [ `Common (0, 0, "a"); `Common (1, 1, "b"); `Common (2, 2, "c")] in + let diffs = diff_str "a b c" " a b\t c\n" in + + assert_equal ~msg:"white space" ~printer:string_of_diffs expected diffs; + let (has_added, has_removed) = has_changes diffs in + assert_equal ~msg:"no `Added" ~printer:string_of_bool false has_added; + assert_equal ~msg:"no `Removed" ~printer:string_of_bool false has_removed +let _ = add_test "diff_str white space" t + +let t () = + let expected : diff_list = [ `Removed (0, "a"); `Added (0, "b")] in + let diffs = diff_str "a" "b" in + + assert_equal ~msg:"add/remove" ~printer:string_of_diffs expected diffs; + let (has_added, has_removed) = has_changes diffs in + assert_equal ~msg:"has `Added" ~printer:string_of_bool true has_added; + assert_equal ~msg:"has `Removed" ~printer:string_of_bool true has_removed +let _ = add_test "diff_str add/remove" t + +(* example of a limitation, not really a test *) +let t () = + try + let _ = diff_str "a" ">" in + assert_failure "unlexable string gives an exception" + with _ -> () +let _ = add_test "diff_str unlexable" t + +(* problematic examples for tokenize_string: + comments omitted + quoted string loses quote marks (are escapes supported/handled?) + char constant split into 2 + *) +let t () = + List.iter (fun x -> cprintf "'%s' " x) (tokenize_string "(* comment *) \"string\" 'c' xx"); + cprintf "\n" +let _ = add_test "tokenize_string examples" t + +open Pp + +(* note pp_to_string concatenates adjacent strings, could become one token, +e.g. str " a" ++ str "b " will give a token "ab" *) +(* checks background is present and correct *) +let t () = + let o_pp = str "a" ++ str "!" ++ str "c" in + let n_pp = str "a" ++ str "?" ++ str "c" in + let (o_exp, n_exp) = (wrap_in_bg "diff.removed" (str "a" ++ (tag "diff.removed" (str "!")) ++ str "c"), + wrap_in_bg "diff.added" (str "a" ++ (tag "diff.added" (str "?")) ++ str "c")) in + let (o_diff, n_diff) = diff_pp o_pp n_pp in + + assert_equal ~msg:"removed" ~printer:db_string_of_pp o_exp o_diff; + assert_equal ~msg:"added" ~printer:db_string_of_pp n_exp n_diff +let _ = add_test "diff_pp/add_diff_tags add/remove" t + +let t () = + (*Printf.printf "%s\n" (string_of_diffs (diff_str "a d" "a b c d"));*) + let o_pp = str "a" ++ str " d" in + let n_pp = str "a" ++ str " b " ++ str " c " ++ str "d" ++ str " e " in + let n_exp = flatten (wrap_in_bg "diff.added" (seq [ + str "a"; + str " "; (tag "start.diff.added" (str "b ")); + (tag "end.diff.added" (str " c")); str " "; + (str "d"); + str " "; (tag "diff.added" (str "e")); str " " + ])) in + let (_, n_diff) = diff_pp o_pp n_pp in + + assert_equal ~msg:"added" ~printer:db_string_of_pp n_exp (flatten n_diff);; +let _ = add_test "diff_pp/add_diff_tags a span with spaces" t + + +let t () = + let o_pp = str " " in + let n_pp = tag "sometag" (str "a") in + let n_exp = flatten (wrap_in_bg "diff.added" (tag "diff.added" (tag "sometag" (str "a")))) in + let (_, n_diff) = diff_pp o_pp n_pp in + + assert_equal ~msg:"added" ~printer:db_string_of_pp n_exp (flatten n_diff) +let _ = add_test "diff_pp/add_diff_tags diff tags outside existing tags" t + +let t () = + let o_pp = str " " in + let n_pp = seq [(tag "sometag" (str " a ")); str "b"] in + let n_exp = flatten (wrap_in_bg "diff.added" + (seq [tag "sometag" (str " "); (tag "start.diff.added" (tag "sometag" (str "a "))); + (tag "end.diff.added" (str "b"))]) ) in + let (_, n_diff) = diff_pp o_pp n_pp in + + assert_equal ~msg:"added" ~printer:db_string_of_pp n_exp (flatten n_diff) +let _ = add_test "diff_pp/add_diff_tags existing tagged values with spaces" t + +let t () = + let o_pp = str " " in + let n_pp = str " a b " in + let n_exp = flatten (wrap_in_bg "diff.added" + (seq [str " "; tag "diff.added" (str "a b"); str " "])) in + let (_, n_diff) = diff_pp o_pp n_pp in + + assert_equal ~msg:"added" ~printer:db_string_of_pp n_exp (flatten n_diff) +let _ = add_test "diff_pp/add_diff_tags multiple tokens in pp" t + +let t () = + let o_pp = str "a d" in + let n_pp = seq [str "a b"; str "c d"] in + let n_exp = flatten (wrap_in_bg "diff.added" + (seq [str "a "; tag "start.diff.added" (str "b"); + tag "end.diff.added" (str "c"); str " d"])) in + let (_, n_diff) = diff_pp o_pp n_pp in + + assert_equal ~msg:"added" ~printer:db_string_of_pp n_exp (flatten n_diff) +let _ = add_test "diff_pp/add_diff_tags token spanning multiple Ppcmd_strs" t + +let t () = + let o_pp = seq [str ""; str "a"] in + let n_pp = seq [str ""; str "a b"] in + let n_exp = flatten (wrap_in_bg "diff.added" + (seq [str ""; str "a "; tag "diff.added" (str "b")])) in + let (_, n_diff) = diff_pp o_pp n_pp in + + assert_equal ~msg:"added" ~printer:db_string_of_pp n_exp (flatten n_diff) +let _ = add_test "diff_pp/add_diff_tags empty string preserved" t + +(* todo: awaiting a change in the lexer to return the quotes of the string token *) +let t () = + let s = "\"a b\"" in + let o_pp = seq [str s] in + let n_pp = seq [str "\"a b\" "] in + cprintf "ppcmds: %s\n" (string_of_ppcmds n_pp); + let n_exp = flatten (wrap_in_bg "diff.added" + (seq [str ""; str "a "; tag "diff.added" (str "b")])) in + let (_, n_diff) = diff_pp o_pp n_pp in + + assert_equal ~msg:"string" ~printer:string_of_string "a b" (List.hd (tokenize_string s)); + assert_equal ~msg:"added" ~printer:db_string_of_pp n_exp (flatten n_diff) +let _ = if false then add_test "diff_pp/add_diff_tags token containing white space" t + +let add_entries map idents rhs_pp = + let make_entry() = { idents; rhs_pp; done_ = false } in + List.iter (fun ident -> map := (StringMap.add ident (make_entry ()) !map); ()) idents;; + +let print_list hyps = List.iter (fun x -> cprintf "%s\n" (string_of_ppcmds (flatten x))) hyps +let db_print_list hyps = List.iter (fun x -> cprintf "%s\n" (db_string_of_pp (flatten x))) hyps + + +(* a : foo + b : bar car -> + b : car + a : foo bar *) +let t () = + write_diffs_option "removed"; (* turn on "removed" option *) + let o_line_idents = [ ["a"]; ["b"]] in + let o_hyp_map = ref StringMap.empty in + add_entries o_hyp_map ["a"] (str " : foo"); + add_entries o_hyp_map ["b"] (str " : bar car"); + let n_line_idents = [ ["b"]; ["a"]] in + let n_hyp_map = ref StringMap.empty in + add_entries n_hyp_map ["b"] (str " : car"); + add_entries n_hyp_map ["a"] (str " : foo bar"); + let expected = [flatten (wrap_in_bg "diff.removed" (seq [str "b"; str " : "; (tag "diff.removed" (str "bar")); str " car" ])); + flatten (wrap_in_bg "diff.added" (seq [str "b"; str " : car" ])); + flatten (wrap_in_bg "diff.added" (seq [str "a"; str " : foo "; (tag "diff.added" (str "bar")) ])) + ] in + + let hyps_diff_list = diff_hyps o_line_idents !o_hyp_map n_line_idents !n_hyp_map in + + (*print_list hyps_diff_list;*) + (*db_print_list hyps_diff_list;*) + + List.iter2 (fun exp act -> + assert_equal ~msg:"added" ~printer:db_string_of_pp exp (flatten act)) + expected hyps_diff_list +let _ = add_test "diff_hyps simple diffs" t + +(* a : nat + c, d : int -> + a, b : nat + d : int + and keeps old order *) +let t () = + write_diffs_option "removed"; (* turn on "removed" option *) + let o_line_idents = [ ["a"]; ["c"; "d"]] in + let o_hyp_map = ref StringMap.empty in + add_entries o_hyp_map ["a"] (str " : nat"); + add_entries o_hyp_map ["c"; "d"] (str " : int"); + let n_line_idents = [ ["a"; "b"]; ["d"]] in + let n_hyp_map = ref StringMap.empty in + add_entries n_hyp_map ["a"; "b"] (str " : nat"); + add_entries n_hyp_map ["d"] (str " : int"); + let expected = [flatten (wrap_in_bg "diff.added" (seq [str "a"; (tag "start.diff.added" (str ", ")); (tag "end.diff.added" (str "b")); str " : nat" ])); + flatten (wrap_in_bg "diff.removed" (seq [(tag "start.diff.removed" (str "c")); (tag "end.diff.removed" (str ",")); str " "; str "d"; str " : int" ])); + flatten (wrap_in_bg "diff.added" (seq [str "d"; str " : int" ])) + ] in + + let hyps_diff_list = diff_hyps o_line_idents !o_hyp_map n_line_idents !n_hyp_map in + + (*print_list hyps_diff_list;*) + (*print_list expected;*) + + (*db_print_list hyps_diff_list;*) + (*db_print_list expected;*) + + List.iter2 (fun exp act -> + assert_equal ~msg:"added" ~printer:db_string_of_pp exp (flatten act)) + expected hyps_diff_list +let _ = add_test "diff_hyps compacted" t + +(* a : foo + b : bar + c : nat -> + b, a, c : nat +DIFFS + b : bar (remove bar) + b : nat (add nat) + a : foo (remove foo) + a : nat (add nat) + c : nat + is this a realistic use case? +*) +let t () = + write_diffs_option "removed"; (* turn on "removed" option *) + let o_line_idents = [ ["a"]; ["b"]; ["c"]] in + let o_hyp_map = ref StringMap.empty in + add_entries o_hyp_map ["a"] (str " : foo"); + add_entries o_hyp_map ["b"] (str " : bar"); + add_entries o_hyp_map ["c"] (str " : nat"); + let n_line_idents = [ ["b"; "a"; "c"] ] in + let n_hyp_map = ref StringMap.empty in + add_entries n_hyp_map ["b"; "a"; "c"] (str " : nat"); + let expected = [flatten (wrap_in_bg "diff.removed" (seq [str "b"; str " : "; (tag "diff.removed" (str "bar"))])); + flatten (wrap_in_bg "diff.added" (seq [str "b"; str " : "; (tag "diff.added" (str "nat"))])); + flatten (wrap_in_bg "diff.removed" (seq [str "a"; str " : "; (tag "diff.removed" (str "foo"))])); + flatten (wrap_in_bg "diff.added" (seq [str "a"; str " : "; (tag "diff.added" (str "nat"))])); + flatten (seq [str "c"; str " : nat"]) + ] in + + let hyps_diff_list = diff_hyps o_line_idents !o_hyp_map n_line_idents !n_hyp_map in + + (*print_list hyps_diff_list;*) + (*db_print_list hyps_diff_list;*) + + List.iter2 (fun exp act -> + assert_equal ~msg:"added" ~printer:db_string_of_pp exp (flatten act)) + expected hyps_diff_list +let _ = add_test "diff_hyps compacted with join" t + +(* b, a, c : nat -> + a : foo + b : bar + c : nat +DIFFS + a : nat (remove nat) + a : foo (add foo) + b : nat (remove nat) + b : bar (add bar) + c : nat + is this a realistic use case? *) +let t () = + write_diffs_option "removed"; (* turn on "removed" option *) + let o_line_idents = [ ["b"; "a"; "c"] ] in + let o_hyp_map = ref StringMap.empty in + add_entries o_hyp_map ["b"; "a"; "c"] (str " : nat"); + let n_line_idents = [ ["a"]; ["b"]; ["c"]] in + let n_hyp_map = ref StringMap.empty in + add_entries n_hyp_map ["a"] (str " : foo"); + add_entries n_hyp_map ["b"] (str " : bar"); + add_entries n_hyp_map ["c"] (str " : nat"); + let expected = [flatten (wrap_in_bg "diff.removed" (seq [str "a"; str " : "; (tag "diff.removed" (str "nat"))])); + flatten (wrap_in_bg "diff.added" (seq [str "a"; str " : "; (tag "diff.added" (str "foo"))])); + flatten (wrap_in_bg "diff.removed" (seq [str "b"; str " : "; (tag "diff.removed" (str "nat"))])); + flatten (wrap_in_bg "diff.added" (seq [str "b"; str " : "; (tag "diff.added" (str "bar"))])); + flatten (seq [str "c"; str " : nat"]) + ] in + + let hyps_diff_list = diff_hyps o_line_idents !o_hyp_map n_line_idents !n_hyp_map in + + (*print_list hyps_diff_list;*) + (*db_print_list hyps_diff_list;*) + + List.iter2 (fun exp act -> + assert_equal ~msg:"added" ~printer:db_string_of_pp exp (flatten act)) + expected hyps_diff_list +let _ = add_test "diff_hyps compacted with split" t + + +(* other potential tests +coqtop/terminal formatting BLOCKED: CAN'T GET TAGS IN FORMATTER + white space at end of line + spanning diffs +shorten_diff_span + +MAYBE NOT WORTH IT +diff_pp/add_diff_tags + add/remove - show it preserves, recurs and processes: + nested in boxes + breaks, etc. preserved +diff_pp_combined with/without removed +*) + + +let _ = run_tests __FILE__ log_out_ch (List.rev !tests) diff --git a/test-suite/unit-tests/src/utest.ml b/test-suite/unit-tests/src/utest.ml index 069e6a4bf3..0cb1780ec9 100644 --- a/test-suite/unit-tests/src/utest.ml +++ b/test-suite/unit-tests/src/utest.ml @@ -42,10 +42,12 @@ let run_one logit test = let results = perform_test (fun _ -> ()) test in process_results results -(* run list of OUnit test cases, log results *) -let run_tests ml_fn tests = +let open_log_out_ch ml_fn = let log_fn = ml_fn ^ ".log" in - let out_ch = open_out log_fn in + open_out log_fn + +(* run list of OUnit test cases, log results *) +let run_tests ml_fn out_ch tests = let cprintf s = cfprintf out_ch s in let ceprintf s = cfprintf stderr s in let logit = logger out_ch in diff --git a/test-suite/unit-tests/src/utest.mli b/test-suite/unit-tests/src/utest.mli index 70928228bf..2e0f26e96b 100644 --- a/test-suite/unit-tests/src/utest.mli +++ b/test-suite/unit-tests/src/utest.mli @@ -9,4 +9,10 @@ val mk_bool_test : string -> string -> bool -> OUnit.test (* the string argument should be the name of the .ml file containing the tests; use __FILE__ for that purpose. *) -val run_tests : string -> OUnit.test list -> unit +val run_tests : string -> out_channel -> OUnit.test list -> unit + +(** open output channel for the test log file *) +(* the string argument should be the name of the .ml file + containing the tests; use __FILE__ for that purpose. + *) +val open_log_out_ch : string -> out_channel diff --git a/theories/Bool/Bool.v b/theories/Bool/Bool.v index edf78ed52d..66a82008d8 100644 --- a/theories/Bool/Bool.v +++ b/theories/Bool/Bool.v @@ -814,3 +814,10 @@ Defined. (** Reciprocally, from a decidability, we could state a [reflect] as soon as we have a [bool_of_sumbool]. *) + +(** For instance, we could state the correctness of [Bool.eqb] via [reflect]: *) + +Lemma eqb_spec (b b' : bool) : reflect (b = b') (eqb b b'). +Proof. + destruct b, b'; now constructor. +Qed. diff --git a/theories/Numbers/DecimalString.v b/theories/Numbers/DecimalString.v index 1a3220f63a..591024baec 100644 --- a/theories/Numbers/DecimalString.v +++ b/theories/Numbers/DecimalString.v @@ -94,7 +94,7 @@ Definition int_of_string s := match s with | EmptyString => Some (Pos Nil) | String a s' => - if ascii_dec a "-" then option_map Neg (uint_of_string s') + if Ascii.eqb a "-" then option_map Neg (uint_of_string s') else option_map Pos (uint_of_string s) end. @@ -131,8 +131,8 @@ Proof. - unfold int_of_string. destruct (string_of_uint d) eqn:Hd. + now destruct d. - + destruct ascii_dec; subst. - * now destruct d. + + case Ascii.eqb_spec. + * intros ->. now destruct d. * rewrite <- Hd, usu; auto. - rewrite usu; auto. Qed. @@ -141,8 +141,8 @@ Lemma sis s d : int_of_string s = Some d -> string_of_int d = s. Proof. destruct s; [intros [= <-]| ]; simpl; trivial. - destruct ascii_dec; subst; simpl. - - destruct (uint_of_string s) eqn:Hs; simpl; intros [= <-]. + case Ascii.eqb_spec. + - intros ->. destruct (uint_of_string s) eqn:Hs; simpl; intros [= <-]. simpl; f_equal. now apply sus. - destruct d; [ | now destruct uint_of_char]. simpl string_of_int. @@ -178,7 +178,7 @@ Definition int_of_string s := match s with | EmptyString => None | String a s' => - if ascii_dec a "-" then option_map Neg (uint_of_string s') + if Ascii.eqb a "-" then option_map Neg (uint_of_string s') else option_map Pos (uint_of_string s) end. @@ -228,8 +228,8 @@ Proof. unfold int_of_string. destruct (string_of_uint d) eqn:Hd. + now destruct d. - + destruct ascii_dec; subst. - * now destruct d. + + case Ascii.eqb_spec. + * intros ->. now destruct d. * rewrite <- Hd, usu; auto. now intros ->. - intros _ H. rewrite usu; auto. now intros ->. @@ -253,8 +253,8 @@ Lemma sis s d : int_of_string s = Some d -> string_of_int d = s. Proof. destruct s; [intros [=]| ]; simpl. - destruct ascii_dec; subst; simpl. - - destruct (uint_of_string s) eqn:Hs; simpl; intros [= <-]. + case Ascii.eqb_spec. + - intros ->. destruct (uint_of_string s) eqn:Hs; simpl; intros [= <-]. simpl; f_equal. now apply sus. - destruct d; [ | now destruct uint_of_char]. simpl string_of_int. diff --git a/theories/Reals/Machin.v b/theories/Reals/Machin.v index cdf98cbdef..8f7e07ac4d 100644 --- a/theories/Reals/Machin.v +++ b/theories/Reals/Machin.v @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -Require Import Fourier. +Require Import Lra. Require Import Rbase. Require Import Rtrigo1. Require Import Ranalysis_reg. @@ -67,7 +67,7 @@ assert (atan x <= PI/4). assert (atan y < PI/4). rewrite <- atan_1; apply atan_increasing. assumption. -rewrite Ropp_div; split; fourier. +rewrite Ropp_div; split; lra. Qed. (* A simple formula, reasonably efficient. *) @@ -77,8 +77,8 @@ assert (utility : 0 < PI/2) by (apply PI2_RGT_0). rewrite <- atan_1. rewrite (atan_sub_correct 1 (/2)). apply f_equal, f_equal; unfold atan_sub; field. - apply Rgt_not_eq; fourier. - apply tech; try split; try fourier. + apply Rgt_not_eq; lra. + apply tech; try split; try lra. apply atan_bound. Qed. @@ -86,7 +86,7 @@ Lemma Machin_4_5_239 : PI/4 = 4 * atan (/5) - atan(/239). Proof. rewrite <- atan_1. rewrite (atan_sub_correct 1 (/5)); - [ | apply Rgt_not_eq; fourier | apply tech; try split; fourier | + [ | apply Rgt_not_eq; lra | apply tech; try split; lra | apply atan_bound ]. replace (4 * atan (/5) - atan (/239)) with (atan (/5) + (atan (/5) + (atan (/5) + (atan (/5) + - @@ -95,17 +95,17 @@ apply f_equal. replace (atan_sub 1 (/5)) with (2/3) by (unfold atan_sub; field). rewrite (atan_sub_correct (2/3) (/5)); - [apply f_equal | apply Rgt_not_eq; fourier | apply tech; try split; fourier | + [apply f_equal | apply Rgt_not_eq; lra | apply tech; try split; lra | apply atan_bound ]. replace (atan_sub (2/3) (/5)) with (7/17) by (unfold atan_sub; field). rewrite (atan_sub_correct (7/17) (/5)); - [apply f_equal | apply Rgt_not_eq; fourier | apply tech; try split; fourier | + [apply f_equal | apply Rgt_not_eq; lra | apply tech; try split; lra | apply atan_bound ]. replace (atan_sub (7/17) (/5)) with (9/46) by (unfold atan_sub; field). rewrite (atan_sub_correct (9/46) (/5)); - [apply f_equal | apply Rgt_not_eq; fourier | apply tech; try split; fourier | + [apply f_equal | apply Rgt_not_eq; lra | apply tech; try split; lra | apply atan_bound ]. rewrite <- atan_opp; apply f_equal. unfold atan_sub; field. @@ -115,7 +115,7 @@ Lemma Machin_2_3_7 : PI/4 = 2 * atan(/3) + (atan (/7)). Proof. rewrite <- atan_1. rewrite (atan_sub_correct 1 (/3)); - [ | apply Rgt_not_eq; fourier | apply tech; try split; fourier | + [ | apply Rgt_not_eq; lra | apply tech; try split; lra | apply atan_bound ]. replace (2 * atan (/3) + atan (/7)) with (atan (/3) + (atan (/3) + atan (/7))) by ring. @@ -123,7 +123,7 @@ apply f_equal. replace (atan_sub 1 (/3)) with (/2) by (unfold atan_sub; field). rewrite (atan_sub_correct (/2) (/3)); - [apply f_equal | apply Rgt_not_eq; fourier | apply tech; try split; fourier | + [apply f_equal | apply Rgt_not_eq; lra | apply tech; try split; lra | apply atan_bound ]. apply f_equal; unfold atan_sub; field. Qed. @@ -138,19 +138,19 @@ Lemma PI_2_3_7_ineq : sum_f_R0 (tg_alt PI_2_3_7_tg) (S (2 * N)) <= PI / 4 <= sum_f_R0 (tg_alt PI_2_3_7_tg) (2 * N). Proof. -assert (dec3 : 0 <= /3 <= 1) by (split; fourier). -assert (dec7 : 0 <= /7 <= 1) by (split; fourier). +assert (dec3 : 0 <= /3 <= 1) by (split; lra). +assert (dec7 : 0 <= /7 <= 1) by (split; lra). assert (decr : Un_decreasing PI_2_3_7_tg). apply Ratan_seq_decreasing in dec3. apply Ratan_seq_decreasing in dec7. intros n; apply Rplus_le_compat. - apply Rmult_le_compat_l; [ fourier | exact (dec3 n)]. + apply Rmult_le_compat_l; [ lra | exact (dec3 n)]. exact (dec7 n). assert (cv : Un_cv PI_2_3_7_tg 0). apply Ratan_seq_converging in dec3. apply Ratan_seq_converging in dec7. intros eps ep. - assert (ep' : 0 < eps /3) by fourier. + assert (ep' : 0 < eps /3) by lra. destruct (dec3 _ ep') as [N1 Pn1]; destruct (dec7 _ ep') as [N2 Pn2]. exists (N1 + N2)%nat; intros n Nn. unfold PI_2_3_7_tg. @@ -161,14 +161,14 @@ assert (cv : Un_cv PI_2_3_7_tg 0). apply Rplus_lt_compat. unfold R_dist, Rminus, Rdiv. rewrite <- (Rmult_0_r 2), <- Ropp_mult_distr_r_reverse. - rewrite <- Rmult_plus_distr_l, Rabs_mult, (Rabs_pos_eq 2);[|fourier]. - rewrite Rmult_assoc; apply Rmult_lt_compat_l;[fourier | ]. + rewrite <- Rmult_plus_distr_l, Rabs_mult, (Rabs_pos_eq 2);[|lra]. + rewrite Rmult_assoc; apply Rmult_lt_compat_l;[lra | ]. apply (Pn1 n); omega. apply (Pn2 n); omega. rewrite Machin_2_3_7. -rewrite !atan_eq_ps_atan; try (split; fourier). +rewrite !atan_eq_ps_atan; try (split; lra). unfold ps_atan; destruct (in_int (/3)); destruct (in_int (/7)); - try match goal with id : ~ _ |- _ => case id; split; fourier end. + try match goal with id : ~ _ |- _ => case id; split; lra end. destruct (ps_atan_exists_1 (/3)) as [v3 Pv3]. destruct (ps_atan_exists_1 (/7)) as [v7 Pv7]. assert (main : Un_cv (sum_f_R0 (tg_alt PI_2_3_7_tg)) (2 * v3 + v7)). diff --git a/theories/Reals/PSeries_reg.v b/theories/Reals/PSeries_reg.v index 61d1b5afea..146d691018 100644 --- a/theories/Reals/PSeries_reg.v +++ b/theories/Reals/PSeries_reg.v @@ -15,7 +15,7 @@ Require Import Ranalysis1. Require Import MVT. Require Import Max. Require Import Even. -Require Import Fourier. +Require Import Lra. Local Open Scope R_scope. (* Boule is French for Ball *) @@ -431,7 +431,7 @@ assert (ctrho : forall n z, Boule c d z -> continuity_pt (rho_ n) z). intros y dyz; unfold rho_; destruct (Req_EM_T y x) as [xy | xny]. rewrite xy in dyz. destruct (Rle_dec delta (Rabs (z - x))). - rewrite Rmin_left, R_dist_sym in dyz; unfold R_dist in dyz; fourier. + rewrite Rmin_left, R_dist_sym in dyz; unfold R_dist in dyz; lra. rewrite Rmin_right, R_dist_sym in dyz; unfold R_dist in dyz; [case (Rlt_irrefl _ dyz) |apply Rlt_le, Rnot_le_gt; assumption]. reflexivity. @@ -449,7 +449,7 @@ assert (ctrho : forall n z, Boule c d z -> continuity_pt (rho_ n) z). assert (CVU rho_ rho c d ). intros eps ep. assert (ep8 : 0 < eps/8). - fourier. + lra. destruct (cvu _ ep8) as [N Pn1]. assert (cauchy1 : forall n p, (N <= n)%nat -> (N <= p)%nat -> forall z, Boule c d z -> Rabs (f' n z - f' p z) < eps/4). @@ -537,7 +537,7 @@ assert (CVU rho_ rho c d ). simpl; unfold R_dist. unfold Rminus; rewrite (Rplus_comm y), Rplus_assoc, Rplus_opp_r, Rplus_0_r. rewrite Rabs_pos_eq;[ |apply Rlt_le; assumption ]. - apply Rlt_le_trans with (Rmin (Rmin d' d2) delta);[fourier | ]. + apply Rlt_le_trans with (Rmin (Rmin d' d2) delta);[lra | ]. apply Rle_trans with (Rmin d' d2); apply Rmin_l. apply Rle_trans with (1 := R_dist_tri _ _ (rho_ p (y + Rmin (Rmin d' d2) delta/2))). apply Rplus_le_compat. @@ -548,33 +548,32 @@ assert (CVU rho_ rho c d ). replace (rho_ p (y + Rmin (Rmin d' d2) delta / 2)) with ((f p (y + Rmin (Rmin d' d2) delta / 2) - f p x)/ ((y + Rmin (Rmin d' d2) delta / 2) - x)). - apply step_2; auto; try fourier. + apply step_2; auto; try lra. assert (0 < pos delta) by (apply cond_pos). apply Boule_convex with y (y + delta/2). assumption. destruct (Pdelta (y + delta/2)); auto. - rewrite xy; unfold Boule; rewrite Rabs_pos_eq; try fourier; auto. - split; try fourier. + rewrite xy; unfold Boule; rewrite Rabs_pos_eq; try lra; auto. + split; try lra. apply Rplus_le_compat_l, Rmult_le_compat_r;[ | apply Rmin_r]. now apply Rlt_le, Rinv_0_lt_compat, Rlt_0_2. - apply Rminus_not_eq_right; rewrite xy; apply Rgt_not_eq; fourier. unfold rho_. destruct (Req_EM_T (y + Rmin (Rmin d' d2) delta/2) x) as [ymx | ymnx]. - case (RIneq.Rle_not_lt _ _ (Req_le _ _ ymx)); fourier. + case (RIneq.Rle_not_lt _ _ (Req_le _ _ ymx)); lra. reflexivity. unfold rho_. destruct (Req_EM_T (y + Rmin (Rmin d' d2) delta / 2) x) as [ymx | ymnx]. - case (RIneq.Rle_not_lt _ _ (Req_le _ _ ymx)); fourier. + case (RIneq.Rle_not_lt _ _ (Req_le _ _ ymx)); lra. reflexivity. - apply Rlt_le, Pd2; split;[split;[exact I | apply Rlt_not_eq; fourier] | ]. + apply Rlt_le, Pd2; split;[split;[exact I | apply Rlt_not_eq; lra] | ]. simpl; unfold R_dist. unfold Rminus; rewrite (Rplus_comm y), Rplus_assoc, Rplus_opp_r, Rplus_0_r. - rewrite Rabs_pos_eq;[ | fourier]. - apply Rlt_le_trans with (Rmin (Rmin d' d2) delta); [fourier |]. + rewrite Rabs_pos_eq;[ | lra]. + apply Rlt_le_trans with (Rmin (Rmin d' d2) delta); [lra |]. apply Rle_trans with (Rmin d' d2). solve[apply Rmin_l]. solve[apply Rmin_r]. - apply Rlt_le, Rlt_le_trans with (eps/4);[ | fourier]. + apply Rlt_le, Rlt_le_trans with (eps/4);[ | lra]. unfold rho_; destruct (Req_EM_T y x); solve[auto]. assert (unif_ac' : forall p, (N <= p)%nat -> forall y, Boule c d y -> Rabs (rho y - rho_ p y) < eps). @@ -589,7 +588,7 @@ assert (CVU rho_ rho c d ). intros eps' ep'; simpl; exists 0%nat; intros; rewrite R_dist_eq; assumption. intros p pN y b_y. replace eps with (eps/2 + eps/2) by field. - assert (ep2 : 0 < eps/2) by fourier. + assert (ep2 : 0 < eps/2) by lra. destruct (cvrho y b_y _ ep2) as [N2 Pn2]. apply Rle_lt_trans with (1 := R_dist_tri _ _ (rho_ (max N N2) y)). apply Rplus_lt_le_compat. diff --git a/theories/Reals/R_sqrt.v b/theories/Reals/R_sqrt.v index d4035fad62..6991923b13 100644 --- a/theories/Reals/R_sqrt.v +++ b/theories/Reals/R_sqrt.v @@ -155,6 +155,22 @@ Proof. | apply (sqrt_positivity x (Rlt_le 0 x H1)) ]. Qed. +Lemma Rlt_mult_inv_pos : forall x y:R, 0 < x -> 0 < y -> 0 < x * / y. +intros x y H H0; try assumption. +replace 0 with (x * 0). +apply Rmult_lt_compat_l; auto with real. +ring. +Qed. + +Lemma Rle_mult_inv_pos : forall x y:R, 0 <= x -> 0 < y -> 0 <= x * / y. +intros x y H H0; try assumption. +case H; intros. +red; left. +apply Rlt_mult_inv_pos; auto with real. +rewrite <- H1. +red; right; ring. +Qed. + Lemma sqrt_div_alt : forall x y : R, 0 < y -> sqrt (x / y) = sqrt x / sqrt y. Proof. @@ -176,14 +192,14 @@ Proof. clearbody Hx'. clear Hx. apply Rsqr_inj. apply sqrt_pos. - apply Fourier_util.Rle_mult_inv_pos. + apply Rle_mult_inv_pos. apply Rsqrt_positivity. now apply sqrt_lt_R0. rewrite Rsqr_div, 2!Rsqr_sqrt. unfold Rsqr. now rewrite Rsqrt_Rsqrt. now apply Rlt_le. - now apply Fourier_util.Rle_mult_inv_pos. + now apply Rle_mult_inv_pos. apply Rgt_not_eq. now apply sqrt_lt_R0. Qed. diff --git a/theories/Reals/Ranalysis5.v b/theories/Reals/Ranalysis5.v index afb78e1c8e..e66130b347 100644 --- a/theories/Reals/Ranalysis5.v +++ b/theories/Reals/Ranalysis5.v @@ -12,7 +12,7 @@ Require Import Rbase. Require Import Ranalysis_reg. Require Import Rfunctions. Require Import Rseries. -Require Import Fourier. +Require Import Lra. Require Import RiemannInt. Require Import SeqProp. Require Import Max. @@ -56,7 +56,7 @@ Proof. } rewrite f_eq_g in Htemp by easy. unfold id in Htemp. - fourier. + lra. Qed. Lemma derivable_pt_id_interv : forall (lb ub x:R), @@ -99,7 +99,7 @@ assert (forall x l, lb < x < ub -> (derivable_pt_abs f x l <-> derivable_pt_abs apply Req_le ; apply Rabs_right ; apply Rgt_ge ; assumption. split. assert (Sublemma : forall x y z, -z < y - x -> x < y + z). - intros ; fourier. + intros ; lra. apply Sublemma. apply Sublemma2. rewrite Rabs_Ropp. apply Rlt_le_trans with (r2:=a-lb) ; [| apply RRle_abs] ; @@ -108,7 +108,7 @@ assert (forall x l, lb < x < ub -> (derivable_pt_abs f x l <-> derivable_pt_abs apply Rlt_le_trans with (r2:=Rmin (ub - a) (a - lb)) ; [| apply Rmin_r] ; apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))) ; [| apply Rmin_r] ; assumption. assert (Sublemma : forall x y z, y < z - x -> x + y < z). - intros ; fourier. + intros ; lra. apply Sublemma. apply Sublemma2. apply Rlt_le_trans with (r2:=ub-a) ; [| apply RRle_abs] ; @@ -137,7 +137,7 @@ assert (forall x l, lb < x < ub -> (derivable_pt_abs f x l <-> derivable_pt_abs apply Req_le ; apply Rabs_right ; apply Rgt_ge ; assumption. split. assert (Sublemma : forall x y z, -z < y - x -> x < y + z). - intros ; fourier. + intros ; lra. apply Sublemma. apply Sublemma2. rewrite Rabs_Ropp. apply Rlt_le_trans with (r2:=a-lb) ; [| apply RRle_abs] ; @@ -146,7 +146,7 @@ assert (forall x l, lb < x < ub -> (derivable_pt_abs f x l <-> derivable_pt_abs apply Rlt_le_trans with (r2:=Rmin (ub - a) (a - lb)) ; [| apply Rmin_r] ; apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))) ; [| apply Rmin_r] ; assumption. assert (Sublemma : forall x y z, y < z - x -> x + y < z). - intros ; fourier. + intros ; lra. apply Sublemma. apply Sublemma2. apply Rlt_le_trans with (r2:=ub-a) ; [| apply RRle_abs] ; @@ -415,7 +415,7 @@ Ltac case_le H := let h' := fresh in match t with ?x <= ?y => case (total_order_T x y); [intros h'; case h'; clear h' | - intros h'; clear -H h'; elimtype False; fourier ] end. + intros h'; clear -H h'; elimtype False; lra ] end. (* end hide *) @@ -539,37 +539,37 @@ intros f g lb ub lb_lt_ub f_incr_interv f_eq_g f_cont_interv b b_encad. assert (x1_encad : lb <= x1 <= ub). split. apply RmaxLess2. apply Rlt_le. rewrite Hx1. rewrite Sublemma. - split. apply Rlt_trans with (r2:=x) ; fourier. + split. apply Rlt_trans with (r2:=x) ; lra. assumption. assert (x2_encad : lb <= x2 <= ub). split. apply Rlt_le ; rewrite Hx2 ; apply Rgt_lt ; rewrite Sublemma2. - split. apply Rgt_trans with (r2:=x) ; fourier. + split. apply Rgt_trans with (r2:=x) ; lra. assumption. apply Rmin_r. assert (x_lt_x2 : x < x2). rewrite Hx2. apply Rgt_lt. rewrite Sublemma2. - split ; fourier. + split ; lra. assert (x1_lt_x : x1 < x). rewrite Hx1. rewrite Sublemma. - split ; fourier. + split ; lra. exists (Rmin (f x - f x1) (f x2 - f x)). - split. apply Rmin_pos ; apply Rgt_minus. apply f_incr_interv ; [apply RmaxLess2 | | ] ; fourier. + split. apply Rmin_pos ; apply Rgt_minus. apply f_incr_interv ; [apply RmaxLess2 | | ] ; lra. apply f_incr_interv ; intuition. intros y Temp. destruct Temp as (_,y_cond). rewrite <- f_x_b in y_cond. assert (Temp : forall x y d1 d2, d1 > 0 -> d2 > 0 -> Rabs (y - x) < Rmin d1 d2 -> x - d1 <= y <= x + d2). intros. - split. assert (H10 : forall x y z, x - y <= z -> x - z <= y). intuition. fourier. + split. assert (H10 : forall x y z, x - y <= z -> x - z <= y). intuition. lra. apply H10. apply Rle_trans with (r2:=Rabs (y0 - x0)). replace (Rabs (y0 - x0)) with (Rabs (x0 - y0)). apply RRle_abs. rewrite <- Rabs_Ropp. unfold Rminus ; rewrite Ropp_plus_distr. rewrite Ropp_involutive. intuition. apply Rle_trans with (r2:= Rmin d1 d2). apply Rlt_le ; assumption. apply Rmin_l. - assert (H10 : forall x y z, x - y <= z -> x <= y + z). intuition. fourier. + assert (H10 : forall x y z, x - y <= z -> x <= y + z). intuition. lra. apply H10. apply Rle_trans with (r2:=Rabs (y0 - x0)). apply RRle_abs. apply Rle_trans with (r2:= Rmin d1 d2). apply Rlt_le ; assumption. apply Rmin_r. @@ -602,12 +602,12 @@ intros f g lb ub lb_lt_ub f_incr_interv f_eq_g f_cont_interv b b_encad. assert (x1_neq_x' : x1 <> x'). intro Hfalse. rewrite Hfalse, f_x'_y in y_cond. assert (Hf : Rabs (y - f x) < f x - y). - apply Rlt_le_trans with (r2:=Rmin (f x - y) (f x2 - f x)). fourier. + apply Rlt_le_trans with (r2:=Rmin (f x - y) (f x2 - f x)). lra. apply Rmin_l. assert(Hfin : f x - y < f x - y). apply Rle_lt_trans with (r2:=Rabs (y - f x)). replace (Rabs (y - f x)) with (Rabs (f x - y)). apply RRle_abs. - rewrite <- Rabs_Ropp. replace (- (f x - y)) with (y - f x) by field ; reflexivity. fourier. + rewrite <- Rabs_Ropp. replace (- (f x - y)) with (y - f x) by field ; reflexivity. lra. apply (Rlt_irrefl (f x - y)) ; assumption. split ; intuition. assert (x'_lb : x - eps < x'). @@ -619,17 +619,17 @@ intros f g lb ub lb_lt_ub f_incr_interv f_eq_g f_cont_interv b b_encad. assert (x1_neq_x' : x' <> x2). intro Hfalse. rewrite <- Hfalse, f_x'_y in y_cond. assert (Hf : Rabs (y - f x) < y - f x). - apply Rlt_le_trans with (r2:=Rmin (f x - f x1) (y - f x)). fourier. + apply Rlt_le_trans with (r2:=Rmin (f x - f x1) (y - f x)). lra. apply Rmin_r. assert(Hfin : y - f x < y - f x). - apply Rle_lt_trans with (r2:=Rabs (y - f x)). apply RRle_abs. fourier. + apply Rle_lt_trans with (r2:=Rabs (y - f x)). apply RRle_abs. lra. apply (Rlt_irrefl (y - f x)) ; assumption. split ; intuition. assert (x'_ub : x' < x + eps). apply Sublemma3. split. intuition. apply Rlt_not_eq. apply Rlt_le_trans with (r2:=x2) ; [ |rewrite Hx2 ; apply Rmin_l] ; intuition. - apply Rabs_def1 ; fourier. + apply Rabs_def1 ; lra. assumption. split. apply Rle_trans with (r2:=x1) ; intuition. apply Rle_trans with (r2:=x2) ; intuition. @@ -742,7 +742,7 @@ intros f g lb ub x Prf g_cont_pur lb_lt_ub x_encad Prg_incr f_eq_g df_neq. assert (lb <= x + h <= ub). split. assert (Sublemma : forall x y z, -z <= y - x -> x <= y + z). - intros ; fourier. + intros ; lra. apply Sublemma. apply Rlt_le ; apply Sublemma2. rewrite Rabs_Ropp. apply Rlt_le_trans with (r2:=x-lb) ; [| apply RRle_abs] ; @@ -751,7 +751,7 @@ intros f g lb ub x Prf g_cont_pur lb_lt_ub x_encad Prg_incr f_eq_g df_neq. apply Rlt_le_trans with (r2:=delta''). assumption. intuition. apply Rmin_r. apply Rgt_minus. intuition. assert (Sublemma : forall x y z, y <= z - x -> x + y <= z). - intros ; fourier. + intros ; lra. apply Sublemma. apply Rlt_le ; apply Sublemma2. apply Rlt_le_trans with (r2:=ub-x) ; [| apply RRle_abs] ; @@ -767,7 +767,7 @@ intros f g lb ub x Prf g_cont_pur lb_lt_ub x_encad Prg_incr f_eq_g df_neq. assumption. split ; [|intuition]. assert (Sublemma : forall x y z, - z <= y - x -> x <= y + z). - intros ; fourier. + intros ; lra. apply Sublemma ; apply Rlt_le ; apply Sublemma2. rewrite Rabs_Ropp. apply Rlt_le_trans with (r2:=x-lb) ; [| apply RRle_abs] ; apply Rlt_le_trans with (r2:=Rmin (x - lb) (ub - x)) ; [| apply Rmin_l] ; @@ -1031,7 +1031,7 @@ Lemma derivable_pt_lim_CVU : forall (fn fn':nat -> R -> R) (f g:R->R) derivable_pt_lim f x (g x). Proof. intros fn fn' f g x c' r xinb Dfn_eq_fn' fn_CV_f fn'_CVU_g g_cont eps eps_pos. -assert (eps_8_pos : 0 < eps / 8) by fourier. +assert (eps_8_pos : 0 < eps / 8) by lra. elim (g_cont x xinb _ eps_8_pos) ; clear g_cont ; intros delta1 (delta1_pos, g_cont). destruct (Ball_in_inter _ _ _ _ _ xinb @@ -1041,11 +1041,11 @@ exists delta; intros h hpos hinbdelta. assert (eps'_pos : 0 < (Rabs h) * eps / 4). unfold Rdiv ; rewrite Rmult_assoc ; apply Rmult_lt_0_compat. apply Rabs_pos_lt ; assumption. -fourier. +lra. destruct (fn_CV_f x xinb ((Rabs h) * eps / 4) eps'_pos) as [N2 fnx_CV_fx]. assert (xhinbxdelta : Boule x delta (x + h)). clear -hinbdelta; apply Rabs_def2 in hinbdelta; unfold Boule; simpl. - destruct hinbdelta; apply Rabs_def1; fourier. + destruct hinbdelta; apply Rabs_def1; lra. assert (t : Boule c' r (x + h)). apply Pdelta in xhinbxdelta; tauto. destruct (fn_CV_f (x+h) t ((Rabs h) * eps / 4) eps'_pos) as [N1 fnxh_CV_fxh]. @@ -1064,17 +1064,17 @@ assert (Main : Rabs ((f (x+h) - fn N (x+h)) - (f x - fn N x) + (fn N (x+h) - fn exists (fn' N c) ; apply Dfn_eq_fn'. assert (t : Boule x delta c). apply Rabs_def2 in xhinbxdelta; destruct xhinbxdelta; destruct c_encad. - apply Rabs_def2 in xinb; apply Rabs_def1; fourier. + apply Rabs_def2 in xinb; apply Rabs_def1; lra. apply Pdelta in t; tauto. assert (pr2 : forall c : R, x + h < c < x -> derivable_pt id c). solve[intros; apply derivable_id]. - assert (xh_x : x+h < x) by fourier. + assert (xh_x : x+h < x) by lra. assert (pr3 : forall c : R, x + h <= c <= x -> continuity_pt (fn N) c). intros c c_encad ; apply derivable_continuous_pt. exists (fn' N c) ; apply Dfn_eq_fn' ; intuition. assert (t : Boule x delta c). apply Rabs_def2 in xhinbxdelta; destruct xhinbxdelta. - apply Rabs_def2 in xinb; apply Rabs_def1; fourier. + apply Rabs_def2 in xinb; apply Rabs_def1; lra. apply Pdelta in t; tauto. assert (pr4 : forall c : R, x + h <= c <= x -> continuity_pt id c). solve[intros; apply derivable_continuous ; apply derivable_id]. @@ -1117,7 +1117,7 @@ assert (Main : Rabs ((f (x+h) - fn N (x+h)) - (f x - fn N x) + (fn N (x+h) - fn assert (t : Boule x delta c). destruct P. apply Rabs_def2 in xhinbxdelta; destruct xhinbxdelta. - apply Rabs_def2 in xinb; apply Rabs_def1; fourier. + apply Rabs_def2 in xinb; apply Rabs_def1; lra. apply Pdelta in t; tauto. apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + Rabs h * (eps / 8) + Rabs h * (eps / 8)). @@ -1131,27 +1131,27 @@ assert (Main : Rabs ((f (x+h) - fn N (x+h)) - (f x - fn N x) + (fn N (x+h) - fn apply Rlt_trans with (Rabs h). apply Rabs_def1. apply Rlt_trans with 0. - destruct P; fourier. + destruct P; lra. apply Rabs_pos_lt ; assumption. - rewrite <- Rabs_Ropp, Rabs_pos_eq, Ropp_involutive;[ | fourier]. - destruct P; fourier. + rewrite <- Rabs_Ropp, Rabs_pos_eq, Ropp_involutive;[ | lra]. + destruct P; lra. clear -Pdelta xhinbxdelta. apply Pdelta in xhinbxdelta; destruct xhinbxdelta as [_ P']. apply Rabs_def2 in P'; simpl in P'; destruct P'; - apply Rabs_def1; fourier. + apply Rabs_def1; lra. rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite <- Rmult_plus_distr_l. replace (Rabs h * eps / 4 + (Rabs h * eps / 4 + Rabs h * (eps / 8 + eps / 8))) with (Rabs h * (eps / 4 + eps / 4 + eps / 8 + eps / 8)) by field. apply Rmult_lt_compat_l. apply Rabs_pos_lt ; assumption. - fourier. + lra. assert (H := pr1 c P) ; elim H ; clear H ; intros l Hl. assert (Temp : l = fn' N c). assert (bc'rc : Boule c' r c). assert (t : Boule x delta c). clear - xhinbxdelta P. destruct P; apply Rabs_def2 in xhinbxdelta; destruct xhinbxdelta. - apply Rabs_def1; fourier. + apply Rabs_def1; lra. apply Pdelta in t; tauto. assert (Hl' := Dfn_eq_fn' c N bc'rc). unfold derivable_pt_abs in Hl; clear -Hl Hl'. @@ -1175,17 +1175,17 @@ assert (Main : Rabs ((f (x+h) - fn N (x+h)) - (f x - fn N x) + (fn N (x+h) - fn exists (fn' N c) ; apply Dfn_eq_fn'. assert (t : Boule x delta c). apply Rabs_def2 in xhinbxdelta; destruct xhinbxdelta; destruct c_encad. - apply Rabs_def2 in xinb; apply Rabs_def1; fourier. + apply Rabs_def2 in xinb; apply Rabs_def1; lra. apply Pdelta in t; tauto. assert (pr2 : forall c : R, x < c < x + h -> derivable_pt id c). solve[intros; apply derivable_id]. - assert (xh_x : x < x + h) by fourier. + assert (xh_x : x < x + h) by lra. assert (pr3 : forall c : R, x <= c <= x + h -> continuity_pt (fn N) c). intros c c_encad ; apply derivable_continuous_pt. exists (fn' N c) ; apply Dfn_eq_fn' ; intuition. assert (t : Boule x delta c). apply Rabs_def2 in xhinbxdelta; destruct xhinbxdelta. - apply Rabs_def2 in xinb; apply Rabs_def1; fourier. + apply Rabs_def2 in xinb; apply Rabs_def1; lra. apply Pdelta in t; tauto. assert (pr4 : forall c : R, x <= c <= x + h -> continuity_pt id c). solve[intros; apply derivable_continuous ; apply derivable_id]. @@ -1223,7 +1223,7 @@ assert (Main : Rabs ((f (x+h) - fn N (x+h)) - (f x - fn N x) + (fn N (x+h) - fn assert (t : Boule x delta c). destruct P. apply Rabs_def2 in xhinbxdelta; destruct xhinbxdelta. - apply Rabs_def2 in xinb; apply Rabs_def1; fourier. + apply Rabs_def2 in xinb; apply Rabs_def1; lra. apply Pdelta in t; tauto. apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + Rabs h * (eps / 8) + Rabs h * (eps / 8)). @@ -1236,27 +1236,27 @@ assert (Main : Rabs ((f (x+h) - fn N (x+h)) - (f x - fn N x) + (fn N (x+h) - fn apply Rlt_not_eq ; exact (proj1 P). apply Rlt_trans with (Rabs h). apply Rabs_def1. - destruct P; rewrite Rabs_pos_eq;fourier. + destruct P; rewrite Rabs_pos_eq;lra. apply Rle_lt_trans with 0. - assert (t := Rabs_pos h); clear -t; fourier. - clear -P; destruct P; fourier. + assert (t := Rabs_pos h); clear -t; lra. + clear -P; destruct P; lra. clear -Pdelta xhinbxdelta. apply Pdelta in xhinbxdelta; destruct xhinbxdelta as [_ P']. apply Rabs_def2 in P'; simpl in P'; destruct P'; - apply Rabs_def1; fourier. + apply Rabs_def1; lra. rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite <- Rmult_plus_distr_l. replace (Rabs h * eps / 4 + (Rabs h * eps / 4 + Rabs h * (eps / 8 + eps / 8))) with (Rabs h * (eps / 4 + eps / 4 + eps / 8 + eps / 8)) by field. apply Rmult_lt_compat_l. apply Rabs_pos_lt ; assumption. - fourier. + lra. assert (H := pr1 c P) ; elim H ; clear H ; intros l Hl. assert (Temp : l = fn' N c). assert (bc'rc : Boule c' r c). assert (t : Boule x delta c). clear - xhinbxdelta P. destruct P; apply Rabs_def2 in xhinbxdelta; destruct xhinbxdelta. - apply Rabs_def1; fourier. + apply Rabs_def1; lra. apply Pdelta in t; tauto. assert (Hl' := Dfn_eq_fn' c N bc'rc). unfold derivable_pt_abs in Hl; clear -Hl Hl'. diff --git a/theories/Reals/Ratan.v b/theories/Reals/Ratan.v index ce39d5ffe4..03e6ff61ab 100644 --- a/theories/Reals/Ratan.v +++ b/theories/Reals/Ratan.v @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -Require Import Fourier. +Require Import Lra. Require Import Rbase. Require Import PSeries_reg. Require Import Rtrigo1. @@ -32,7 +32,7 @@ intros x y; unfold Rdiv; rewrite <-Ropp_mult_distr_l_reverse; reflexivity. Qed. Definition pos_half_prf : 0 < /2. -Proof. fourier. Qed. +Proof. lra. Qed. Definition pos_half := mkposreal (/2) pos_half_prf. @@ -40,15 +40,15 @@ Lemma Boule_half_to_interval : forall x , Boule (/2) pos_half x -> 0 <= x <= 1. Proof. unfold Boule, pos_half; simpl. -intros x b; apply Rabs_def2 in b; destruct b; split; fourier. +intros x b; apply Rabs_def2 in b; destruct b; split; lra. Qed. Lemma Boule_lt : forall c r x, Boule c r x -> Rabs x < Rabs c + r. Proof. unfold Boule; intros c r x h. apply Rabs_def2 in h; destruct h; apply Rabs_def1; - (destruct (Rle_lt_dec 0 c);[rewrite Rabs_pos_eq; fourier | - rewrite <- Rabs_Ropp, Rabs_pos_eq; fourier]). + (destruct (Rle_lt_dec 0 c);[rewrite Rabs_pos_eq; lra | + rewrite <- Rabs_Ropp, Rabs_pos_eq; lra]). Qed. (* The following lemma does not belong here. *) @@ -117,53 +117,53 @@ intros [ | N] Npos n decr to0 cv nN. case (even_odd_cor n) as [p' [neven | nodd]]. rewrite neven. destruct (alternated_series_ineq _ _ p' decr to0 cv) as [D E]. - unfold R_dist; rewrite Rabs_pos_eq;[ | fourier]. + unfold R_dist; rewrite Rabs_pos_eq;[ | lra]. assert (dist : (p <= p')%nat) by omega. assert (t := decreasing_prop _ _ _ (CV_ALT_step1 f decr) dist). apply Rle_trans with (sum_f_R0 (tg_alt f) (2 * p) - l). unfold Rminus; apply Rplus_le_compat_r; exact t. match goal with _ : ?a <= l, _ : l <= ?b |- _ => replace (f (S (2 * p))) with (b - a) by - (rewrite tech5; unfold tg_alt; rewrite pow_1_odd; ring); fourier + (rewrite tech5; unfold tg_alt; rewrite pow_1_odd; ring); lra end. rewrite nodd; destruct (alternated_series_ineq _ _ p' decr to0 cv) as [D E]. unfold R_dist; rewrite <- Rabs_Ropp, Rabs_pos_eq, Ropp_minus_distr; - [ | fourier]. + [ | lra]. assert (dist : (p <= p')%nat) by omega. apply Rle_trans with (l - sum_f_R0 (tg_alt f) (S (2 * p))). unfold Rminus; apply Rplus_le_compat_l, Ropp_le_contravar. solve[apply Rge_le, (growing_prop _ _ _ (CV_ALT_step0 f decr) dist)]. unfold Rminus; rewrite tech5, Ropp_plus_distr, <- Rplus_assoc. - unfold tg_alt at 2; rewrite pow_1_odd; fourier. + unfold tg_alt at 2; rewrite pow_1_odd; lra. rewrite Nodd; destruct (alternated_series_ineq _ _ p decr to0 cv) as [B _]. destruct (alternated_series_ineq _ _ (S p) decr to0 cv) as [_ C]. assert (keep : (2 * S p = S (S ( 2 * p)))%nat) by ring. case (even_odd_cor n) as [p' [neven | nodd]]. rewrite neven; destruct (alternated_series_ineq _ _ p' decr to0 cv) as [D E]. - unfold R_dist; rewrite Rabs_pos_eq;[ | fourier]. + unfold R_dist; rewrite Rabs_pos_eq;[ | lra]. assert (dist : (S p < S p')%nat) by omega. apply Rle_trans with (sum_f_R0 (tg_alt f) (2 * S p) - l). unfold Rminus; apply Rplus_le_compat_r, (decreasing_prop _ _ _ (CV_ALT_step1 f decr)). omega. rewrite keep, tech5; unfold tg_alt at 2; rewrite <- keep, pow_1_even. - fourier. + lra. rewrite nodd; destruct (alternated_series_ineq _ _ p' decr to0 cv) as [D E]. - unfold R_dist; rewrite <- Rabs_Ropp, Rabs_pos_eq;[ | fourier]. + unfold R_dist; rewrite <- Rabs_Ropp, Rabs_pos_eq;[ | lra]. rewrite Ropp_minus_distr. apply Rle_trans with (l - sum_f_R0 (tg_alt f) (S (2 * p))). unfold Rminus; apply Rplus_le_compat_l, Ropp_le_contravar, Rge_le, (growing_prop _ _ _ (CV_ALT_step0 f decr)); omega. generalize C; rewrite keep, tech5; unfold tg_alt. rewrite <- keep, pow_1_even. - assert (t : forall a b c, a <= b + 1 * c -> a - b <= c) by (intros; fourier). + assert (t : forall a b c, a <= b + 1 * c -> a - b <= c) by (intros; lra). solve[apply t]. clear WLOG; intros Hyp [ | n] decr to0 cv _. generalize (alternated_series_ineq f l 0 decr to0 cv). unfold R_dist, tg_alt; simpl; rewrite !Rmult_1_l, !Rmult_1_r. assert (f 1%nat <= f 0%nat) by apply decr. - intros [A B]; rewrite Rabs_pos_eq; fourier. + intros [A B]; rewrite Rabs_pos_eq; lra. apply Rle_trans with (f 1%nat). apply (Hyp 1%nat (le_n 1) (S n) decr to0 cv). omega. @@ -180,7 +180,7 @@ Lemma Alt_CVU : forall (f : nat -> R -> R) g h c r, CVU (fun N x => sum_f_R0 (tg_alt (fun i => f i x)) N) g c r. Proof. intros f g h c r decr to0 to_g bound bound0 eps ep. -assert (ep' : 0 <eps/2) by fourier. +assert (ep' : 0 <eps/2) by lra. destruct (bound0 _ ep) as [N Pn]; exists N. intros n y nN dy. rewrite <- Rabs_Ropp, Ropp_minus_distr; apply Rle_lt_trans with (f n y). @@ -201,14 +201,14 @@ intros x; destruct (Rle_lt_dec 0 x). replace (x ^ 2) with (x * x) by field. apply Rmult_le_pos; assumption. replace (x ^ 2) with ((-x) * (-x)) by field. -apply Rmult_le_pos; fourier. +apply Rmult_le_pos; lra. Qed. Lemma pow2_abs : forall x, Rabs x ^ 2 = x ^ 2. Proof. intros x; destruct (Rle_lt_dec 0 x). rewrite Rabs_pos_eq;[field | assumption]. -rewrite <- Rabs_Ropp, Rabs_pos_eq;[field | fourier]. +rewrite <- Rabs_Ropp, Rabs_pos_eq;[field | lra]. Qed. (** * Properties of tangent *) @@ -307,18 +307,18 @@ destruct (MVT_cor1 cos (PI/2) x derivable_cos xgtpi2) as [c [Pc [cint1 cint2]]]. revert Pc; rewrite cos_PI2, Rminus_0_r. rewrite <- (pr_nu cos c (derivable_pt_cos c)), derive_pt_cos. -assert (0 < c < 2) by (split; assert (t := PI2_RGT_0); fourier). +assert (0 < c < 2) by (split; assert (t := PI2_RGT_0); lra). assert (0 < sin c) by now apply sin_pos_tech. intros Pc. case (Rlt_not_le _ _ cx). rewrite <- (Rplus_0_l (cos x)), Pc, Ropp_mult_distr_l_reverse. -apply Rle_minus, Rmult_le_pos;[apply Rlt_le; assumption | fourier ]. +apply Rle_minus, Rmult_le_pos;[apply Rlt_le; assumption | lra ]. Qed. Lemma PI2_3_2 : 3/2 < PI/2. Proof. -apply PI2_lower_bound;[split; fourier | ]. -destruct (pre_cos_bound (3/2) 1) as [t _]; [fourier | fourier | ]. +apply PI2_lower_bound;[split; lra | ]. +destruct (pre_cos_bound (3/2) 1) as [t _]; [lra | lra | ]. apply Rlt_le_trans with (2 := t); clear t. unfold cos_approx; simpl; unfold cos_term. rewrite !INR_IZR_INZ. @@ -330,7 +330,7 @@ apply Rdiv_lt_0_compat ; now apply IZR_lt. Qed. Lemma PI2_1 : 1 < PI/2. -Proof. assert (t := PI2_3_2); fourier. Qed. +Proof. assert (t := PI2_3_2); lra. Qed. Lemma tan_increasing : forall x y:R, @@ -347,7 +347,7 @@ intros x y Z_le_x x_lt_y y_le_1. derivable_pt tan x). intros ; apply derivable_pt_tan ; intuition. apply derive_increasing_interv with (a:=-PI/2) (b:=PI/2) (pr:=local_derivable_pt_tan) ; intuition. - fourier. + lra. assert (Temp := pr_nu tan t (derivable_pt_tan t t_encad) (local_derivable_pt_tan t t_encad)) ; rewrite <- Temp ; clear Temp. assert (Temp := derive_pt_tan t t_encad) ; rewrite Temp ; clear Temp. @@ -414,49 +414,49 @@ Qed. (** * Definition of arctangent as the reciprocal function of tangent and proof of this status *) Lemma tan_1_gt_1 : tan 1 > 1. Proof. -assert (0 < cos 1) by (apply cos_gt_0; assert (t:=PI2_1); fourier). +assert (0 < cos 1) by (apply cos_gt_0; assert (t:=PI2_1); lra). assert (t1 : cos 1 <= 1 - 1/2 + 1/24). - destruct (pre_cos_bound 1 0) as [_ t]; try fourier; revert t. + destruct (pre_cos_bound 1 0) as [_ t]; try lra; revert t. unfold cos_approx, cos_term; simpl; intros t; apply Rle_trans with (1:=t). clear t; apply Req_le; field. assert (t2 : 1 - 1/6 <= sin 1). - destruct (pre_sin_bound 1 0) as [t _]; try fourier; revert t. + destruct (pre_sin_bound 1 0) as [t _]; try lra; revert t. unfold sin_approx, sin_term; simpl; intros t; apply Rle_trans with (2:=t). clear t; apply Req_le; field. pattern 1 at 2; replace 1 with - (cos 1 / cos 1) by (field; apply Rgt_not_eq; fourier). + (cos 1 / cos 1) by (field; apply Rgt_not_eq; lra). apply Rlt_gt; apply (Rmult_lt_compat_r (/ cos 1) (cos 1) (sin 1)). apply Rinv_0_lt_compat; assumption. apply Rle_lt_trans with (1 := t1); apply Rlt_le_trans with (2 := t2). -fourier. +lra. Qed. Definition frame_tan y : {x | 0 < x < PI/2 /\ Rabs y < tan x}. Proof. destruct (total_order_T (Rabs y) 1) as [Hs|Hgt]. - assert (yle1 : Rabs y <= 1) by (destruct Hs; fourier). + assert (yle1 : Rabs y <= 1) by (destruct Hs; lra). clear Hs; exists 1; split;[split; [exact Rlt_0_1 | exact PI2_1] | ]. apply Rle_lt_trans with (1 := yle1); exact tan_1_gt_1. assert (0 < / (Rabs y + 1)). - apply Rinv_0_lt_compat; fourier. + apply Rinv_0_lt_compat; lra. set (u := /2 * / (Rabs y + 1)). assert (0 < u). - apply Rmult_lt_0_compat; [fourier | assumption]. + apply Rmult_lt_0_compat; [lra | assumption]. assert (vlt1 : / (Rabs y + 1) < 1). apply Rmult_lt_reg_r with (Rabs y + 1). - assert (t := Rabs_pos y); fourier. - rewrite Rinv_l; [rewrite Rmult_1_l | apply Rgt_not_eq]; fourier. + assert (t := Rabs_pos y); lra. + rewrite Rinv_l; [rewrite Rmult_1_l | apply Rgt_not_eq]; lra. assert (vlt2 : u < 1). apply Rlt_trans with (/ (Rabs y + 1)). rewrite double_var. - assert (t : forall x, 0 < x -> x < x + x) by (clear; intros; fourier). + assert (t : forall x, 0 < x -> x < x + x) by (clear; intros; lra). unfold u; rewrite Rmult_comm; apply t. unfold Rdiv; rewrite Rmult_comm; assumption. assumption. assert(int : 0 < PI / 2 - u < PI / 2). split. assert (t := PI2_1); apply Rlt_Rminus, Rlt_trans with (2 := t); assumption. - assert (dumb : forall x y, 0 < y -> x - y < x) by (clear; intros; fourier). + assert (dumb : forall x y, 0 < y -> x - y < x) by (clear; intros; lra). apply dumb; clear dumb; assumption. exists (PI/2 - u). assert (tmp : forall x y, 0 < x -> y < 1 -> x * y < x). @@ -473,7 +473,7 @@ split. assert (sin u < u). assert (t1 : 0 <= u) by (apply Rlt_le; assumption). assert (t2 : u <= 4) by - (apply Rle_trans with 1;[apply Rlt_le | fourier]; assumption). + (apply Rle_trans with 1;[apply Rlt_le | lra]; assumption). destruct (pre_sin_bound u 0 t1 t2) as [_ t]. apply Rle_lt_trans with (1 := t); clear t1 t2 t. unfold sin_approx; simpl; unfold sin_term; simpl ((-1) ^ 0); @@ -503,17 +503,17 @@ split. solve[apply Rinv_0_lt_compat, INR_fact_lt_0]. apply Rlt_trans with (2 := vlt2). simpl; unfold u; apply tmp; auto; rewrite Rmult_1_r; assumption. - apply Rlt_trans with (Rabs y + 1);[fourier | ]. + apply Rlt_trans with (Rabs y + 1);[lra | ]. pattern (Rabs y + 1) at 1; rewrite <- (Rinv_involutive (Rabs y + 1)); - [ | apply Rgt_not_eq; fourier]. + [ | apply Rgt_not_eq; lra]. rewrite <- Rinv_mult_distr. apply Rinv_lt_contravar. apply Rmult_lt_0_compat. - apply Rmult_lt_0_compat;[fourier | assumption]. + apply Rmult_lt_0_compat;[lra | assumption]. assumption. replace (/(Rabs y + 1)) with (2 * u). - fourier. - unfold u; field; apply Rgt_not_eq; clear -Hgt; fourier. + lra. + unfold u; field; apply Rgt_not_eq; clear -Hgt; lra. solve[discrR]. apply Rgt_not_eq; assumption. unfold tan. @@ -522,22 +522,22 @@ set (u' := PI / 2); unfold Rdiv; apply Rmult_lt_compat_r; unfold u'. rewrite cos_shift; assumption. assert (vlt3 : u < /4). replace (/4) with (/2 * /2) by field. - unfold u; apply Rmult_lt_compat_l;[fourier | ]. + unfold u; apply Rmult_lt_compat_l;[lra | ]. apply Rinv_lt_contravar. - apply Rmult_lt_0_compat; fourier. - fourier. -assert (1 < PI / 2 - u) by (assert (t := PI2_3_2); fourier). + apply Rmult_lt_0_compat; lra. + lra. +assert (1 < PI / 2 - u) by (assert (t := PI2_3_2); lra). apply Rlt_trans with (sin 1). - assert (t' : 1 <= 4) by fourier. + assert (t' : 1 <= 4) by lra. destruct (pre_sin_bound 1 0 (Rlt_le _ _ Rlt_0_1) t') as [t _]. apply Rlt_le_trans with (2 := t); clear t. - simpl plus; replace (sin_approx 1 1) with (5/6);[fourier | ]. + simpl plus; replace (sin_approx 1 1) with (5/6);[lra | ]. unfold sin_approx, sin_term; simpl; field. apply sin_increasing_1. - assert (t := PI2_1); fourier. + assert (t := PI2_1); lra. apply Rlt_le, PI2_1. - assert (t := PI2_1); fourier. - fourier. + assert (t := PI2_1); lra. + lra. assumption. Qed. @@ -547,7 +547,7 @@ intros x h; rewrite Ropp_div; apply Ropp_lt_contravar; assumption. Qed. Lemma pos_opp_lt : forall x, 0 < x -> -x < x. -Proof. intros; fourier. Qed. +Proof. intros; lra. Qed. Lemma tech_opp_tan : forall x y, -tan x < y -> tan (-x) < y. Proof. @@ -562,7 +562,7 @@ set (pr := (conj (tech_opp_tan _ _ (proj2 (Rabs_def2 _ _ Ptan_ub))) destruct (exists_atan_in_frame (-ub) ub y (pos_opp_lt _ ub0) (ub_opp _ ubpi2) ubpi2 pr) as [v [[vl vu] vq]]. exists v; clear pr. -split;[rewrite Ropp_div; split; fourier | assumption]. +split;[rewrite Ropp_div; split; lra | assumption]. Qed. Definition atan x := let (v, _) := pre_atan x in v. @@ -581,7 +581,7 @@ Lemma atan_opp : forall x, atan (- x) = - atan x. Proof. intros x; generalize (atan_bound (-x)); rewrite Ropp_div;intros [a b]. generalize (atan_bound x); rewrite Ropp_div; intros [c d]. -apply tan_is_inj; try rewrite Ropp_div; try split; try fourier. +apply tan_is_inj; try rewrite Ropp_div; try split; try lra. rewrite tan_neg, !atan_right_inv; reflexivity. Qed. @@ -604,23 +604,23 @@ assert (int_tan : forall y, tan (- ub) <= y -> y <= tan ub -> rewrite <- (atan_right_inv y); apply tan_increasing. destruct (atan_bound y); assumption. assumption. - fourier. - fourier. + lra. + lra. destruct (Rle_lt_dec (atan y) ub) as [h | abs]; auto. assert (tan ub < y). rewrite <- (atan_right_inv y); apply tan_increasing. - rewrite Ropp_div; fourier. + rewrite Ropp_div; lra. assumption. destruct (atan_bound y); assumption. - fourier. + lra. assert (incr : forall x y, -ub <= x -> x < y -> y <= ub -> tan x < tan y). intros y z l yz u; apply tan_increasing. - rewrite Ropp_div; fourier. + rewrite Ropp_div; lra. assumption. - fourier. + lra. assert (der : forall a, -ub <= a <= ub -> derivable_pt tan a). intros a [la ua]; apply derivable_pt_tan. - rewrite Ropp_div; split; fourier. + rewrite Ropp_div; split; lra. assert (df_neq : derive_pt tan (atan x) (derivable_pt_recip_interv_prelim1 tan atan (- ub) ub x lb_lt_ub xint inv_p int_tan incr der) <> 0). @@ -651,7 +651,7 @@ Qed. Lemma atan_0 : atan 0 = 0. Proof. apply tan_is_inj; try (apply atan_bound). - assert (t := PI_RGT_0); rewrite Ropp_div; split; fourier. + assert (t := PI_RGT_0); rewrite Ropp_div; split; lra. rewrite atan_right_inv, tan_0. reflexivity. Qed. @@ -659,7 +659,7 @@ Qed. Lemma atan_1 : atan 1 = PI/4. Proof. assert (ut := PI_RGT_0). -assert (-PI/2 < PI/4 < PI/2) by (rewrite Ropp_div; split; fourier). +assert (-PI/2 < PI/4 < PI/2) by (rewrite Ropp_div; split; lra). assert (t := atan_bound 1). apply tan_is_inj; auto. rewrite tan_PI4, atan_right_inv; reflexivity. @@ -688,23 +688,23 @@ assert (int_tan : forall y, tan (- ub) <= y -> y <= tan ub -> rewrite <- (atan_right_inv y); apply tan_increasing. destruct (atan_bound y); assumption. assumption. - fourier. - fourier. + lra. + lra. destruct (Rle_lt_dec (atan y) ub) as [h | abs]; auto. assert (tan ub < y). rewrite <- (atan_right_inv y); apply tan_increasing. - rewrite Ropp_div; fourier. + rewrite Ropp_div; lra. assumption. destruct (atan_bound y); assumption. - fourier. + lra. assert (incr : forall x y, -ub <= x -> x < y -> y <= ub -> tan x < tan y). intros y z l yz u; apply tan_increasing. - rewrite Ropp_div; fourier. + rewrite Ropp_div; lra. assumption. - fourier. + lra. assert (der : forall a, -ub <= a <= ub -> derivable_pt tan a). intros a [la ua]; apply derivable_pt_tan. - rewrite Ropp_div; split; fourier. + rewrite Ropp_div; split; lra. assert (df_neq : derive_pt tan (atan x) (derivable_pt_recip_interv_prelim1 tan atan (- ub) ub x lb_lt_ub xint inv_p int_tan incr der) <> 0). @@ -883,7 +883,7 @@ Proof. destruct (Rle_lt_dec 0 x). assert (pr : 0 <= x <= 1) by tauto. exact (ps_atan_exists_01 x pr). -assert (pr : 0 <= -x <= 1) by (destruct Hx; split; fourier). +assert (pr : 0 <= -x <= 1) by (destruct Hx; split; lra). destruct (ps_atan_exists_01 _ pr) as [v Pv]. exists (-v). apply (Un_cv_ext (fun n => (- 1) * sum_f_R0 (tg_alt (Ratan_seq (- x))) n)). @@ -898,8 +898,8 @@ Proof. destruct (Rle_lt_dec x 1). destruct (Rle_lt_dec (-1) x). left;split; auto. - right;intros [a1 a2]; fourier. -right;intros [a1 a2]; fourier. + right;intros [a1 a2]; lra. +right;intros [a1 a2]; lra. Qed. Definition ps_atan (x : R) : R := @@ -922,7 +922,7 @@ unfold ps_atan. unfold Rdiv; rewrite !Rmult_0_l, Rmult_0_r; reflexivity. intros eps ep; exists 0%nat; intros n _; unfold R_dist. rewrite Rminus_0_r, Rabs_pos_eq; auto with real. -case h2; split; fourier. +case h2; split; lra. Qed. Lemma ps_atan_exists_1_opp : @@ -948,9 +948,9 @@ destruct (in_int (- x)) as [inside | outside]. destruct (in_int x) as [ins' | outs']. generalize (ps_atan_exists_1_opp x inside ins'). intros h; exact h. - destruct inside; case outs'; split; fourier. + destruct inside; case outs'; split; lra. destruct (in_int x) as [ins' | outs']. - destruct outside; case ins'; split; fourier. + destruct outside; case ins'; split; lra. apply atan_opp. Qed. @@ -1057,7 +1057,7 @@ Proof. intros x n. assert (dif : - x ^ 2 <> 1). apply Rlt_not_eq; apply Rle_lt_trans with 0;[ | apply Rlt_0_1]. -assert (t := pow2_ge_0 x); fourier. +assert (t := pow2_ge_0 x); lra. replace (1 + x ^ 2) with (1 - - (x ^ 2)) by ring; rewrite <- (tech3 _ n dif). apply sum_eq; unfold tg_alt, Datan_seq; intros i _. rewrite pow_mult, <- Rpow_mult_distr. @@ -1073,7 +1073,7 @@ intros x y n n_lb x_encad ; assert (x_pos : x >= 0) by intuition. apply False_ind ; intuition. clear -x_encad x_pos y_pos ; induction n ; unfold Datan_seq. case x_pos ; clear x_pos ; intro x_pos. - simpl ; apply Rmult_gt_0_lt_compat ; intuition. fourier. + simpl ; apply Rmult_gt_0_lt_compat ; intuition. lra. rewrite x_pos ; rewrite pow_i. replace (y ^ (2*1)) with (y*y). apply Rmult_gt_0_compat ; assumption. simpl ; field. @@ -1084,7 +1084,7 @@ intros x y n n_lb x_encad ; assert (x_pos : x >= 0) by intuition. case x_pos ; clear x_pos ; intro x_pos. rewrite Hrew ; rewrite Hrew. apply Rmult_gt_0_lt_compat ; intuition. - apply Rmult_gt_0_lt_compat ; intuition ; fourier. + apply Rmult_gt_0_lt_compat ; intuition ; lra. rewrite x_pos. rewrite pow_i ; intuition. Qed. @@ -1141,7 +1141,7 @@ elim (pow_lt_1_zero _ x_ub2 _ eps'_pos) ; intros N HN ; exists N. intros n Hn. assert (H1 : - x^2 <> 1). apply Rlt_not_eq; apply Rle_lt_trans with (2 := Rlt_0_1). -assert (t := pow2_ge_0 x); fourier. +assert (t := pow2_ge_0 x); lra. rewrite Datan_sum_eq. unfold R_dist. assert (tool : forall a b, a / b - /b = (-1 + a) /b). @@ -1179,13 +1179,13 @@ apply (Alt_CVU (fun x n => Datan_seq n x) (Datan_seq (Rabs c + r)) c r). intros x inb; apply Datan_seq_decreasing; try (apply Boule_lt in inb; apply Rabs_def2 in inb; - destruct inb; fourier). + destruct inb; lra). intros x inb; apply Datan_seq_CV_0; try (apply Boule_lt in inb; apply Rabs_def2 in inb; - destruct inb; fourier). + destruct inb; lra). intros x inb; apply (Datan_lim x); try (apply Boule_lt in inb; apply Rabs_def2 in inb; - destruct inb; fourier). + destruct inb; lra). intros x [ | n] inb. solve[unfold Datan_seq; apply Rle_refl]. rewrite <- (Datan_seq_Rabs x); apply Rlt_le, Datan_seq_increasing. @@ -1193,7 +1193,7 @@ apply (Alt_CVU (fun x n => Datan_seq n x) apply Boule_lt in inb; intuition. solve[apply Rabs_pos]. apply Datan_seq_CV_0. - apply Rlt_trans with 0;[fourier | ]. + apply Rlt_trans with 0;[lra | ]. apply Rplus_le_lt_0_compat. solve[apply Rabs_pos]. destruct r; assumption. @@ -1226,7 +1226,7 @@ intros N x x_lb x_ub. apply Hdelta ; assumption. unfold id ; field ; assumption. intros eps eps_pos. - assert (eps_3_pos : (eps/3) > 0) by fourier. + assert (eps_3_pos : (eps/3) > 0) by lra. elim (IHN (eps/3) eps_3_pos) ; intros delta1 Hdelta1. assert (Main : derivable_pt_lim (fun x : R =>tg_alt (Ratan_seq x) (S N)) x ((tg_alt (Datan_seq x)) (S N))). clear -Tool ; intros eps' eps'_pos. @@ -1297,7 +1297,7 @@ intros N x x_lb x_ub. intuition ; apply Rlt_le_trans with (r2:=delta) ; intuition unfold delta, mydelta. apply Rmin_l. apply Rmin_r. - fourier. + lra. Qed. Lemma Ratan_CVU' : @@ -1310,7 +1310,7 @@ apply (Alt_CVU (fun i r => Ratan_seq r i) ps_atan PI_tg (/2) pos_half); now intros; apply Ratan_seq_converging, Boule_half_to_interval. intros x b; apply Boule_half_to_interval in b. unfold ps_atan; destruct (in_int x) as [inside | outside]; - [ | destruct b; case outside; split; fourier]. + [ | destruct b; case outside; split; lra]. destruct (ps_atan_exists_1 x inside) as [v Pv]. apply Un_cv_ext with (2 := Pv);[reflexivity]. intros x n b; apply Boule_half_to_interval in b. @@ -1330,7 +1330,7 @@ exists N; intros n x nN b_y. case (Rtotal_order 0 x) as [xgt0 | [x0 | x0]]. assert (Boule (/2) {| pos := / 2; cond_pos := pos_half_prf|} x). revert b_y; unfold Boule; simpl; intros b_y; apply Rabs_def2 in b_y. - destruct b_y; unfold Boule; simpl; apply Rabs_def1; fourier. + destruct b_y; unfold Boule; simpl; apply Rabs_def1; lra. apply Pn; assumption. rewrite <- x0, ps_atan0_0. rewrite <- (sum_eq (fun _ => 0)), sum_cte, Rmult_0_l, Rminus_0_r, Rabs_pos_eq. @@ -1343,7 +1343,7 @@ replace (ps_atan x - sum_f_R0 (tg_alt (Ratan_seq x)) n) with rewrite Rabs_Ropp. assert (Boule (/2) {| pos := / 2; cond_pos := pos_half_prf|} (-x)). revert b_y; unfold Boule; simpl; intros b_y; apply Rabs_def2 in b_y. - destruct b_y; unfold Boule; simpl; apply Rabs_def1; fourier. + destruct b_y; unfold Boule; simpl; apply Rabs_def1; lra. apply Pn; assumption. unfold Rminus; rewrite ps_atan_opp, Ropp_plus_distr, sum_Ratan_seq_opp. rewrite !Ropp_involutive; reflexivity. @@ -1372,7 +1372,7 @@ apply continuity_inv. apply continuity_plus. apply continuity_const ; unfold constant ; intuition. apply derivable_continuous ; apply derivable_pow. -intro x ; apply Rgt_not_eq ; apply Rge_gt_trans with (1+0) ; [|fourier] ; +intro x ; apply Rgt_not_eq ; apply Rge_gt_trans with (1+0) ; [|lra] ; apply Rplus_ge_compat_l. replace (x^2) with (x²). apply Rle_ge ; apply Rle_0_sqr. @@ -1393,11 +1393,11 @@ apply derivable_pt_lim_CVU with assumption. intros y N inb; apply Rabs_def2 in inb; destruct inb. apply Datan_is_datan. - fourier. - fourier. + lra. + lra. intros y inb; apply Rabs_def2 in inb; destruct inb. - assert (y_gt_0 : -1 < y) by fourier. - assert (y_lt_1 : y < 1) by fourier. + assert (y_gt_0 : -1 < y) by lra. + assert (y_lt_1 : y < 1) by lra. intros eps eps_pos ; elim (Ratan_is_ps_atan eps eps_pos). intros N HN ; exists N; intros n n_lb ; apply HN ; tauto. apply Datan_CVU_prelim. @@ -1406,8 +1406,8 @@ apply derivable_pt_lim_CVU with replace ((c + r - (c - r)) / 2) with (r :R) by field. assert (Rabs c < 1 - r). unfold Boule in Pcr1; destruct r; simpl in *; apply Rabs_def1; - apply Rabs_def2 in Pcr1; destruct Pcr1; fourier. - fourier. + apply Rabs_def2 in Pcr1; destruct Pcr1; lra. + lra. intros; apply Datan_continuity. Qed. @@ -1426,7 +1426,7 @@ Lemma ps_atan_continuity_pt_1 : forall eps : R, dist R_met (ps_atan x) (Alt_PI/4) < eps). Proof. intros eps eps_pos. -assert (eps_3_pos : eps / 3 > 0) by fourier. +assert (eps_3_pos : eps / 3 > 0) by lra. elim (Ratan_is_ps_atan (eps / 3) eps_3_pos) ; intros N1 HN1. unfold Alt_PI. destruct exist_PI as [v Pv]; replace ((4 * v)/4) with v by field. @@ -1461,10 +1461,10 @@ rewrite Rplus_assoc ; apply Rabs_triang. unfold D_x, no_cond ; split ; [ | apply Rgt_not_eq ] ; intuition. intuition. apply HN2; unfold N; omega. - fourier. + lra. rewrite <- Rabs_Ropp, Ropp_minus_distr; apply HN1. unfold N; omega. - fourier. + lra. assumption. field. ring. @@ -1486,11 +1486,11 @@ intros x x_encad Pratan Prmymeta. rewrite Hrew1. replace (Rsqr x) with (x ^ 2) by (unfold Rsqr; ring). unfold Rdiv; rewrite Rmult_1_l; reflexivity. - fourier. + lra. assumption. intros; reflexivity. - fourier. - assert (t := tan_1_gt_1); split;destruct x_encad; fourier. + lra. + assert (t := tan_1_gt_1); split;destruct x_encad; lra. intros; reflexivity. Qed. @@ -1503,46 +1503,46 @@ assert (pr1 : forall c : R, 0 < c < x -> derivable_pt (atan - ps_atan) c). apply derivable_pt_minus. exact (derivable_pt_atan c). apply derivable_pt_ps_atan. - destruct x_encad; destruct c_encad; split; fourier. + destruct x_encad; destruct c_encad; split; lra. assert (pr2 : forall c : R, 0 < c < x -> derivable_pt id c). - intros ; apply derivable_pt_id; fourier. + intros ; apply derivable_pt_id; lra. assert (delta_cont : forall c : R, 0 <= c <= x -> continuity_pt (atan - ps_atan) c). intros c [[c_encad1 | c_encad1 ] [c_encad2 | c_encad2]]; apply continuity_pt_minus. apply derivable_continuous_pt ; apply derivable_pt_atan. apply derivable_continuous_pt ; apply derivable_pt_ps_atan. - split; destruct x_encad; fourier. + split; destruct x_encad; lra. apply derivable_continuous_pt, derivable_pt_atan. apply derivable_continuous_pt, derivable_pt_ps_atan. - subst c; destruct x_encad; split; fourier. + subst c; destruct x_encad; split; lra. apply derivable_continuous_pt, derivable_pt_atan. apply derivable_continuous_pt, derivable_pt_ps_atan. - subst c; split; fourier. + subst c; split; lra. apply derivable_continuous_pt, derivable_pt_atan. apply derivable_continuous_pt, derivable_pt_ps_atan. - subst c; destruct x_encad; split; fourier. + subst c; destruct x_encad; split; lra. assert (id_cont : forall c : R, 0 <= c <= x -> continuity_pt id c). intros ; apply derivable_continuous ; apply derivable_id. -assert (x_lb : 0 < x) by (destruct x_encad; fourier). +assert (x_lb : 0 < x) by (destruct x_encad; lra). elim (MVT (atan - ps_atan)%F id 0 x pr1 pr2 x_lb delta_cont id_cont) ; intros d Temp ; elim Temp ; intros d_encad Main. clear - Main x_encad. assert (Temp : forall (pr: derivable_pt (atan - ps_atan) d), derive_pt (atan - ps_atan) d pr = 0). intro pr. assert (d_encad3 : -1 < d < 1). - destruct d_encad; destruct x_encad; split; fourier. + destruct d_encad; destruct x_encad; split; lra. pose (pr3 := derivable_pt_minus atan ps_atan d (derivable_pt_atan d) (derivable_pt_ps_atan d d_encad3)). rewrite <- pr_nu_var2_interv with (f:=(atan - ps_atan)%F) (g:=(atan - ps_atan)%F) (lb:=0) (ub:=x) (pr1:=pr3) (pr2:=pr). unfold pr3. rewrite derive_pt_minus. rewrite Datan_eq_DatanSeq_interv with (Prmymeta := derivable_pt_atan d). intuition. assumption. - destruct d_encad; fourier. + destruct d_encad; lra. assumption. reflexivity. assert (iatan0 : atan 0 = 0). apply tan_is_inj. apply atan_bound. - rewrite Ropp_div; assert (t := PI2_RGT_0); split; fourier. + rewrite Ropp_div; assert (t := PI2_RGT_0); split; lra. rewrite tan_0, atan_right_inv; reflexivity. generalize Main; rewrite Temp, Rmult_0_r. replace ((atan - ps_atan)%F x) with (atan x - ps_atan x) by intuition. @@ -1560,19 +1560,19 @@ Qed. Theorem Alt_PI_eq : Alt_PI = PI. Proof. apply Rmult_eq_reg_r with (/4); fold (Alt_PI/4); fold (PI/4); - [ | apply Rgt_not_eq; fourier]. + [ | apply Rgt_not_eq; lra]. assert (0 < PI/6) by (apply PI6_RGT_0). assert (t1:= PI2_1). assert (t2 := PI_4). assert (m := Alt_PI_RGT_0). -assert (-PI/2 < 1 < PI/2) by (rewrite Ropp_div; split; fourier). +assert (-PI/2 < 1 < PI/2) by (rewrite Ropp_div; split; lra). apply cond_eq; intros eps ep. change (R_dist (Alt_PI/4) (PI/4) < eps). assert (ca : continuity_pt atan 1). apply derivable_continuous_pt, derivable_pt_atan. assert (Xe : exists eps', exists eps'', eps' + eps'' <= eps /\ 0 < eps' /\ 0 < eps''). - exists (eps/2); exists (eps/2); repeat apply conj; fourier. + exists (eps/2); exists (eps/2); repeat apply conj; lra. destruct Xe as [eps' [eps'' [eps_ineq [ep' ep'']]]]. destruct (ps_atan_continuity_pt_1 _ ep') as [alpha [a0 Palpha]]. destruct (ca _ ep'') as [beta [b0 Pbeta]]. @@ -1585,14 +1585,14 @@ assert (Xa : exists a, 0 < a < 1 /\ R_dist a 1 < alpha /\ assert ((1 - alpha /2) <= Rmax (1 - alpha /2) (1 - beta /2)) by apply Rmax_l. assert ((1 - beta /2) <= Rmax (1 - alpha /2) (1 - beta /2)) by apply Rmax_r. assert (Rmax (1 - alpha /2) (1 - beta /2) < 1) - by (apply Rmax_lub_lt; fourier). - split;[split;[ | apply Rmax_lub_lt]; fourier | ]. + by (apply Rmax_lub_lt; lra). + split;[split;[ | apply Rmax_lub_lt]; lra | ]. assert (0 <= 1 - Rmax (/ 2) (Rmax (1 - alpha / 2) (1 - beta / 2))). assert (Rmax (/2) (Rmax (1 - alpha / 2) - (1 - beta /2)) <= 1) by (apply Rmax_lub; fourier). - fourier. + (1 - beta /2)) <= 1) by (apply Rmax_lub; lra). + lra. split; unfold R_dist; rewrite <-Rabs_Ropp, Ropp_minus_distr, - Rabs_pos_eq;fourier. + Rabs_pos_eq;lra. destruct Xa as [a [[Pa0 Pa1] [P1 P2]]]. apply Rle_lt_trans with (1 := R_dist_tri _ _ (ps_atan a)). apply Rlt_le_trans with (2 := eps_ineq). diff --git a/theories/Reals/Rbasic_fun.v b/theories/Reals/Rbasic_fun.v index aa886cee03..59e0148625 100644 --- a/theories/Reals/Rbasic_fun.v +++ b/theories/Reals/Rbasic_fun.v @@ -15,7 +15,7 @@ Require Import Rbase. Require Import R_Ifp. -Require Import Fourier. +Require Import Lra. Local Open Scope R_scope. Implicit Type r : R. @@ -357,7 +357,7 @@ Qed. Lemma Rle_abs : forall x:R, x <= Rabs x. Proof. - intro; unfold Rabs; case (Rcase_abs x); intros; fourier. + intro; unfold Rabs; case (Rcase_abs x); intros; lra. Qed. Definition RRle_abs := Rle_abs. diff --git a/theories/Reals/Rderiv.v b/theories/Reals/Rderiv.v index dfa5c7104c..aaf691ed1a 100644 --- a/theories/Reals/Rderiv.v +++ b/theories/Reals/Rderiv.v @@ -16,7 +16,7 @@ Require Import Rbase. Require Import Rfunctions. Require Import Rlimit. -Require Import Fourier. +Require Import Lra. Require Import Omega. Local Open Scope R_scope. @@ -77,7 +77,7 @@ Proof. elim (Rmin_Rgt (/ 2) x 0); intros a b; cut (0 < 2). intro; generalize (Rinv_0_lt_compat 2 H3); intro; fold (/ 2 > 0) in H4; apply (b (conj H4 H)). - fourier. + lra. intros; elim H3; clear H3; intros; generalize (let (H1, H2) := @@ -167,7 +167,7 @@ Proof. unfold Rabs; destruct (Rcase_abs 2) as [Hlt|Hge]; auto. cut (0 < 2). intro H7; elim (Rlt_asym 0 2 H7 Hlt). - fourier. + lra. apply Rabs_no_R0. discrR. Qed. diff --git a/theories/Reals/Reals.v b/theories/Reals/Reals.v index b249b519f5..3ef368bb4f 100644 --- a/theories/Reals/Reals.v +++ b/theories/Reals/Reals.v @@ -30,3 +30,4 @@ Require Export SeqSeries. Require Export Rtrigo. Require Export Ranalysis. Require Export Integration. +Require Import Fourier. diff --git a/theories/Reals/Rlimit.v b/theories/Reals/Rlimit.v index b14fcc4d36..e3e995d201 100644 --- a/theories/Reals/Rlimit.v +++ b/theories/Reals/Rlimit.v @@ -15,7 +15,7 @@ Require Import Rbase. Require Import Rfunctions. -Require Import Fourier. +Require Import Lra. Local Open Scope R_scope. (*******************************) @@ -24,7 +24,7 @@ Local Open Scope R_scope. (*********) Lemma eps2_Rgt_R0 : forall eps:R, eps > 0 -> eps * / 2 > 0. Proof. - intros; fourier. + intros; lra. Qed. (*********) @@ -45,14 +45,14 @@ Qed. Lemma Rlt_eps2_eps : forall eps:R, eps > 0 -> eps * / 2 < eps. Proof. intros. - fourier. + lra. Qed. (*********) Lemma Rlt_eps4_eps : forall eps:R, eps > 0 -> eps * / (2 + 2) < eps. Proof. intros. - fourier. + lra. Qed. (*********) diff --git a/theories/Reals/Rpower.v b/theories/Reals/Rpower.v index c6fac951b6..d465523a70 100644 --- a/theories/Reals/Rpower.v +++ b/theories/Reals/Rpower.v @@ -25,7 +25,7 @@ Require Import R_sqrt. Require Import Sqrt_reg. Require Import MVT. Require Import Ranalysis4. -Require Import Fourier. +Require Import Lra. Local Open Scope R_scope. Lemma P_Rmin : forall (P:R -> Prop) (x y:R), P x -> P y -> P (Rmin x y). @@ -714,7 +714,7 @@ Qed. Lemma Rlt_Rpower_l a b c: 0 < c -> 0 < a < b -> a ^R c < b ^R c. Proof. intros c0 [a0 ab]; apply exp_increasing. -now apply Rmult_lt_compat_l; auto; apply ln_increasing; fourier. +now apply Rmult_lt_compat_l; auto; apply ln_increasing; lra. Qed. Lemma Rle_Rpower_l a b c: 0 <= c -> 0 < a <= b -> a ^R c <= b ^R c. @@ -722,7 +722,7 @@ Proof. intros [c0 | c0]; [ | intros; rewrite <- c0, !Rpower_O; [apply Rle_refl | |] ]. intros [a0 [ab|ab]]. - now apply Rlt_le, Rlt_Rpower_l;[ | split]; fourier. + now apply Rlt_le, Rlt_Rpower_l;[ | split]; lra. rewrite ab; apply Rle_refl. apply Rlt_le_trans with a; tauto. tauto. @@ -754,10 +754,10 @@ assert (cmp : 0 < x + sqrt (x ^ 2 + 1)). replace (x ^ 2) with ((-x) ^ 2) by ring. assert (sqrt ((- x) ^ 2) < sqrt ((-x)^2+1)). apply sqrt_lt_1_alt. - split;[apply pow_le | ]; fourier. + split;[apply pow_le | ]; lra. pattern x at 1; replace x with (- (sqrt ((- x) ^ 2))). - assert (t:= sqrt_pos ((-x)^2)); fourier. - simpl; rewrite Rmult_1_r, sqrt_square, Ropp_involutive;[reflexivity | fourier]. + assert (t:= sqrt_pos ((-x)^2)); lra. + simpl; rewrite Rmult_1_r, sqrt_square, Ropp_involutive;[reflexivity | lra]. apply Rplus_lt_le_0_compat;[apply Rnot_le_gt; assumption | apply sqrt_pos]. rewrite exp_ln;[ | assumption]. rewrite exp_Ropp, exp_ln;[ | assumption]. @@ -770,7 +770,7 @@ apply Rmult_eq_reg_l with (2 * (x + sqrt (x ^ 2 + 1)));[ | apply Rgt_not_eq, Rmult_lt_0_compat;[apply Rlt_0_2 | assumption]]. assert (pow2_sqrt : forall x, 0 <= x -> sqrt x ^ 2 = x) by (intros; simpl; rewrite Rmult_1_r, sqrt_sqrt; auto). -field_simplify;[rewrite pow2_sqrt;[field | ] | apply Rgt_not_eq; fourier]. +field_simplify;[rewrite pow2_sqrt;[field | ] | apply Rgt_not_eq; lra]. apply Rplus_le_le_0_compat;[simpl; rewrite Rmult_1_r; apply (Rle_0_sqr x)|apply Rlt_le, Rlt_0_1]. Qed. @@ -784,12 +784,12 @@ assert (0 < x + sqrt (x ^ 2 + 1)). replace (x ^ 2) with ((-x) ^ 2) by ring. assert (sqrt ((- x) ^ 2) < sqrt ((-x)^2+1)). apply sqrt_lt_1_alt. - split;[apply pow_le|]; fourier. + split;[apply pow_le|]; lra. pattern x at 1; replace x with (- (sqrt ((- x) ^ 2))). - assert (t:= sqrt_pos ((-x)^2)); fourier. - simpl; rewrite Rmult_1_r, sqrt_square, Ropp_involutive; auto; fourier. + assert (t:= sqrt_pos ((-x)^2)); lra. + simpl; rewrite Rmult_1_r, sqrt_square, Ropp_involutive; auto; lra. assert (0 < x ^ 2 + 1). - apply Rplus_le_lt_0_compat;[simpl; rewrite Rmult_1_r; apply Rle_0_sqr|fourier]. + apply Rplus_le_lt_0_compat;[simpl; rewrite Rmult_1_r; apply Rle_0_sqr|lra]. replace (/sqrt (x ^ 2 + 1)) with (/(x + sqrt (x ^ 2 + 1)) * (1 + (/(2 * sqrt (x ^ 2 + 1)) * (INR 2 * x ^ 1 + 0)))). @@ -817,7 +817,7 @@ intros x y xy. case (Rle_dec (arcsinh y) (arcsinh x));[ | apply Rnot_le_lt ]. intros abs; case (Rlt_not_le _ _ xy). rewrite <- (sinh_arcsinh y), <- (sinh_arcsinh x). -destruct abs as [lt | q];[| rewrite q; fourier]. +destruct abs as [lt | q];[| rewrite q; lra]. apply Rlt_le, sinh_lt; assumption. Qed. diff --git a/theories/Reals/Rtrigo.v b/theories/Reals/Rtrigo.v index ffc0adf509..ddd8722e1e 100644 --- a/theories/Reals/Rtrigo.v +++ b/theories/Reals/Rtrigo.v @@ -18,7 +18,7 @@ Require Export Cos_rel. Require Export Cos_plus. Require Import ZArith_base. Require Import Zcomplements. -Require Import Fourier. +Require Import Lra. Require Import Ranalysis1. Require Import Rsqrt_def. Require Import PSeries_reg. diff --git a/theories/Reals/Rtrigo1.v b/theories/Reals/Rtrigo1.v index bf00f736f7..a75fd2ddeb 100644 --- a/theories/Reals/Rtrigo1.v +++ b/theories/Reals/Rtrigo1.v @@ -18,7 +18,7 @@ Require Export Cos_rel. Require Export Cos_plus. Require Import ZArith_base. Require Import Zcomplements. -Require Import Fourier. +Require Import Lra. Require Import Ranalysis1. Require Import Rsqrt_def. Require Import PSeries_reg. @@ -175,10 +175,10 @@ Qed. Lemma sin_gt_cos_7_8 : sin (7 / 8) > cos (7 / 8). Proof. -assert (lo1 : 0 <= 7/8) by fourier. -assert (up1 : 7/8 <= 4) by fourier. -assert (lo : -2 <= 7/8) by fourier. -assert (up : 7/8 <= 2) by fourier. +assert (lo1 : 0 <= 7/8) by lra. +assert (up1 : 7/8 <= 4) by lra. +assert (lo : -2 <= 7/8) by lra. +assert (up : 7/8 <= 2) by lra. destruct (pre_sin_bound _ 0 lo1 up1) as [lower _ ]. destruct (pre_cos_bound _ 0 lo up) as [_ upper]. apply Rle_lt_trans with (1 := upper). @@ -205,12 +205,12 @@ Definition PI_2_aux : {z | 7/8 <= z <= 7/4 /\ -cos z = 0}. assert (cc : continuity (fun r =>- cos r)). apply continuity_opp, continuity_cos. assert (cvp : 0 < cos (7/8)). - assert (int78 : -2 <= 7/8 <= 2) by (split; fourier). + assert (int78 : -2 <= 7/8 <= 2) by (split; lra). destruct int78 as [lower upper]. case (pre_cos_bound _ 0 lower upper). unfold cos_approx; simpl sum_f_R0; unfold cos_term. intros cl _; apply Rlt_le_trans with (2 := cl); simpl. - fourier. + lra. assert (cun : cos (7/4) < 0). replace (7/4) with (7/8 + 7/8) by field. rewrite cos_plus. @@ -218,7 +218,7 @@ assert (cun : cos (7/4) < 0). exact sin_gt_cos_7_8. apply Rlt_le; assumption. apply Rlt_le; apply Rlt_trans with (1 := cvp); exact sin_gt_cos_7_8. -apply IVT; auto; fourier. +apply IVT; auto; lra. Qed. Definition PI2 := proj1_sig PI_2_aux. @@ -270,7 +270,7 @@ Qed. Lemma sin_pos_tech : forall x, 0 < x < 2 -> 0 < sin x. intros x [int1 int2]. assert (lo : 0 <= x) by (apply Rlt_le; assumption). -assert (up : x <= 4) by (apply Rlt_le, Rlt_trans with (1:=int2); fourier). +assert (up : x <= 4) by (apply Rlt_le, Rlt_trans with (1:=int2); lra). destruct (pre_sin_bound _ 0 lo up) as [t _]; clear lo up. apply Rlt_le_trans with (2:= t); clear t. unfold sin_approx; simpl sum_f_R0; unfold sin_term; simpl. @@ -280,13 +280,13 @@ end. assert (t' : x ^ 2 <= 4). replace 4 with (2 ^ 2) by field. apply (pow_incr x 2); split; apply Rlt_le; assumption. -apply Rmult_lt_0_compat;[assumption | fourier ]. +apply Rmult_lt_0_compat;[assumption | lra ]. Qed. Lemma sin_PI2 : sin (PI / 2) = 1. replace (PI / 2) with PI2 by (unfold PI; field). assert (int' : 0 < PI2 < 2). - destruct pi2_int; split; fourier. + destruct pi2_int; split; lra. assert (lo2 := sin_pos_tech PI2 int'). assert (t2 : Rabs (sin PI2) = 1). rewrite <- Rabs_R1; apply Rsqr_eq_abs_0. @@ -295,10 +295,10 @@ revert t2; rewrite Rabs_pos_eq;[| apply Rlt_le]; tauto. Qed. Lemma PI_RGT_0 : PI > 0. -Proof. unfold PI; destruct pi2_int; fourier. Qed. +Proof. unfold PI; destruct pi2_int; lra. Qed. Lemma PI_4 : PI <= 4. -Proof. unfold PI; destruct pi2_int; fourier. Qed. +Proof. unfold PI; destruct pi2_int; lra. Qed. (**********) Lemma PI_neq0 : PI <> 0. @@ -344,13 +344,13 @@ Lemma cos_bound : forall (a : R) (n : nat), - PI / 2 <= a -> a <= PI / 2 -> Proof. intros a n lower upper; apply pre_cos_bound. apply Rle_trans with (2 := lower). - apply Rmult_le_reg_r with 2; [fourier |]. + apply Rmult_le_reg_r with 2; [lra |]. replace ((-PI/2) * 2) with (-PI) by field. - assert (t := PI_4); fourier. + assert (t := PI_4); lra. apply Rle_trans with (1 := upper). -apply Rmult_le_reg_r with 2; [fourier | ]. +apply Rmult_le_reg_r with 2; [lra | ]. replace ((PI/2) * 2) with PI by field. -generalize PI_4; intros; fourier. +generalize PI_4; intros; lra. Qed. (**********) Lemma neg_cos : forall x:R, cos (x + PI) = - cos x. @@ -749,19 +749,19 @@ Qed. Lemma _PI2_RLT_0 : - (PI / 2) < 0. Proof. assert (H := PI_RGT_0). - fourier. + lra. Qed. Lemma PI4_RLT_PI2 : PI / 4 < PI / 2. Proof. assert (H := PI_RGT_0). - fourier. + lra. Qed. Lemma PI2_Rlt_PI : PI / 2 < PI. Proof. assert (H := PI_RGT_0). - fourier. + lra. Qed. (***************************************************) diff --git a/theories/Reals/Rtrigo_calc.v b/theories/Reals/Rtrigo_calc.v index 7cbfc63033..78797c87c8 100644 --- a/theories/Reals/Rtrigo_calc.v +++ b/theories/Reals/Rtrigo_calc.v @@ -205,7 +205,6 @@ Proof with trivial. rewrite cos2; unfold Rsqr; rewrite sin_PI6; rewrite sqrt_def... field. left ; prove_sup0. - discrR. Qed. Lemma tan_PI6 : tan (PI / 6) = 1 / sqrt 3. diff --git a/theories/Strings/Ascii.v b/theories/Strings/Ascii.v index 5154b75b3f..31a7fb8ad6 100644 --- a/theories/Strings/Ascii.v +++ b/theories/Strings/Ascii.v @@ -40,6 +40,40 @@ Proof. decide equality; apply bool_dec. Defined. +Local Open Scope lazy_bool_scope. + +Definition eqb (a b : ascii) : bool := + match a, b with + | Ascii a0 a1 a2 a3 a4 a5 a6 a7, + Ascii b0 b1 b2 b3 b4 b5 b6 b7 => + Bool.eqb a0 b0 &&& Bool.eqb a1 b1 &&& Bool.eqb a2 b2 &&& Bool.eqb a3 b3 + &&& Bool.eqb a4 b4 &&& Bool.eqb a5 b5 &&& Bool.eqb a6 b6 &&& Bool.eqb a7 b7 + end. + +Infix "=?" := eqb : char_scope. + +Lemma eqb_spec (a b : ascii) : reflect (a = b) (a =? b)%char. +Proof. + destruct a, b; simpl. + do 8 (case Bool.eqb_spec; [ intros -> | constructor; now intros [= ] ]). + now constructor. +Qed. + +Local Ltac t_eqb := + repeat first [ congruence + | progress subst + | apply conj + | match goal with + | [ |- context[eqb ?x ?y] ] => destruct (eqb_spec x y) + end + | intro ]. +Lemma eqb_refl x : (x =? x)%char = true. Proof. t_eqb. Qed. +Lemma eqb_sym x y : (x =? y)%char = (y =? x)%char. Proof. t_eqb. Qed. +Lemma eqb_eq n m : (n =? m)%char = true <-> n = m. Proof. t_eqb. Qed. +Lemma eqb_neq x y : (x =? y)%char = false <-> x <> y. Proof. t_eqb. Qed. +Lemma eqb_compat: Morphisms.Proper (Morphisms.respectful eq (Morphisms.respectful eq eq)) eqb. +Proof. t_eqb. Qed. + (** * Conversion between natural numbers modulo 256 and ascii characters *) (** Auxiliary function that turns a positive into an ascii by diff --git a/theories/Strings/BinaryString.v b/theories/Strings/BinaryString.v new file mode 100644 index 0000000000..6df0a9170a --- /dev/null +++ b/theories/Strings/BinaryString.v @@ -0,0 +1,147 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Import Ascii String. +Require Import BinNums. +Import BinNatDef. +Import BinIntDef. +Import BinPosDef. + +Local Open Scope positive_scope. +Local Open Scope string_scope. + +Definition ascii_to_digit (ch : ascii) : option N + := (if ascii_dec ch "0" then Some 0 + else if ascii_dec ch "1" then Some 1 + else None)%N. + +Fixpoint pos_bin_app (p q:positive) : positive := + match q with + | q~0 => (pos_bin_app p q)~0 + | q~1 => (pos_bin_app p q)~1 + | 1 => p~1 + end. + +Module Raw. + Fixpoint of_pos (p : positive) (rest : string) : string + := match p with + | 1 => String "1" rest + | p'~0 => of_pos p' (String "0" rest) + | p'~1 => of_pos p' (String "1" rest) + end. + + Fixpoint to_N (s : string) (rest : N) + : N + := match s with + | "" => rest + | String ch s' + => to_N + s' + match ascii_to_digit ch with + | Some v => N.add v (N.double rest) + | None => N0 + end + end. + + Fixpoint to_N_of_pos (p : positive) (rest : string) (base : N) + : to_N (of_pos p rest) base + = to_N rest match base with + | N0 => N.pos p + | Npos v => Npos (pos_bin_app v p) + end. + Proof. + destruct p as [p|p|]; destruct base; try reflexivity; + cbn; rewrite to_N_of_pos; reflexivity. + Qed. +End Raw. + +Definition of_pos (p : positive) : string + := String "0" (String "b" (Raw.of_pos p "")). +Definition of_N (n : N) : string + := match n with + | N0 => "0b0" + | Npos p => of_pos p + end. +Definition of_Z (z : Z) : string + := match z with + | Zneg p => String "-" (of_pos p) + | Z0 => "0b0" + | Zpos p => of_pos p + end. +Definition of_nat (n : nat) : string + := of_N (N.of_nat n). + +Definition to_N (s : string) : N + := match s with + | String s0 (String sb s) + => if ascii_dec s0 "0" + then if ascii_dec sb "b" + then Raw.to_N s N0 + else N0 + else N0 + | _ => N0 + end. +Definition to_pos (s : string) : positive + := match to_N s with + | N0 => 1 + | Npos p => p + end. +Definition to_Z (s : string) : Z + := let '(is_neg, n) := match s with + | String s0 s' + => if ascii_dec s0 "-" + then (true, to_N s') + else (false, to_N s) + | EmptyString => (false, to_N s) + end in + match n with + | N0 => Z0 + | Npos p => if is_neg then Zneg p else Zpos p + end. +Definition to_nat (s : string) : nat + := N.to_nat (to_N s). + +Lemma to_N_of_N (n : N) + : to_N (of_N n) + = n. +Proof. + destruct n; [ reflexivity | apply Raw.to_N_of_pos ]. +Qed. + +Lemma Z_of_of_Z (z : Z) + : to_Z (of_Z z) + = z. +Proof. + cbv [of_Z to_Z]; destruct z as [|z|z]; cbn; + try reflexivity; + rewrite Raw.to_N_of_pos; cbn; reflexivity. +Qed. + +Lemma to_nat_of_nat (n : nat) + : to_nat (of_nat n) + = n. +Proof. + cbv [to_nat of_nat]; + rewrite to_N_of_N, Nnat.Nat2N.id; reflexivity. +Qed. + +Lemma to_pos_of_pos (p : positive) + : to_pos (of_pos p) + = p. +Proof. + cbv [of_pos to_pos to_N]; cbn; + rewrite Raw.to_N_of_pos; cbn; reflexivity. +Qed. + +Example of_pos_1 : of_pos 1 = "0b1" := eq_refl. +Example of_pos_2 : of_pos 2 = "0b10" := eq_refl. +Example of_pos_3 : of_pos 3 = "0b11" := eq_refl. +Example of_N_0 : of_N 0 = "0b0" := eq_refl. +Example of_Z_0 : of_Z 0 = "0b0" := eq_refl. +Example of_Z_m1 : of_Z (-1) = "-0b1" := eq_refl. +Example of_nat_0 : of_nat 0 = "0b0" := eq_refl. diff --git a/theories/Strings/HexString.v b/theories/Strings/HexString.v new file mode 100644 index 0000000000..9ea93c909e --- /dev/null +++ b/theories/Strings/HexString.v @@ -0,0 +1,229 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Import Ascii String. +Require Import BinNums. +Import BinNatDef. +Import BinIntDef. +Import BinPosDef. + +Local Open Scope positive_scope. +Local Open Scope string_scope. + +Local Notation "a || b" + := (if a then true else if b then true else false). +Definition ascii_to_digit (ch : ascii) : option N + := (if ascii_dec ch "0" then Some 0 + else if ascii_dec ch "1" then Some 1 + else if ascii_dec ch "2" then Some 2 + else if ascii_dec ch "3" then Some 3 + else if ascii_dec ch "4" then Some 4 + else if ascii_dec ch "5" then Some 5 + else if ascii_dec ch "6" then Some 6 + else if ascii_dec ch "7" then Some 7 + else if ascii_dec ch "8" then Some 8 + else if ascii_dec ch "9" then Some 9 + else if ascii_dec ch "a" || ascii_dec ch "A" then Some 10 + else if ascii_dec ch "b" || ascii_dec ch "B" then Some 11 + else if ascii_dec ch "c" || ascii_dec ch "C" then Some 12 + else if ascii_dec ch "d" || ascii_dec ch "D" then Some 13 + else if ascii_dec ch "e" || ascii_dec ch "E" then Some 14 + else if ascii_dec ch "f" || ascii_dec ch "F" then Some 15 + else None)%N. + +Fixpoint pos_hex_app (p q:positive) : positive := + match q with + | 1 => p~0~0~0~1 + | 2 => p~0~0~1~0 + | 3 => p~0~0~1~1 + | 4 => p~0~1~0~0 + | 5 => p~0~1~0~1 + | 6 => p~0~1~1~0 + | 7 => p~0~1~1~1 + | 8 => p~1~0~0~0 + | 9 => p~1~0~0~1 + | 10 => p~1~0~1~0 + | 11 => p~1~0~1~1 + | 12 => p~1~1~0~0 + | 13 => p~1~1~0~1 + | 14 => p~1~1~1~0 + | 15 => p~1~1~1~1 + | q~0~0~0~0 => (pos_hex_app p q)~0~0~0~0 + | q~0~0~0~1 => (pos_hex_app p q)~0~0~0~1 + | q~0~0~1~0 => (pos_hex_app p q)~0~0~1~0 + | q~0~0~1~1 => (pos_hex_app p q)~0~0~1~1 + | q~0~1~0~0 => (pos_hex_app p q)~0~1~0~0 + | q~0~1~0~1 => (pos_hex_app p q)~0~1~0~1 + | q~0~1~1~0 => (pos_hex_app p q)~0~1~1~0 + | q~0~1~1~1 => (pos_hex_app p q)~0~1~1~1 + | q~1~0~0~0 => (pos_hex_app p q)~1~0~0~0 + | q~1~0~0~1 => (pos_hex_app p q)~1~0~0~1 + | q~1~0~1~0 => (pos_hex_app p q)~1~0~1~0 + | q~1~0~1~1 => (pos_hex_app p q)~1~0~1~1 + | q~1~1~0~0 => (pos_hex_app p q)~1~1~0~0 + | q~1~1~0~1 => (pos_hex_app p q)~1~1~0~1 + | q~1~1~1~0 => (pos_hex_app p q)~1~1~1~0 + | q~1~1~1~1 => (pos_hex_app p q)~1~1~1~1 + end. + +Module Raw. + Fixpoint of_pos (p : positive) (rest : string) : string + := match p with + | 1 => String "1" rest + | 2 => String "2" rest + | 3 => String "3" rest + | 4 => String "4" rest + | 5 => String "5" rest + | 6 => String "6" rest + | 7 => String "7" rest + | 8 => String "8" rest + | 9 => String "9" rest + | 10 => String "a" rest + | 11 => String "b" rest + | 12 => String "c" rest + | 13 => String "d" rest + | 14 => String "e" rest + | 15 => String "f" rest + | p'~0~0~0~0 => of_pos p' (String "0" rest) + | p'~0~0~0~1 => of_pos p' (String "1" rest) + | p'~0~0~1~0 => of_pos p' (String "2" rest) + | p'~0~0~1~1 => of_pos p' (String "3" rest) + | p'~0~1~0~0 => of_pos p' (String "4" rest) + | p'~0~1~0~1 => of_pos p' (String "5" rest) + | p'~0~1~1~0 => of_pos p' (String "6" rest) + | p'~0~1~1~1 => of_pos p' (String "7" rest) + | p'~1~0~0~0 => of_pos p' (String "8" rest) + | p'~1~0~0~1 => of_pos p' (String "9" rest) + | p'~1~0~1~0 => of_pos p' (String "a" rest) + | p'~1~0~1~1 => of_pos p' (String "b" rest) + | p'~1~1~0~0 => of_pos p' (String "c" rest) + | p'~1~1~0~1 => of_pos p' (String "d" rest) + | p'~1~1~1~0 => of_pos p' (String "e" rest) + | p'~1~1~1~1 => of_pos p' (String "f" rest) + end. + + Fixpoint to_N (s : string) (rest : N) + : N + := match s with + | "" => rest + | String ch s' + => to_N + s' + match ascii_to_digit ch with + | Some v => N.add v (N.mul 16 rest) + | None => N0 + end + end. + + Fixpoint to_N_of_pos (p : positive) (rest : string) (base : N) + : to_N (of_pos p rest) base + = to_N rest match base with + | N0 => N.pos p + | Npos v => Npos (pos_hex_app v p) + end. + Proof. + do 4 try destruct p as [p|p|]; destruct base; try reflexivity; + cbn; rewrite to_N_of_pos; reflexivity. + Qed. +End Raw. + +Definition of_pos (p : positive) : string + := String "0" (String "x" (Raw.of_pos p "")). +Definition of_N (n : N) : string + := match n with + | N0 => "0x0" + | Npos p => of_pos p + end. +Definition of_Z (z : Z) : string + := match z with + | Zneg p => String "-" (of_pos p) + | Z0 => "0x0" + | Zpos p => of_pos p + end. +Definition of_nat (n : nat) : string + := of_N (N.of_nat n). + +Definition to_N (s : string) : N + := match s with + | String s0 (String so s) + => if ascii_dec s0 "0" + then if ascii_dec so "x" + then Raw.to_N s N0 + else N0 + else N0 + | _ => N0 + end. +Definition to_pos (s : string) : positive + := match to_N s with + | N0 => 1 + | Npos p => p + end. +Definition to_Z (s : string) : Z + := let '(is_neg, n) := match s with + | String s0 s' + => if ascii_dec s0 "-" + then (true, to_N s') + else (false, to_N s) + | EmptyString => (false, to_N s) + end in + match n with + | N0 => Z0 + | Npos p => if is_neg then Zneg p else Zpos p + end. +Definition to_nat (s : string) : nat + := N.to_nat (to_N s). + +Lemma to_N_of_N (n : N) + : to_N (of_N n) + = n. +Proof. + destruct n; [ reflexivity | apply Raw.to_N_of_pos ]. +Qed. + +Lemma to_Z_of_Z (z : Z) + : to_Z (of_Z z) + = z. +Proof. + cbv [of_Z to_Z]; destruct z as [|z|z]; cbn; + try reflexivity; + rewrite Raw.to_N_of_pos; cbn; reflexivity. +Qed. + +Lemma to_nat_of_nat (n : nat) + : to_nat (of_nat n) + = n. +Proof. + cbv [to_nat of_nat]; + rewrite to_N_of_N, Nnat.Nat2N.id; reflexivity. +Qed. + +Lemma to_pos_of_pos (p : positive) + : to_pos (of_pos p) + = p. +Proof. + cbv [of_pos to_pos to_N]; cbn; + rewrite Raw.to_N_of_pos; cbn; reflexivity. +Qed. + +Example of_pos_1 : of_pos 1 = "0x1" := eq_refl. +Example of_pos_2 : of_pos 2 = "0x2" := eq_refl. +Example of_pos_3 : of_pos 3 = "0x3" := eq_refl. +Example of_pos_7 : of_pos 7 = "0x7" := eq_refl. +Example of_pos_8 : of_pos 8 = "0x8" := eq_refl. +Example of_pos_9 : of_pos 9 = "0x9" := eq_refl. +Example of_pos_10 : of_pos 10 = "0xa" := eq_refl. +Example of_pos_11 : of_pos 11 = "0xb" := eq_refl. +Example of_pos_12 : of_pos 12 = "0xc" := eq_refl. +Example of_pos_13 : of_pos 13 = "0xd" := eq_refl. +Example of_pos_14 : of_pos 14 = "0xe" := eq_refl. +Example of_pos_15 : of_pos 15 = "0xf" := eq_refl. +Example of_pos_16 : of_pos 16 = "0x10" := eq_refl. +Example of_N_0 : of_N 0 = "0x0" := eq_refl. +Example of_Z_0 : of_Z 0 = "0x0" := eq_refl. +Example of_Z_m1 : of_Z (-1) = "-0x1" := eq_refl. +Example of_nat_0 : of_nat 0 = "0x0" := eq_refl. diff --git a/theories/Strings/OctalString.v b/theories/Strings/OctalString.v new file mode 100644 index 0000000000..fe8cc9aae9 --- /dev/null +++ b/theories/Strings/OctalString.v @@ -0,0 +1,179 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Import Ascii String. +Require Import BinNums. +Import BinNatDef. +Import BinIntDef. +Import BinPosDef. + +Local Open Scope positive_scope. +Local Open Scope string_scope. + +Definition ascii_to_digit (ch : ascii) : option N + := (if ascii_dec ch "0" then Some 0 + else if ascii_dec ch "1" then Some 1 + else if ascii_dec ch "2" then Some 2 + else if ascii_dec ch "3" then Some 3 + else if ascii_dec ch "4" then Some 4 + else if ascii_dec ch "5" then Some 5 + else if ascii_dec ch "6" then Some 6 + else if ascii_dec ch "7" then Some 7 + else None)%N. + +Fixpoint pos_oct_app (p q:positive) : positive := + match q with + | 1 => p~0~0~1 + | 2 => p~0~1~0 + | 3 => p~0~1~1 + | 4 => p~1~0~0 + | 5 => p~1~0~1 + | 6 => p~1~1~0 + | 7 => p~1~1~1 + | q~0~0~0 => (pos_oct_app p q)~0~0~0 + | q~0~0~1 => (pos_oct_app p q)~0~0~1 + | q~0~1~0 => (pos_oct_app p q)~0~1~0 + | q~0~1~1 => (pos_oct_app p q)~0~1~1 + | q~1~0~0 => (pos_oct_app p q)~1~0~0 + | q~1~0~1 => (pos_oct_app p q)~1~0~1 + | q~1~1~0 => (pos_oct_app p q)~1~1~0 + | q~1~1~1 => (pos_oct_app p q)~1~1~1 + end. + +Module Raw. + Fixpoint of_pos (p : positive) (rest : string) : string + := match p with + | 1 => String "1" rest + | 2 => String "2" rest + | 3 => String "3" rest + | 4 => String "4" rest + | 5 => String "5" rest + | 6 => String "6" rest + | 7 => String "7" rest + | p'~0~0~0 => of_pos p' (String "0" rest) + | p'~0~0~1 => of_pos p' (String "1" rest) + | p'~0~1~0 => of_pos p' (String "2" rest) + | p'~0~1~1 => of_pos p' (String "3" rest) + | p'~1~0~0 => of_pos p' (String "4" rest) + | p'~1~0~1 => of_pos p' (String "5" rest) + | p'~1~1~0 => of_pos p' (String "6" rest) + | p'~1~1~1 => of_pos p' (String "7" rest) + end. + + Fixpoint to_N (s : string) (rest : N) + : N + := match s with + | "" => rest + | String ch s' + => to_N + s' + match ascii_to_digit ch with + | Some v => N.add v (N.mul 8 rest) + | None => N0 + end + end. + + Fixpoint to_N_of_pos (p : positive) (rest : string) (base : N) + : to_N (of_pos p rest) base + = to_N rest match base with + | N0 => N.pos p + | Npos v => Npos (pos_oct_app v p) + end. + Proof. + do 3 try destruct p as [p|p|]; destruct base; try reflexivity; + cbn; rewrite to_N_of_pos; reflexivity. + Qed. +End Raw. + +Definition of_pos (p : positive) : string + := String "0" (String "o" (Raw.of_pos p "")). +Definition of_N (n : N) : string + := match n with + | N0 => "0o0" + | Npos p => of_pos p + end. +Definition of_Z (z : Z) : string + := match z with + | Zneg p => String "-" (of_pos p) + | Z0 => "0o0" + | Zpos p => of_pos p + end. +Definition of_nat (n : nat) : string + := of_N (N.of_nat n). + +Definition to_N (s : string) : N + := match s with + | String s0 (String so s) + => if ascii_dec s0 "0" + then if ascii_dec so "o" + then Raw.to_N s N0 + else N0 + else N0 + | _ => N0 + end. +Definition to_pos (s : string) : positive + := match to_N s with + | N0 => 1 + | Npos p => p + end. +Definition to_Z (s : string) : Z + := let '(is_neg, n) := match s with + | String s0 s' + => if ascii_dec s0 "-" + then (true, to_N s') + else (false, to_N s) + | EmptyString => (false, to_N s) + end in + match n with + | N0 => Z0 + | Npos p => if is_neg then Zneg p else Zpos p + end. +Definition to_nat (s : string) : nat + := N.to_nat (to_N s). + +Lemma to_N_of_N (n : N) + : to_N (of_N n) + = n. +Proof. + destruct n; [ reflexivity | apply Raw.to_N_of_pos ]. +Qed. + +Lemma to_Z_of_Z (z : Z) + : to_Z (of_Z z) + = z. +Proof. + cbv [of_Z to_Z]; destruct z as [|z|z]; cbn; + try reflexivity; + rewrite Raw.to_N_of_pos; cbn; reflexivity. +Qed. + +Lemma to_nat_of_nat (n : nat) + : to_nat (of_nat n) + = n. +Proof. + cbv [to_nat of_nat]; + rewrite to_N_of_N, Nnat.Nat2N.id; reflexivity. +Qed. + +Lemma to_pos_of_pos (p : positive) + : to_pos (of_pos p) + = p. +Proof. + cbv [of_pos to_pos to_N]; cbn; + rewrite Raw.to_N_of_pos; cbn; reflexivity. +Qed. + +Example of_pos_1 : of_pos 1 = "0o1" := eq_refl. +Example of_pos_2 : of_pos 2 = "0o2" := eq_refl. +Example of_pos_3 : of_pos 3 = "0o3" := eq_refl. +Example of_pos_7 : of_pos 7 = "0o7" := eq_refl. +Example of_pos_8 : of_pos 8 = "0o10" := eq_refl. +Example of_N_0 : of_N 0 = "0o0" := eq_refl. +Example of_Z_0 : of_Z 0 = "0o0" := eq_refl. +Example of_Z_m1 : of_Z (-1) = "-0o1" := eq_refl. +Example of_nat_0 : of_nat 0 = "0o0" := eq_refl. diff --git a/theories/Strings/String.v b/theories/Strings/String.v index 2be6618ad6..be9a10c6dc 100644 --- a/theories/Strings/String.v +++ b/theories/Strings/String.v @@ -14,6 +14,7 @@ Require Import Arith. Require Import Ascii. +Require Import Bool. Declare ML Module "string_syntax_plugin". (** *** Definition of strings *) @@ -35,6 +36,39 @@ Proof. decide equality; apply ascii_dec. Defined. +Local Open Scope lazy_bool_scope. + +Fixpoint eqb s1 s2 : bool := + match s1, s2 with + | EmptyString, EmptyString => true + | String c1 s1', String c2 s2' => Ascii.eqb c1 c2 &&& eqb s1' s2' + | _,_ => false + end. + +Infix "=?" := eqb : string_scope. + +Lemma eqb_spec s1 s2 : Bool.reflect (s1 = s2) (s1 =? s2)%string. +Proof. + revert s2. induction s1; destruct s2; try (constructor; easy); simpl. + case Ascii.eqb_spec; simpl; [intros -> | constructor; now intros [= ]]. + case IHs1; [intros ->; now constructor | constructor; now intros [= ]]. +Qed. + +Local Ltac t_eqb := + repeat first [ congruence + | progress subst + | apply conj + | match goal with + | [ |- context[eqb ?x ?y] ] => destruct (eqb_spec x y) + end + | intro ]. +Lemma eqb_refl x : (x =? x)%string = true. Proof. t_eqb. Qed. +Lemma eqb_sym x y : (x =? y)%string = (y =? x)%string. Proof. t_eqb. Qed. +Lemma eqb_eq n m : (n =? m)%string = true <-> n = m. Proof. t_eqb. Qed. +Lemma eqb_neq x y : (x =? y)%string = false <-> x <> y. Proof. t_eqb. Qed. +Lemma eqb_compat: Morphisms.Proper (Morphisms.respectful eq (Morphisms.respectful eq eq)) eqb. +Proof. t_eqb. Qed. + (** *** Concatenation of strings *) Reserved Notation "x ++ y" (right associativity, at level 60). diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml index c640167ac8..05bc6aea9b 100644 --- a/tools/coqdoc/output.ml +++ b/tools/coqdoc/output.ml @@ -76,7 +76,7 @@ let is_tactic = [ "intro"; "intros"; "apply"; "rewrite"; "refine"; "case"; "clear"; "injection"; "elimtype"; "progress"; "setoid_rewrite"; "left"; "right"; "constructor"; "econstructor"; "decide equality"; "abstract"; "exists"; "cbv"; "simple destruct"; - "info"; "fourier"; "field"; "specialize"; "evar"; "solve"; "instanciate"; "info_auto"; "info_eauto"; + "info"; "field"; "specialize"; "evar"; "solve"; "instanciate"; "info_auto"; "info_eauto"; "quote"; "eexact"; "autorewrite"; "destruct"; "destruction"; "destruct_call"; "dependent"; "elim"; "extensionality"; "f_equal"; "generalize"; "generalize_eqs"; "generalize_eqs_vars"; "induction"; "rename"; "move"; "omega"; diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index 89602c9b56..900964609d 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -68,6 +68,7 @@ type coq_cmdopts = { impredicative_set : Declarations.set_predicativity; stm_flags : Stm.AsyncOpts.stm_opt; debug : bool; + diffs_set : bool; time : bool; filter_opts : bool; @@ -117,6 +118,7 @@ let init_args = { impredicative_set = Declarations.PredicativeSet; stm_flags = Stm.AsyncOpts.default_opts; debug = false; + diffs_set = false; time = false; filter_opts = false; @@ -526,6 +528,12 @@ let parse_args arglist : coq_cmdopts * string list = |"-color" -> set_color oval (next ()) |"-config"|"--config" -> { oval with print_config = true } |"-debug" -> Coqinit.set_debug (); oval + |"-diffs" -> let opt = next () in + if List.exists (fun x -> opt = x) ["off"; "on"; "removed"] then + Proof_diffs.write_diffs_option opt + else + (prerr_endline ("Error: on|off|removed expected after -diffs"); exit 1); + { oval with diffs_set = true } |"-stm-debug" -> Stm.stm_debug := true; oval |"-emacs" -> set_emacs oval |"-filteropts" -> { oval with filter_opts = true } diff --git a/toplevel/coqargs.mli b/toplevel/coqargs.mli index 9fb6219a61..7b0cdcf127 100644 --- a/toplevel/coqargs.mli +++ b/toplevel/coqargs.mli @@ -43,6 +43,7 @@ type coq_cmdopts = { impredicative_set : Declarations.set_predicativity; stm_flags : Stm.AsyncOpts.stm_opt; debug : bool; + diffs_set : bool; time : bool; filter_opts : bool; diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 7ae15ac100..7b7e1b16c0 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -318,12 +318,6 @@ let loop_flush_all () = Format.pp_print_flush !Topfmt.std_ft (); Format.pp_print_flush !Topfmt.err_ft () -let pr_open_cur_subgoals () = - try - let proof = Proof_global.give_me_the_proof () in - Printer.pr_open_subgoals ~proof - with Proof_global.NoCurrentProof -> Pp.str "" - (* Goal equality heuristic. *) let pequal cmp1 cmp2 (a1,a2) (b1,b2) = cmp1 a1 b1 && cmp2 a2 b2 let evleq e1 e2 = CList.equal Evar.equal e1 e2 @@ -346,7 +340,7 @@ let top_goal_print oldp newp = let proof_changed = not (Option.equal cproof oldp newp) in let print_goals = not !Flags.quiet && proof_changed && Proof_global.there_are_pending_proofs () in - if print_goals then Feedback.msg_notice (pr_open_cur_subgoals ()) + if print_goals then Printer.print_and_diff oldp newp; with | exn -> let (e, info) = CErrors.push exn in diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index e979d0e544..9b68f303a6 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -339,8 +339,8 @@ let do_vio opts = (******************************************************************************) (* Color Options *) (******************************************************************************) -let init_color color_mode = - let has_color = match color_mode with +let init_color opts = + let has_color = match opts.color with | `OFF -> false | `ON -> true | `AUTO -> @@ -350,26 +350,23 @@ let init_color color_mode = its TERM variable is set to "dumb". *) try Sys.getenv "TERM" <> "dumb" with Not_found -> false in - if has_color then begin - let colors = try Some (Sys.getenv "COQ_COLORS") with Not_found -> None in - match colors with - | None -> - (** Default colors *) - Topfmt.default_styles (); - Topfmt.init_terminal_output ~color:true - | Some "" -> - (** No color output *) - Topfmt.init_terminal_output ~color:false - | Some s -> - (** Overwrite all colors *) - Topfmt.parse_color_config s; - Topfmt.init_terminal_output ~color:true - end - else - Topfmt.init_terminal_output ~color:false + let term_color = + if has_color then begin + let colors = try Some (Sys.getenv "COQ_COLORS") with Not_found -> None in + match colors with + | None -> Topfmt.default_styles (); true (** Default colors *) + | Some "" -> false (** No color output *) + | Some s -> Topfmt.parse_color_config s; true (** Overwrite all colors *) + end + else + false + in + if Proof_diffs.show_diffs () && not term_color && not opts.batch_mode then + CErrors.user_err Pp.(str "Error: -diffs requires enabling -color"); + Topfmt.init_terminal_output ~color:term_color let print_style_tags opts = - let () = init_color opts.color in + let () = init_color opts in let tags = Topfmt.dump_tags () in let iter (t, st) = let opt = Terminal.eval st ^ t ^ Terminal.reset ^ "\n" in @@ -520,7 +517,7 @@ type custom_toplevel = { } let coqtop_init ~opts extra = - init_color opts.color; + init_color opts; CoqworkmgrApi.(init !async_proofs_worker_priority); opts, extra diff --git a/toplevel/usage.ml b/toplevel/usage.ml index 504ffa521b..d85fed5f43 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -72,7 +72,8 @@ let print_usage_channel co command = \n -boot boot mode (implies -q and -batch)\ \n -bt print backtraces (requires configure debug flag)\ \n -debug debug mode (implies -bt)\ -\n -stm-debug STM debug mode (will trace every transaction) \ +\n -diffs (on|off|removed) highlight differences between proof steps\ +\n -stm-debug STM debug mode (will trace every transaction)\ \n -emacs tells Coq it is executed under Emacs\ \n -noglob do not dump globalizations\ \n -dump-glob f dump globalizations in file f (to be used by coqdoc)\ diff --git a/vernac/class.ml b/vernac/class.ml index e425e6474d..614b2181d9 100644 --- a/vernac/class.ml +++ b/vernac/class.ml @@ -73,7 +73,7 @@ let check_reference_arity ref = let check_arity = function | CL_FUN | CL_SORT -> () | CL_CONST cst -> check_reference_arity (ConstRef cst) - | CL_PROJ cst -> check_reference_arity (ConstRef cst) + | CL_PROJ p -> check_reference_arity (ConstRef (Projection.Repr.constant p)) | CL_SECVAR id -> check_reference_arity (VarRef id) | CL_IND kn -> check_reference_arity (IndRef kn) @@ -92,8 +92,8 @@ let uniform_cond sigma ctx lt = let class_of_global = function | ConstRef sp -> - if Environ.is_projection sp (Global.env ()) - then CL_PROJ sp else CL_CONST sp + (match Recordops.find_primitive_projection sp with + | Some p -> CL_PROJ p | None -> CL_CONST sp) | IndRef sp -> CL_IND sp | VarRef id -> CL_SECVAR id | ConstructRef _ as c -> @@ -143,8 +143,8 @@ let get_target t ind = CL_FUN else match pi1 (find_class_type Evd.empty (EConstr.of_constr t)) with - | CL_CONST p when Environ.is_projection p (Global.env ()) -> - CL_PROJ p + | CL_CONST p when Recordops.is_primitive_projection p -> + CL_PROJ (Option.get @@ Recordops.find_primitive_projection p) | x -> x let strength_of_cl = function @@ -165,7 +165,8 @@ let get_strength stre ref cls clt = let ident_key_of_class = function | CL_FUN -> "Funclass" | CL_SORT -> "Sortclass" - | CL_CONST sp | CL_PROJ sp -> Label.to_string (Constant.label sp) + | CL_CONST sp -> Label.to_string (Constant.label sp) + | CL_PROJ sp -> Label.to_string (Projection.Repr.label sp) | CL_IND (sp,_) -> Label.to_string (MutInd.label sp) | CL_SECVAR id -> Id.to_string id diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index eef7afbfba..102a98f046 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -187,7 +187,9 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = let sigma, def = let sigma, h_a_term = Evarutil.new_global sigma (delayed_force fix_sub_ref) in let sigma, h_e_term = Evarutil.new_evar env sigma - ~src:(Loc.tag @@ Evar_kinds.QuestionMark (Evar_kinds.Define false,Anonymous)) wf_proof in + ~src:(Loc.tag @@ Evar_kinds.QuestionMark { + Evar_kinds.default_question_mark with Evar_kinds.qm_obligation=Evar_kinds.Define false; + }) wf_proof in sigma, mkApp (h_a_term, [| argtyp ; wf_rel ; h_e_term; prop |]) in let sigma, def = Typing.solve_evars env sigma def in diff --git a/vernac/egramml.ml b/vernac/egramml.ml index 048d4d93a0..c5dedc880e 100644 --- a/vernac/egramml.ml +++ b/vernac/egramml.ml @@ -64,6 +64,15 @@ let make_rule f prod = let act = ty_eval ty_rule f in Extend.Rule (symb, act) +let rec proj_symbol : type a b c. (a, b, c) ty_user_symbol -> (a, b, c) genarg_type = function +| TUentry a -> ExtraArg a +| TUentryl (a,l) -> ExtraArg a +| TUopt(o) -> OptArg (proj_symbol o) +| TUlist1 l -> ListArg (proj_symbol l) +| TUlist1sep (l,_) -> ListArg (proj_symbol l) +| TUlist0 l -> ListArg (proj_symbol l) +| TUlist0sep (l,_) -> ListArg (proj_symbol l) + (** Vernac grammar extensions *) let vernac_exts = ref [] diff --git a/vernac/egramml.mli b/vernac/egramml.mli index a5ee036db5..c4f4fcfaa4 100644 --- a/vernac/egramml.mli +++ b/vernac/egramml.mli @@ -26,6 +26,8 @@ val extend_vernac_command_grammar : val get_extend_vernac_rule : Vernacexpr.extend_name -> vernac_expr grammar_prod_item list +val proj_symbol : ('a, 'b, 'c) Extend.ty_user_symbol -> ('a, 'b, 'c) Genarg.genarg_type + (** Utility function reused in Egramcoq : *) val make_rule : diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 534e58f9c9..b9c47ff475 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -194,12 +194,6 @@ let rec pr_disjunction pr = function | a::l -> pr a ++ str "," ++ spc () ++ pr_disjunction pr l | [] -> assert false -let pr_puniverses f env (c,u) = - f env c ++ - (if Flags.is_universe_polymorphism () && not (Univ.Instance.is_empty u) then - str"(*" ++ Univ.Instance.pr UnivNames.pr_with_global_universes u ++ str"*)" - else mt()) - let explain_elim_arity env sigma ind sorts c pj okinds = let open EConstr in let env = make_all_name_different env sigma in @@ -262,7 +256,7 @@ let explain_ill_formed_branch env sigma c ci actty expty = let pa, pe = pr_explicit env sigma (simp actty) (simp expty) in strbrk "In pattern-matching on term" ++ brk(1,1) ++ pc ++ spc () ++ strbrk "the branch for constructor" ++ spc () ++ - quote (pr_puniverses pr_constructor env ci) ++ + quote (pr_pconstructor env sigma ci) ++ spc () ++ str "has type" ++ brk(1,1) ++ pa ++ spc () ++ str "which should be" ++ brk(1,1) ++ pe ++ str "." @@ -520,11 +514,15 @@ let pr_trailing_ne_context_of env sigma = then str "." else (str " in environment:"++ pr_context_unlimited env sigma) -let rec explain_evar_kind env sigma evk ty = function +let rec explain_evar_kind env sigma evk ty = + let open Evar_kinds in + function | Evar_kinds.NamedHole id -> strbrk "the existential variable named " ++ Id.print id - | Evar_kinds.QuestionMark _ -> + | Evar_kinds.QuestionMark {qm_record_field=None} -> strbrk "this placeholder of type " ++ ty + | Evar_kinds.QuestionMark {qm_record_field=Some {fieldname; recordname}} -> + str "field " ++ (Printer.pr_constant env fieldname) ++ str " of record " ++ (Printer.pr_inductive env recordname) | Evar_kinds.CasesType false -> strbrk "the type of this pattern-matching problem" | Evar_kinds.CasesType true -> @@ -1229,12 +1227,7 @@ let explain_wrong_numarg_inductive env ind n = str " expects " ++ decline_string n "argument" ++ str "." let explain_unused_clause env pats = -(* Without localisation - let s = if List.length pats > 1 then "s" else "" in - (str ("Unused clause with pattern"^s) ++ spc () ++ - hov 0 (pr_sequence pr_cases_pattern pats) ++ str ")") -*) - str "This clause is redundant." + str "Pattern \"" ++ hov 0 (prlist_with_sep pr_comma pr_cases_pattern pats) ++ strbrk "\" is redundant in this clause." let explain_non_exhaustive env pats = str "Non exhaustive pattern-matching: no clause found for " ++ diff --git a/vernac/obligations.ml b/vernac/obligations.ml index 1f401b4e15..14d7642328 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -220,7 +220,7 @@ let eterm_obligations env name evm fs ?status t ty = in let loc, k = evar_source id evm in let status = match k with - | Evar_kinds.QuestionMark (o,_) -> o + | Evar_kinds.QuestionMark { Evar_kinds.qm_obligation=o } -> o | _ -> match status with | Some o -> o | None -> Evar_kinds.Define (not (Program.get_proofs_transparency ())) diff --git a/vernac/proof_using.ml b/vernac/proof_using.ml index 74e53bef18..3e2bd98720 100644 --- a/vernac/proof_using.ml +++ b/vernac/proof_using.ml @@ -18,14 +18,6 @@ module NamedDecl = Context.Named.Declaration let known_names = Summary.ref [] ~name:"proofusing-nameset" -let in_nameset = - let open Libobject in - declare_object { (default_object "proofusing-nameset") with - cache_function = (fun (_,x) -> known_names := x :: !known_names); - classify_function = (fun _ -> Dispose); - discharge_function = (fun _ -> None) - } - let rec close_fwd e s = let s' = List.fold_left (fun s decl -> @@ -73,7 +65,7 @@ let process_expr env e ty = let s = Id.Set.union v_ty (process_expr env e ty) in Id.Set.elements s -let name_set id expr = Lib.add_anonymous_leaf (in_nameset (id,expr)) +let name_set id expr = known_names := (id,expr) :: !known_names let minimize_hyps env ids = let rec aux ids = diff --git a/vernac/record.ml b/vernac/record.ml index 7a8ce7d25a..6b5c538df2 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -324,12 +324,16 @@ let declare_projections indsp ctx ?(kind=StructureComponent) binder_name coers u | Name fid -> try let kn, term = if is_local_assum decl && primitive then - (** Already defined in the kernel silently *) - let gr = Nametab.locate (Libnames.qualid_of_ident fid) in - let kn = destConstRef gr in + let p = Projection.Repr.make indsp + ~proj_npars:mib.mind_nparams + ~proj_arg:i + (Label.of_id fid) + in + (** Already defined by declare_mind silently *) + let kn = Projection.Repr.constant p in Declare.definition_message fid; - UnivNames.register_universe_binders gr ubinders; - kn, mkProj (Projection.make kn false,mkRel 1) + UnivNames.register_universe_binders (ConstRef kn) ubinders; + kn, mkProj (Projection.make p false,mkRel 1) else let ccl = subst_projection fid subst ti in let body = match decl with diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml index 609dac69aa..f842ca5ead 100644 --- a/vernac/topfmt.ml +++ b/vernac/topfmt.ml @@ -181,6 +181,10 @@ let default_tag_map () = let open Terminal in [ ; "tactic.keyword" , make ~bold:true () ; "tactic.primitive" , make ~fg_color:`LIGHT_GREEN () ; "tactic.string" , make ~fg_color:`LIGHT_RED () + ; "diff.added" , make ~bg_color:(`RGB(0,141,0)) ~underline:true () + ; "diff.removed" , make ~bg_color:(`RGB(170,0,0)) ~underline:true () + ; "diff.added.bg" , make ~bg_color:(`RGB(0,91,0)) () + ; "diff.removed.bg" , make ~bg_color:(`RGB(91,0,0)) () ] let tag_map = ref CString.Map.empty @@ -198,72 +202,103 @@ let parse_color_config file = let dump_tags () = CString.Map.bindings !tag_map +let empty = Terminal.make () +let default_style = Terminal.reset_style + +let get_style tag = + try CString.Map.find tag !tag_map + with Not_found -> empty;; + +let get_open_seq tags = + let style = List.fold_left (fun a b -> Terminal.merge a (get_style b)) default_style tags in + Terminal.eval (Terminal.diff default_style style);; + +let get_close_seq tags = + let style = List.fold_left (fun a b -> Terminal.merge a (get_style b)) default_style tags in + Terminal.eval (Terminal.diff style default_style);; + +let diff_tag_stack = ref [] (* global, just like std_ft *) + (** Not thread-safe. We should put a lock somewhere if we print from different threads. Do we? *) let make_style_stack () = (** Default tag is to reset everything *) - let empty = Terminal.make () in - let default_tag = Terminal.({ - fg_color = Some `DEFAULT; - bg_color = Some `DEFAULT; - bold = Some false; - italic = Some false; - underline = Some false; - negative = Some false; - prefix = None; - suffix = None; - }) - in let style_stack = ref [] in let peek () = match !style_stack with - | [] -> default_tag (** Anomalous case, but for robustness *) + | [] -> default_style (** Anomalous case, but for robustness *) | st :: _ -> st in - let push tag = - let style = - try CString.Map.find tag !tag_map - with | Not_found -> empty - in - (** Use the merging of the latest tag and the one being currently pushed. - This may be useful if for instance the latest tag changes the background and - the current one the foreground, so that the two effects are additioned. *) + let open_tag tag = + let (tpfx, ttag) = split_tag tag in + if tpfx = end_pfx then "" else + let style = get_style ttag in + (** Merge the current settings and the style being pushed. This allows + restoring the previous settings correctly in a pop when both set the same + attribute. Example: current settings have red FG, the pushed style has + green FG. When popping the style, we should set red FG, not default FG. *) let style = Terminal.merge (peek ()) style in + let diff = Terminal.diff (peek ()) style in style_stack := style :: !style_stack; - Terminal.eval style + if tpfx = start_pfx then diff_tag_stack := ttag :: !diff_tag_stack; + Terminal.eval diff in - let pop _ = match !style_stack with - | [] -> (** Something went wrong, we fallback *) - Terminal.eval default_tag - | _ :: rem -> style_stack := rem; - Terminal.eval (peek ()) + let close_tag tag = + let (tpfx, _) = split_tag tag in + if tpfx = start_pfx then "" else begin + if tpfx = end_pfx then diff_tag_stack := (try List.tl !diff_tag_stack with tl -> []); + match !style_stack with + | [] -> (** Something went wrong, we fallback *) + Terminal.eval default_style + | cur :: rem -> style_stack := rem; + if cur = (peek ()) then "" else + if rem = [] then Terminal.reset else + Terminal.eval (Terminal.diff cur (peek ())) + end in let clear () = style_stack := [] in - push, pop, clear + open_tag, close_tag, clear let make_printing_functions () = - let empty = Terminal.make () in let print_prefix ft tag = - let style = - try CString.Map.find tag !tag_map - with | Not_found -> empty - in - match style.Terminal.prefix with Some s -> Format.pp_print_string ft s | None -> () - in + let (tpfx, ttag) = split_tag tag in + if tpfx <> end_pfx then + let style = get_style ttag in + match style.Terminal.prefix with Some s -> Format.pp_print_string ft s | None -> () in + let print_suffix ft tag = - let style = - try CString.Map.find tag !tag_map - with | Not_found -> empty - in - match style.Terminal.suffix with Some s -> Format.pp_print_string ft s | None -> () - in + let (tpfx, ttag) = split_tag tag in + if tpfx <> start_pfx then + let style = get_style ttag in + match style.Terminal.suffix with Some s -> Format.pp_print_string ft s | None -> () in + print_prefix, print_suffix +let init_output_fns () = + let reopen_highlight = ref "" in + let open Format in + let fns = Format.pp_get_formatter_out_functions !std_ft () in + let newline () = + if !diff_tag_stack <> [] then begin + let close = get_close_seq !diff_tag_stack in + fns.out_string close 0 (String.length close); + reopen_highlight := get_open_seq (List.rev !diff_tag_stack); + end; + fns.out_string "\n" 0 1 in + let string s off n = + if !reopen_highlight <> "" && String.trim (String.sub s off n) <> "" then begin + fns.out_string !reopen_highlight 0 (String.length !reopen_highlight); + reopen_highlight := "" + end; + fns.out_string s off n in + let new_fns = { fns with out_string = string; out_newline = newline } in + Format.pp_set_formatter_out_functions !std_ft new_fns;; + let init_terminal_output ~color = - let push_tag, pop_tag, clear_tag = make_style_stack () in + let open_tag, close_tag, clear_tag = make_style_stack () in let print_prefix, print_suffix = make_printing_functions () in let tag_handler ft = { - Format.mark_open_tag = push_tag; - Format.mark_close_tag = pop_tag; + Format.mark_open_tag = open_tag; + Format.mark_close_tag = close_tag; Format.print_open_tag = print_prefix ft; Format.print_close_tag = print_suffix ft; } in @@ -271,6 +306,7 @@ let init_terminal_output ~color = (* Use 0-length markers *) begin std_logger_cleanup := clear_tag; + init_output_fns (); Format.pp_set_mark_tags !std_ft true; Format.pp_set_mark_tags !err_ft true end diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index b6bc76a2ed..653f8b26e0 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -2436,3 +2436,121 @@ let interp ?verbosely ?proof ~st cmd = let exn = CErrors.push exn in Vernacstate.invalidate_cache (); iraise exn + +(** VERNAC EXTEND registering *) + +open Genarg +open Extend + +type classifier = Genarg.raw_generic_argument list -> vernac_classification + +type (_, _) ty_sig = +| TyNil : (atts:atts -> st:Vernacstate.t -> Vernacstate.t, Vernacexpr.vernac_classification) ty_sig +| TyTerminal : string * ('r, 's) ty_sig -> ('r, 's) ty_sig +| TyNonTerminal : + string option * ('a, 'b, 'c) Extend.ty_user_symbol * ('r, 's) ty_sig -> ('a -> 'r, 'a -> 's) ty_sig + +type ty_ml = TyML : bool * ('r, 's) ty_sig * 'r * 's option -> ty_ml + +let type_error () = CErrors.anomaly (Pp.str "Ill-typed VERNAC EXTEND") + +let rec untype_classifier : type r s. (r, s) ty_sig -> s -> classifier = function +| TyNil -> fun f args -> + begin match args with + | [] -> f + | _ :: _ -> type_error () + end +| TyTerminal (_, ty) -> fun f args -> untype_classifier ty f args +| TyNonTerminal (_, tu, ty) -> fun f args -> + begin match args with + | [] -> type_error () + | Genarg.GenArg (Rawwit tag, v) :: args -> + match Genarg.genarg_type_eq tag (Egramml.proj_symbol tu) with + | None -> type_error () + | Some Refl -> untype_classifier ty (f v) args + end + +(** Stupid GADTs forces us to duplicate the definition just for typing *) +let rec untype_command : type r s. (r, s) ty_sig -> r -> plugin_args vernac_command = function +| TyNil -> fun f args -> + begin match args with + | [] -> f + | _ :: _ -> type_error () + end +| TyTerminal (_, ty) -> fun f args -> untype_command ty f args +| TyNonTerminal (_, tu, ty) -> fun f args -> + begin match args with + | [] -> type_error () + | Genarg.GenArg (Rawwit tag, v) :: args -> + match Genarg.genarg_type_eq tag (Egramml.proj_symbol tu) with + | None -> type_error () + | Some Refl -> untype_command ty (f v) args + end + +let rec untype_user_symbol : type s a b c. (a, b, c) Extend.ty_user_symbol -> (s, a) Extend.symbol = function +| TUlist1 l -> Alist1 (untype_user_symbol l) +| TUlist1sep (l, s) -> Alist1sep (untype_user_symbol l, Atoken (CLexer.terminal s)) +| TUlist0 l -> Alist0 (untype_user_symbol l) +| TUlist0sep (l, s) -> Alist0sep (untype_user_symbol l, Atoken (CLexer.terminal s)) +| TUopt o -> Aopt (untype_user_symbol o) +| TUentry a -> Aentry (Pcoq.genarg_grammar (ExtraArg a)) +| TUentryl (a, i) -> Aentryl (Pcoq.genarg_grammar (ExtraArg a), string_of_int i) + +let rec untype_grammar : type r s. (r, s) ty_sig -> vernac_expr Egramml.grammar_prod_item list = function +| TyNil -> [] +| TyTerminal (tok, ty) -> Egramml.GramTerminal tok :: untype_grammar ty +| TyNonTerminal (id, tu, ty) -> + let t = Option.map (fun _ -> rawwit (Egramml.proj_symbol tu)) id in + let symb = untype_user_symbol tu in + Egramml.GramNonTerminal (Loc.tag (t, symb)) :: untype_grammar ty + +let _ = untype_classifier, untype_command, untype_grammar, untype_user_symbol + +let classifiers : classifier array String.Map.t ref = ref String.Map.empty + +let get_vernac_classifier (name, i) args = + (String.Map.find name !classifiers).(i) args + +let declare_vernac_classifier name f = + classifiers := String.Map.add name f !classifiers + +let vernac_extend ~command ?classifier ?entry ext = + let get_classifier (TyML (_, ty, _, cl)) = match cl with + | Some cl -> untype_classifier ty cl + | None -> + match classifier with + | Some cl -> fun _ -> cl command + | None -> + let e = match entry with + | None -> "COMMAND" + | Some e -> Pcoq.Gram.Entry.name e + in + let msg = Printf.sprintf "\ + Vernac entry \"%s\" misses a classifier. \ + A classifier is a function that returns an expression \ + of type vernac_classification (see Vernacexpr). You can: \n\ + - Use '... EXTEND %s CLASSIFIED AS QUERY ...' if the \ + new vernacular command does not alter the system state;\n\ + - Use '... EXTEND %s CLASSIFIED AS SIDEFF ...' if the \ + new vernacular command alters the system state but not the \ + parser nor it starts a proof or ends one;\n\ + - Use '... EXTEND %s CLASSIFIED BY f ...' to specify \ + a global function f. The function f will be called passing\ + \"%s\" as the only argument;\n\ + - Add a specific classifier in each clause using the syntax:\n\ + '[...] => [ f ] -> [...]'.\n\ + Specific classifiers have precedence over global \ + classifiers. Only one classifier is called." + command e e e command + in + CErrors.user_err (Pp.strbrk msg) + in + let cl = Array.map_of_list get_classifier ext in + let iter i (TyML (depr, ty, f, _)) = + let f = untype_command ty f in + let r = untype_grammar ty in + let () = vinterp_add depr (command, i) f in + Egramml.extend_vernac_command_grammar (command, i) entry r + in + let () = declare_vernac_classifier command cl in + List.iteri iter ext diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index 79f9c05ad8..fb2a30bac7 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -42,3 +42,33 @@ val universe_polymorphism_option_name : string list (** Elaborate a [atts] record out of a list of flags. Also returns whether polymorphism is explicitly (un)set. *) val attributes_of_flags : Vernacexpr.vernac_flags -> Vernacinterp.atts -> bool option * Vernacinterp.atts + +(** {5 VERNAC EXTEND} *) + +type classifier = Genarg.raw_generic_argument list -> Vernacexpr.vernac_classification + +type (_, _) ty_sig = +| TyNil : (atts:Vernacinterp.atts -> st:Vernacstate.t -> Vernacstate.t, Vernacexpr.vernac_classification) ty_sig +| TyTerminal : string * ('r, 's) ty_sig -> ('r, 's) ty_sig +| TyNonTerminal : + string option * + ('a, 'b, 'c) Extend.ty_user_symbol * ('r, 's) ty_sig -> + ('a -> 'r, 'a -> 's) ty_sig + +type ty_ml = TyML : bool (** deprecated *) * ('r, 's) ty_sig * 'r * 's option -> ty_ml + +(** Wrapper to dynamically extend vernacular commands. *) +val vernac_extend : + command:string -> + ?classifier:(string -> Vernacexpr.vernac_classification) -> + ?entry:Vernacexpr.vernac_expr Pcoq.Entry.t -> + ty_ml list -> unit + +(** {5 STM classifiers} *) + +val get_vernac_classifier : + Vernacexpr.extend_name -> classifier + +(** Low-level API, not for casual user. *) +val declare_vernac_classifier : + string -> classifier array -> unit |