aboutsummaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
-rw-r--r--.gitlab-ci.yml4
-rw-r--r--.travis.yml9
-rw-r--r--CHANGES22
-rw-r--r--Makefile.doc15
-rw-r--r--appveyor.yml4
-rw-r--r--checker/checker.ml44
-rw-r--r--checker/print.ml156
-rw-r--r--checker/print.mli2
-rw-r--r--checker/reduction.ml4
-rw-r--r--checker/univ.mli2
-rw-r--r--clib/option.ml5
-rw-r--r--clib/option.mli3
-rw-r--r--configure.ml389
-rw-r--r--dev/build/windows/MakeCoq_MinGW.bat13
-rw-r--r--dev/build/windows/ReadMe.txt5
-rw-r--r--dev/build/windows/makecoq_mingw.sh39
-rw-r--r--dev/build/windows/patches_coq/coq_new.nsi11
-rw-r--r--dev/ci/appveyor.bat1
-rw-r--r--dev/doc/setup.txt10
-rw-r--r--dev/header.c9
-rw-r--r--dev/header.ml (renamed from dev/header)0
-rw-r--r--dev/header.py9
-rw-r--r--doc/LICENSE10
-rw-r--r--doc/refman/Classes.tex27
-rw-r--r--doc/refman/RefMan-com.tex14
-rw-r--r--doc/refman/RefMan-ltac.tex10
-rw-r--r--doc/refman/RefMan-pro.tex8
-rw-r--r--doc/refman/RefMan-sch.tex2
-rw-r--r--doc/refman/RefMan-tac.tex12
-rw-r--r--doc/stdlib/index-list.html.template1
-rw-r--r--engine/evarutil.ml6
-rw-r--r--engine/evd.ml148
-rw-r--r--engine/evd.mli56
-rw-r--r--engine/namegen.ml57
-rw-r--r--engine/namegen.mli7
-rw-r--r--engine/proofview.ml22
-rw-r--r--engine/proofview.mli12
-rw-r--r--engine/termops.ml3
-rw-r--r--engine/uState.ml12
-rw-r--r--engine/uState.mli5
-rw-r--r--grammar/tacextend.mlp142
-rw-r--r--grammar/vernacextend.mlp16
-rw-r--r--interp/constrintern.ml2
-rw-r--r--interp/modintern.ml23
-rw-r--r--intf/constrexpr.ml11
-rw-r--r--intf/extend.ml9
-rw-r--r--intf/vernacexpr.ml16
-rw-r--r--kernel/cClosure.ml2
-rw-r--r--kernel/cClosure.mli2
-rw-r--r--kernel/environ.mli2
-rw-r--r--kernel/inductive.ml3
-rw-r--r--kernel/reduction.ml5
-rw-r--r--kernel/uGraph.mli2
-rw-r--r--lib/coqProject_file.ml487
-rw-r--r--lib/coqProject_file.mli42
-rw-r--r--lib/genarg.ml13
-rw-r--r--lib/genarg.mli3
-rw-r--r--lib/lib.mllib1
-rw-r--r--library/summary.ml12
-rw-r--r--man/coqdep.13
-rw-r--r--parsing/g_proofs.ml430
-rw-r--r--parsing/g_vernac.ml48
-rw-r--r--parsing/pcoq.ml1
-rw-r--r--parsing/pcoq.mli1
-rw-r--r--plugins/extraction/ExtrOcamlNatBigInt.v2
-rw-r--r--plugins/extraction/ExtrOcamlNatInt.v2
-rw-r--r--plugins/extraction/extract_env.ml60
-rw-r--r--plugins/extraction/extract_env.mli7
-rw-r--r--plugins/extraction/extraction.ml482
-rw-r--r--plugins/extraction/extraction.mli12
-rw-r--r--plugins/extraction/g_extraction.ml46
-rw-r--r--plugins/extraction/table.ml7
-rw-r--r--plugins/ltac/g_eqdecide.ml41
-rw-r--r--plugins/ltac/rewrite.ml2
-rw-r--r--plugins/ltac/taccoerce.ml76
-rw-r--r--plugins/ltac/taccoerce.mli19
-rw-r--r--plugins/ltac/tacentries.ml135
-rw-r--r--plugins/ltac/tacentries.mli12
-rw-r--r--plugins/ltac/tacinterp.ml98
-rw-r--r--plugins/ltac/tacinterp.mli8
-rw-r--r--plugins/ltac/tauto.ml22
-rw-r--r--plugins/micromega/RingMicromega.v3
-rw-r--r--plugins/nsatz/Nsatz.v6
-rw-r--r--plugins/nsatz/g_nsatz.ml41
-rw-r--r--plugins/romega/const_omega.ml175
-rw-r--r--plugins/romega/const_omega.mli155
-rw-r--r--plugins/romega/refl_omega.ml148
-rw-r--r--plugins/rtauto/Rtauto.v229
-rw-r--r--plugins/ssr/ssrast.mli12
-rw-r--r--plugins/ssr/ssrbwd.mli2
-rw-r--r--plugins/ssr/ssrcommon.ml14
-rw-r--r--plugins/ssr/ssrcommon.mli2
-rw-r--r--plugins/ssr/ssrelim.ml2
-rw-r--r--plugins/ssr/ssrequality.ml16
-rw-r--r--plugins/ssr/ssrfun.v5
-rw-r--r--plugins/ssr/ssripats.mli6
-rw-r--r--plugins/ssr/ssrparser.ml46
-rw-r--r--plugins/ssr/ssrparser.mli13
-rw-r--r--plugins/ssr/ssrtacticals.ml4
-rw-r--r--plugins/ssr/ssrvernac.ml46
-rw-r--r--plugins/ssrmatching/ssrmatching.ml48
-rw-r--r--plugins/ssrmatching/ssrmatching.mli2
-rw-r--r--pretyping/evarconv.ml11
-rw-r--r--pretyping/reductionops.mli2
-rw-r--r--pretyping/unification.ml24
-rw-r--r--pretyping/univdecls.ml2
-rw-r--r--pretyping/univdecls.mli4
-rw-r--r--printing/ppvernac.ml4
-rw-r--r--printing/prettyp.ml4
-rw-r--r--printing/printer.ml44
-rw-r--r--printing/printer.mli8
-rw-r--r--printing/printmod.ml4
-rw-r--r--proofs/goal.ml5
-rw-r--r--proofs/pfedit.ml16
-rw-r--r--proofs/proof.ml6
-rw-r--r--proofs/proof_global.ml5
-rw-r--r--proofs/refine.ml20
-rw-r--r--stm/stm.ml2
-rw-r--r--tactics/auto.ml14
-rw-r--r--tactics/class_tactics.ml416
-rw-r--r--tactics/eqschemes.ml12
-rw-r--r--tactics/equality.ml32
-rw-r--r--tactics/hipattern.ml4
-rw-r--r--tactics/ind_tables.ml4
-rw-r--r--tactics/leminv.ml2
-rw-r--r--tactics/tactics.ml107
-rw-r--r--test-suite/bugs/closed/2245.v11
-rw-r--r--test-suite/bugs/closed/2378.v2
-rw-r--r--test-suite/bugs/closed/3481.v4
-rw-r--r--test-suite/bugs/closed/3513.v20
-rw-r--r--test-suite/bugs/closed/3520.v2
-rw-r--r--test-suite/bugs/closed/3662.v2
-rw-r--r--test-suite/bugs/closed/6313.v64
-rw-r--r--test-suite/bugs/closed/6634.v6
-rw-r--r--test-suite/bugs/closed/6910.v5
-rw-r--r--test-suite/bugs/closed/HoTT_coq_077.v2
-rw-r--r--test-suite/bugs/closed/HoTT_coq_104.v2
-rw-r--r--test-suite/bugs/opened/1596.v1
-rw-r--r--test-suite/bugs/opened/3926.v30
-rw-r--r--test-suite/failure/fixpointeta.v70
-rw-r--r--test-suite/micromega/square.v6
-rw-r--r--test-suite/modules/WithDefUBinders.v15
-rw-r--r--test-suite/output/Arguments_renaming.out2
-rw-r--r--test-suite/output/Existentials.out6
-rw-r--r--test-suite/output/Notations3.out8
-rw-r--r--test-suite/output/inference.out8
-rw-r--r--test-suite/success/Hints.v11
-rw-r--r--test-suite/success/Inductive.v6
-rw-r--r--test-suite/success/ShowExtraction.v31
-rw-r--r--test-suite/success/cumulativity.v21
-rw-r--r--test-suite/success/letproj.v2
-rw-r--r--test-suite/success/name_mangling.v192
-rw-r--r--test-suite/success/old_typeclass.v13
-rw-r--r--test-suite/success/primitiveproj.v2
-rw-r--r--test-suite/success/shrink_abstract.v2
-rw-r--r--theories/Compat/Coq87.v1
-rw-r--r--theories/Compat/Coq88.v11
-rw-r--r--theories/Init/Notations.v1
-rw-r--r--theories/Init/Peano.v4
-rw-r--r--theories/Init/Specif.v1
-rw-r--r--theories/Logic/ChoiceFacts.v4
-rw-r--r--theories/QArith/QArith_base.v46
-rw-r--r--theories/QArith/Qabs.v8
-rw-r--r--theories/QArith/Qcanon.v4
-rw-r--r--theories/QArith/Qpower.v4
-rw-r--r--theories/QArith/Qreals.v4
-rw-r--r--theories/QArith/Qreduction.v14
-rw-r--r--theories/QArith/Qround.v12
-rw-r--r--theories/Reals/Ranalysis5.v62
-rw-r--r--theories/Sets/Multiset.v4
-rw-r--r--theories/Sets/Uniset.v4
-rw-r--r--theories/Sorting/Heap.v2
-rw-r--r--theories/Strings/String.v12
-rw-r--r--tools/CoqMakefile.in9
-rw-r--r--tools/coq_makefile.ml71
-rw-r--r--tools/coqc.ml2
-rw-r--r--tools/coqdep.ml19
-rw-r--r--toplevel/coqargs.ml8
-rw-r--r--toplevel/coqloop.ml20
-rw-r--r--toplevel/usage.ml1
-rw-r--r--toplevel/vernac.ml33
-rw-r--r--vernac/auto_ind_decl.ml8
-rw-r--r--vernac/classes.ml36
-rw-r--r--vernac/comAssumption.ml2
-rw-r--r--vernac/comAssumption.mli2
-rw-r--r--vernac/comDefinition.ml2
-rw-r--r--vernac/comDefinition.mli4
-rw-r--r--vernac/comFixpoint.ml1
-rw-r--r--vernac/comFixpoint.mli2
-rw-r--r--vernac/comInductive.ml2
-rw-r--r--vernac/comInductive.mli2
-rw-r--r--vernac/himsg.ml2
-rw-r--r--vernac/indschemes.ml9
-rw-r--r--vernac/obligations.ml2
-rw-r--r--vernac/record.ml2
-rw-r--r--vernac/vernacentries.ml13
196 files changed, 2769 insertions, 2349 deletions
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml
index 5dd376079..04b75bfdf 100644
--- a/.gitlab-ci.yml
+++ b/.gitlab-ci.yml
@@ -26,7 +26,7 @@ variables:
COQIDE_PACKAGES: "libgtk2.0-dev libgtksourceview2.0-dev"
#COQIDE_PACKAGES_32BIT: "libgtk2.0-dev:i386 libgtksourceview2.0-dev:i386"
COQIDE_OPAM: "lablgtk-extras"
- COQIDE_OPAM_BE: "num lablgtk.2.18.6 lablgtk-extras.1.6"
+ COQIDE_OPAM_BE: "lablgtk.2.18.6 lablgtk-extras.1.6"
COQDOC_PACKAGES: "texlive-latex-base texlive-latex-recommended texlive-latex-extra texlive-math-extra texlive-fonts-recommended texlive-fonts-extra latex-xcolor ghostscript transfig imagemagick tipa"
COQDOC_OPAM: "hevea"
@@ -49,7 +49,7 @@ before_script:
- opam switch ${COMPILER}
- eval $(opam config env)
- opam config list
- - opam install -j ${NJOBS} -y camlp5.${CAMLP5_VER} ocamlfind ${EXTRA_OPAM}
+ - opam install -j ${NJOBS} -y camlp5.${CAMLP5_VER} ocamlfind num ${EXTRA_OPAM}
- rm -rf ~/.opam/log/
- opam list
diff --git a/.travis.yml b/.travis.yml
index 9ec936b0c..1699568ca 100644
--- a/.travis.yml
+++ b/.travis.yml
@@ -190,7 +190,7 @@ matrix:
# Ocaml warnings with two compilers
- env:
- MAIN_TARGET="coqocaml"
- - EXTRA_CONF="-byte-only -coqide byte -warn-error"
+ - EXTRA_CONF="-byte-only -coqide byte -warn-error yes"
- EXTRA_OPAM="hevea ${LABLGTK}"
# dummy target
- BUILD_TARGET="clean"
@@ -209,7 +209,7 @@ matrix:
- COMPILER="${COMPILER_BE}"
- FINDLIB_VER="${FINDLIB_VER_BE}"
- CAMLP5_VER="${CAMLP5_VER_BE}"
- - EXTRA_CONF="-byte-only -coqide byte -warn-error"
+ - EXTRA_CONF="-byte-only -coqide byte -warn-error yes"
- EXTRA_OPAM="num hevea ${LABLGTK_BE}"
# dummy target
- BUILD_TARGET="clean"
@@ -239,11 +239,12 @@ matrix:
- CAMLP5_VER=".6.17"
- NATIVE_COMP="no"
- COQ_DEST="-prefix ${PWD}/_install"
- - EXTRA_CONF="-coqide opt -warn-error"
+ - EXTRA_CONF="-coqide opt -warn-error yes"
- EXTRA_OPAM="${LABLGTK}"
before_install:
- brew update
- - brew install opam gnu-time gtk+ expat gtksourceview libxml2 gdk-pixbuf python3
+ - brew install opam gnu-time gtk+ expat gtksourceview gdk-pixbuf
+ - brew upgrade python
- pip3 install macpack
before_deploy:
- dev/build/osx/make-macos-dmg.sh
diff --git a/CHANGES b/CHANGES
index 466b4cde5..1c7c53f29 100644
--- a/CHANGES
+++ b/CHANGES
@@ -63,6 +63,7 @@ Focusing
- Focusing bracket `{` now supports single-numbered goal selector,
e.g. `2: {` will focus on the second sub-goal. As usual, unfocus
with `}` once the sub-goal is fully solved.
+ The `Focus` and `Unfocus` commands are now deprecated.
Vernacular Commands
@@ -73,6 +74,9 @@ Vernacular Commands
was removed. Use Local as a prefix instead.
- For the Extraction Language command, "OCaml" is spelled correctly.
The older "Ocaml" is still accepted, but deprecated.
+- Using “Require” inside a section is deprecated.
+- An experimental command "Show Extraction" allows to extract the content
+ of the current ongoing proof (grant wish #4129).
Universes
@@ -86,6 +90,15 @@ Universes
more information.
- Fix #5726: Notations that start with `Type` now support universe instances
with `@{u}`.
+- `with Definition` now understands universe declarations
+ (like `@{u| Set < u}`).
+
+Tools
+
+- Coq can now be run with the option -mangle-names to change the auto-generated
+ name scheme. This is intended to function as a linter for developments that
+ want to be robust to changes in auto-generated names. This feature is experimental,
+ and may change or dissapear without warning.
Checker
@@ -96,6 +109,12 @@ CoqIDE
- Find and Replace All report the number of occurrences found; Find indicates
when it wraps.
+coqdep
+
+- Learned to read -I, -Q, -R and filenames from _CoqProject files.
+ This is used by coq_makefile when generating dependencies for .v
+ files (but not other files).
+
Documentation
- The Coq FAQ, formerly located at https://coq.inria.fr/faq, has been
@@ -110,6 +129,8 @@ Standard Library
Coq.Numbers.DecimalString providing a type of decimal numbers, some
facts about them, and conversions between decimal numbers and nat,
positive, N, Z, and string.
+- Added [Coq.Strings.String.concat] to concatenate a list of strings
+ inserting a separator between each item
- Some deprecated aliases are now emitting warnings when used.
@@ -268,6 +289,7 @@ Standard Library
lemmas such as INR_IZR_INZ should be used instead.
- Real constants are now represented using IZR rather than R0 and R1;
this might cause rewriting rules to fail to apply to constants.
+- Added new notation {x & P} for sigT (without a type for x)
Plugins
diff --git a/Makefile.doc b/Makefile.doc
index 894ef9a99..9fd93651d 100644
--- a/Makefile.doc
+++ b/Makefile.doc
@@ -387,10 +387,10 @@ install-doc-index-urls:
OCAMLDOCDIR=dev/ocamldoc
-DOCMLIS=$(wildcard ./lib/*.mli ./intf/*.mli ./kernel/*.mli ./library/*.mli \
- ./engine/*.mli ./pretyping/*.mli ./interp/*.mli printing/*.mli \
- ./parsing/*.mli ./proofs/*.mli \
- ./tactics/*.mli ./stm/*.mli ./toplevel/*.mli ./ltac/*.mli)
+DOCMLLIBS= $(CORECMA:.cma=_MLLIB_DEPENDENCIES) $(PLUGINSCMO:.cmo=_MLPACK_DEPENDENCIES)
+DOCMLS=$(foreach lib,$(DOCMLLIBS),$(addsuffix .ml, $($(lib))))
+
+DOCMLIS=$(wildcard $(addsuffix /*.mli, $(SRCDIRS)))
# Defining options to generate dependencies graphs
DOT=dot
@@ -434,7 +434,12 @@ OCAMLDOC_MLLIBD = $(OCAMLFIND) ocamldoc -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -
$(OCAMLDOC_MLLIBD)
ml-doc:
- $(OCAMLFIND) ocamldoc -charset utf-8 -html -rectypes -I +threads $(MLINCLUDES) $(COQIDEFLAGS) -d $(OCAMLDOCDIR) $(MLSTATICFILES)
+ $(SHOW)'OCAMLDOC -html'
+ $(HIDE)mkdir -p $(OCAMLDOCDIR)/html/implementation
+ $(HIDE)$(OCAMLFIND) ocamldoc -charset utf-8 -html -rectypes -I +threads $(MLINCLUDES) $(COQIDEFLAGS) \
+ $(DOCMLS) -d $(OCAMLDOCDIR)/html/implementation -colorize-code \
+ -t "Coq mls documentation" \
+ -css-style ../style.css
parsing/parsing.dot : | parsing/parsing.mllib.d
$(OCAMLDOC_MLLIBD)
diff --git a/appveyor.yml b/appveyor.yml
index 64c1bedb5..44a93d15d 100644
--- a/appveyor.yml
+++ b/appveyor.yml
@@ -10,12 +10,12 @@ image:
environment:
CYGMIRROR: http://ftp.inf.tu-dresden.de/software/windows/cygwin32
matrix:
- - USEOPAM: true
- ARCH: 64
- USEOPAM: false
ARCH: 32
- USEOPAM: false
ARCH: 64
+ - USEOPAM: true
+ ARCH: 64
build_script:
- cmd: 'call %APPVEYOR_BUILD_FOLDER%\dev\ci\appveyor.bat'
diff --git a/checker/checker.ml b/checker/checker.ml
index b2aeb1f14..fd2725c85 100644
--- a/checker/checker.ml
+++ b/checker/checker.ml
@@ -17,10 +17,10 @@ open Check
let () = at_exit flush_all
-let chk_pp = Pp.pp_with Format.std_formatter
+let pp_arrayi pp fmt a = Array.iteri (fun i x -> pp fmt (i,x)) a
let fatal_error info anomaly =
- flush_all (); Format.eprintf "@[Fatal Error: @[%a@]@]%!@\n" Pp.pp_with info; flush_all ();
+ flush_all (); Format.eprintf "@[Fatal Error: @[%a@]@]@\n%!" Pp.pp_with info; flush_all ();
exit (if anomaly then 129 else 1)
let coq_root = Id.of_string "Coq"
@@ -269,26 +269,26 @@ let explain_exn = function
| Generalization _ -> str"Generalization"
| ActualType _ -> str"ActualType"
| CantApplyBadType ((n,a,b),(hd,hdty),args) ->
- Format.printf "====== ill-typed term ====@\n";
- Format.printf "@[<hov 2>application head=@ ";
- Print.print_pure_constr hd;
- Format.printf "@]@\n@[<hov 2>head type=@ ";
- Print.print_pure_constr hdty;
- Format.printf "@]@\narguments:@\n@[<hv>";
- Array.iteri (fun i (t,ty) ->
- Format.printf "@[<hov 2>arg %d=@ " (i+1);
- Print.print_pure_constr t;
- Format.printf "@ type=@ ";
- Print.print_pure_constr ty) args;
- Format.printf "@]@\n====== type error ====@\n";
- Print.print_pure_constr b;
- Format.printf "@\nis not convertible with@\n";
- Print.print_pure_constr a;
- Format.printf "@\n====== universes ====@\n";
- chk_pp
- (Univ.pr_universes
- (ctx.Environ.env_stratification.Environ.env_universes));
- str "\nCantApplyBadType at argument " ++ int n
+ (* This mix of printf / pp was here before... *)
+ let fmt = Format.std_formatter in
+ let open Format in
+ let open Print in
+ fprintf fmt "====== ill-typed term ====@\n";
+ fprintf fmt "@[<hov 2>application head=@ %a@]@\n" print_pure_constr hd;
+ fprintf fmt "@[<hov 2>head type=@ %a@]@\n" print_pure_constr hdty;
+ let pp_arg fmt (i,(t,ty)) = fprintf fmt "@[<hv>@[<1>arg %d=@ @[%a@]@]@,@[<1>type=@ @[%a@]@]@]@\n@," (i+1)
+ print_pure_constr t print_pure_constr ty
+ in
+ fprintf fmt "arguments:@\n@[<hv>%a@]@\n" (pp_arrayi pp_arg) args;
+ fprintf fmt "====== type error ====@\n";
+ fprintf fmt "%a@\n" print_pure_constr b;
+ fprintf fmt "is not convertible with@\n";
+ fprintf fmt "%a@\n" print_pure_constr a;
+ fprintf fmt "====== universes ====@\n";
+ fprintf fmt "%a@\n%!" Pp.pp_with
+ (Univ.pr_universes
+ (ctx.Environ.env_stratification.Environ.env_universes));
+ str "CantApplyBadType at argument " ++ int n
| CantApplyNonFunctional _ -> str"CantApplyNonFunctional"
| IllFormedRecBody _ -> str"IllFormedRecBody"
| IllTypedRecBody _ -> str"IllTypedRecBody"
diff --git a/checker/print.ml b/checker/print.ml
index c1fa8f94c..fc9cd687e 100644
--- a/checker/print.ml
+++ b/checker/print.ml
@@ -12,137 +12,85 @@ open Format
open Cic
open Names
-let chk_pp = Pp.pp_with Format.std_formatter
+let chk_pp fmt = Pp.pp_with fmt
+let pp_arrayi pp fmt a = Array.iteri (fun i x -> pp fmt (i,x)) a
+let pp_instance fmt i = chk_pp fmt (Univ.Instance.pr i)
+let pp_id fmt id = fprintf fmt "%s" (Id.to_string id)
-let print_instance i = chk_pp (Univ.Instance.pr i)
-
-let print_pure_constr csr =
- let rec term_display c = match c with
- | Rel n -> print_string "#"; print_int n
- | Meta n -> print_string "Meta("; print_int n; print_string ")"
- | Var id -> print_string (Id.to_string id)
- | Sort s -> sort_display s
- | Cast (c,_, t) -> open_hovbox 1;
- print_string "("; (term_display c); print_cut();
- print_string "::"; (term_display t); print_string ")"; close_box()
+let print_pure_constr fmt csr =
+ let rec pp_term fmt c = match c with
+ | Rel n -> fprintf fmt "#%d" n
+ | Meta n -> fprintf fmt "Meta(%d)" n
+ | Var id -> pp_id fmt id
+ | Sort s -> pp_sort fmt s
+ | Cast (c,_, t) ->
+ fprintf fmt "@[<hov 1>(%a@;::%a)@]" pp_term c pp_term t
| Prod (Name(id),t,c) ->
- open_hovbox 1;
- print_string"("; print_string (Id.to_string id);
- print_string ":"; box_display t;
- print_string ")"; print_cut();
- box_display c; close_box()
+ fprintf fmt "@[<hov 1>(%a:%a)@;@[%a@]@]" pp_id id pp_term t pp_term c
| Prod (Anonymous,t,c) ->
- print_string"("; box_display t; print_cut(); print_string "->";
- box_display c; print_string ")";
+ fprintf fmt "(%a@,->@[%a@])" pp_term t pp_term c
| Lambda (na,t,c) ->
- print_string "["; name_display na;
- print_string ":"; box_display t; print_string "]";
- print_cut(); box_display c;
+ fprintf fmt "[%a:@[%a@]]@,@[%a@]" pp_name na pp_term t pp_term c
| LetIn (na,b,t,c) ->
- print_string "["; name_display na; print_string "=";
- box_display b; print_cut();
- print_string ":"; box_display t; print_string "]";
- print_cut(); box_display c;
+ fprintf fmt "[%a=@[%a@]@,:@[%a@]]@,@[%a@]" pp_name na pp_term b pp_term t pp_term c
| App (c,l) ->
- print_string "(";
- box_display c;
- Array.iter (fun x -> print_space (); box_display x) l;
- print_string ")"
- | Evar _ -> print_string "Evar#"
- | Const (c,u) -> print_string "Cons(";
- sp_con_display c;
- print_string ","; print_instance u;
- print_string ")"
+ fprintf fmt "(@[%a@]@, @[<hov 1>%a@])" pp_term c (pp_arrayi (fun _ (_,s) -> fprintf fmt "@[%a@]@," pp_term s)) l;
+ | Evar _ -> pp_print_string fmt "Evar#"
+ | Const (c,u) ->
+ fprintf fmt "Cons(@[%a,%a@])" sp_con_display c pp_instance u
| Ind ((sp,i),u) ->
- print_string "Ind(";
- sp_display sp;
- print_string ","; print_int i;
- print_string ","; print_instance u;
- print_string ")"
+ fprintf fmt "Ind(@[%a,%d,%a@])" sp_display sp i pp_instance u
| Construct (((sp,i),j),u) ->
- print_string "Constr(";
- sp_display sp;
- print_string ",";
- print_int i; print_string ","; print_int j;
- print_string ","; print_instance u; print_string ")"
+ fprintf fmt "Constr(%a,%d,%d,%a)" sp_display sp i j pp_instance u
| Case (ci,p,c,bl) ->
- open_vbox 0;
- print_string "<"; box_display p; print_string ">";
- print_cut(); print_string "Case";
- print_space(); box_display c; print_space (); print_string "of";
- open_vbox 0;
- Array.iter (fun x -> print_cut(); box_display x) bl;
- close_box();
- print_cut();
- print_string "end";
- close_box()
+ let pp_match fmt (_,mc) = fprintf fmt " @[%a@]" pp_term mc in
+ fprintf fmt "@[<v><@[%a@]>@,Case@ @[%a@]@ of@[<v>%a@]@,end@]" pp_term p pp_term c (pp_arrayi pp_match) bl
| Fix ((t,i),(lna,tl,bl)) ->
- print_string "Fix("; print_int i; print_string ")";
- print_cut();
- open_vbox 0;
- let print_fix () =
- for k = 0 to (Array.length tl) - 1 do
- open_vbox 0;
- name_display lna.(k); print_string "/";
- print_int t.(k); print_cut(); print_string ":";
- box_display tl.(k) ; print_cut(); print_string ":=";
- box_display bl.(k); close_box ();
- print_cut()
- done
- in print_string"{"; print_fix(); print_string"}"
+ let pp_fixc fmt (k,_) =
+ fprintf fmt "@[<v 0> %a/%d@,:@[%a@]@,:=@[%a@]@]@," pp_name lna.(k) t.(k) pp_term tl.(k) pp_term bl.(k) in
+ fprintf fmt "Fix(%d)@,@[<v>{%a}@]" i (pp_arrayi pp_fixc) tl
| CoFix(i,(lna,tl,bl)) ->
- print_string "CoFix("; print_int i; print_string ")";
- print_cut();
- open_vbox 0;
- let print_fix () =
- for k = 0 to (Array.length tl) - 1 do
- open_vbox 1;
- name_display lna.(k); print_cut(); print_string ":";
- box_display tl.(k) ; print_cut(); print_string ":=";
- box_display bl.(k); close_box ();
- print_cut();
- done
- in print_string"{"; print_fix (); print_string"}"
+ let pp_fixc fmt (k,_) =
+ fprintf fmt "@[<v 0> %a@,:@[%a@]@,:=@[%a@]@]@," pp_name lna.(k) pp_term tl.(k) pp_term bl.(k) in
+ fprintf fmt "CoFix(%d)@,@[<v>{%a}@]" i (pp_arrayi pp_fixc) tl
| Proj (p, c) ->
- print_string "Proj("; sp_con_display (Projection.constant p); print_string ",";
- box_display c; print_string ")"
+ fprintf fmt "Proj(%a,@,@[%a@])" sp_con_display (Projection.constant p) pp_term c
- and box_display c = open_hovbox 1; term_display c; close_box()
+ and pp_sort fmt = function
+ | Prop(Pos) -> pp_print_string fmt "Set"
+ | Prop(Null) -> pp_print_string fmt "Prop"
+ | Type u -> fprintf fmt "Type(%a)" chk_pp (Univ.pr_uni u)
- and sort_display = function
- | Prop(Pos) -> print_string "Set"
- | Prop(Null) -> print_string "Prop"
- | Type u -> print_string "Type("; chk_pp (Univ.pr_uni u); print_string ")"
+ and pp_name fmt = function
+ | Name id -> pp_id fmt id
+ | Anonymous -> pp_print_string fmt "_"
- and name_display = function
- | Name id -> print_string (Id.to_string id)
- | Anonymous -> print_string "_"
(* Remove the top names for library and Scratch to avoid long names *)
- and sp_display sp =
-(* let dir,l = decode_kn sp in
+ and sp_display fmt sp =
+(* let dir,l = decode_kn sp in
let ls =
match List.rev_map Id.to_string (DirPath.repr dir) with
("Top"::l)-> l
| ("Coq"::_::l) -> l
| l -> l
in List.iter (fun x -> print_string x; print_string ".") ls;*)
- print_string (MutInd.debug_to_string sp)
- and sp_con_display sp =
-(* let dir,l = decode_kn sp in
+ pp_print_string fmt (MutInd.debug_to_string sp)
+
+ and sp_con_display fmt sp =
+ (*
+ let dir,l = decode_kn sp in
let ls =
match List.rev_map Id.to_string (DirPath.repr dir) with
("Top"::l)-> l
| ("Coq"::_::l) -> l
| l -> l
in List.iter (fun x -> print_string x; print_string ".") ls;*)
- print_string (Constant.debug_to_string sp)
+ pp_print_string fmt (Constant.debug_to_string sp)
in
- try
- box_display csr; print_flush()
- with e ->
- print_string (Printexc.to_string e);print_flush ();
- raise e
-
-
-
+ try
+ fprintf fmt "@[%a@]%!" pp_term csr
+ with e ->
+ pp_print_string fmt (Printexc.to_string e);
+ print_flush ();
+ raise e
diff --git a/checker/print.mli b/checker/print.mli
index 67562125f..da1362ca5 100644
--- a/checker/print.mli
+++ b/checker/print.mli
@@ -10,4 +10,4 @@
open Cic
-val print_pure_constr : constr -> unit
+val print_pure_constr : Format.formatter -> constr -> unit
diff --git a/checker/reduction.ml b/checker/reduction.ml
index 67d00b21d..97255dd49 100644
--- a/checker/reduction.ml
+++ b/checker/reduction.ml
@@ -201,7 +201,9 @@ let convert_constructors
if not (num_cnstr_args = sv1 && num_cnstr_args = sv2) then
convert_universes univs u1 u2
else
- convert_inductive_instances CONV cumi u1 u2 univs
+ (** By invariant, both constructors have a common supertype,
+ so they are convertible _at that type_. *)
+ ()
(* Convertibility of sorts *)
diff --git a/checker/univ.mli b/checker/univ.mli
index 3876e7bbc..935f0a2b8 100644
--- a/checker/univ.mli
+++ b/checker/univ.mli
@@ -84,7 +84,7 @@ val check_eq : universe check_function
val initial_universes : universes
(** Adds a universe to the graph, ensuring it is >= or > Set.
- @raises AlreadyDeclared if the level is already declared in the graph. *)
+ @raise AlreadyDeclared if the level is already declared in the graph. *)
exception AlreadyDeclared
diff --git a/clib/option.ml b/clib/option.ml
index c2e2e7097..32fe2fc5f 100644
--- a/clib/option.ml
+++ b/clib/option.ml
@@ -44,7 +44,7 @@ let hash f = function
exception IsNone
(** [get x] returns [y] where [x] is [Some y].
- @raise [IsNone] if [x] equals [None]. *)
+ @raise IsNone if [x] equals [None]. *)
let get = function
| Some y -> y
| _ -> raise IsNone
@@ -52,6 +52,9 @@ let get = function
(** [make x] returns [Some x]. *)
let make x = Some x
+(** [bind x f] is [f y] if [x] is [Some y] and [None] otherwise *)
+let bind x f = match x with Some y -> f y | None -> None
+
(** [init b x] returns [Some x] if [b] is [true] and [None] otherwise. *)
let init b x =
if b then
diff --git a/clib/option.mli b/clib/option.mli
index 226099352..67b42268a 100644
--- a/clib/option.mli
+++ b/clib/option.mli
@@ -43,6 +43,9 @@ val get : 'a option -> 'a
(** [make x] returns [Some x]. *)
val make : 'a -> 'a option
+(** [bind x f] is [f y] if [x] is [Some y] and [None] otherwise *)
+val bind : 'a option -> ('a -> 'b option) -> 'b option
+
(** [init b x] returns [Some x] if [b] is [true] and [None] otherwise. *)
val init : bool -> 'a -> 'a option
diff --git a/configure.ml b/configure.ml
index 69db9407a..1eae3bd93 100644
--- a/configure.ml
+++ b/configure.ml
@@ -22,8 +22,10 @@ let distributed_exec = ["coqtop";"coqc";"coqchk";"coqdoc";"coqworkmgr";
let verbose = ref false (* for debugging this script *)
(** * Utility functions *)
-
-let die msg = eprintf "%s\nConfiguration script failed!\n" msg; exit 1
+let cfprintf oc = kfprintf (fun oc -> fprintf oc "\n%!") oc
+let cprintf s = cfprintf stdout s
+let ceprintf s = cfprintf stderr s
+let die msg = ceprintf "%s\nConfiguration script failed!" msg; exit 1
let s2i = int_of_string
let i2s = string_of_int
@@ -107,7 +109,7 @@ let run ?(fatal=true) ?(err=StdErr) prog args =
let cmd = String.concat " " (prog::args) in
let exn = match e with Failure s -> s | _ -> Printexc.to_string e in
let msg = sprintf "Error while running '%s' (%s)" cmd exn in
- if fatal then die msg else (printf "W: %s\n" msg; "", [])
+ if fatal then die msg else (cprintf "W: %s" msg; "", [])
let tryrun prog args = run ~fatal:false ~err:DevNull prog args
@@ -203,7 +205,7 @@ let win_aware_quote_executable str =
sprintf "%S" str
else
let _ = if contains_suspicious_characters str then
- printf "*Warning* The string %S contains suspicious characters; ocamlfind might fail\n" str in
+ cprintf "*Warning* The string %S contains suspicious characters; ocamlfind might fail" str in
Str.global_replace (Str.regexp "\\\\") "/" str
(** * Date *)
@@ -235,6 +237,101 @@ let _ = if not (dir_exists "bin") then Unix.mkdir "bin" 0o755
type ide = Opt | Byte | No
+type preferences = {
+ prefix : string option;
+ local : bool;
+ vmbyteflags : string option;
+ custom : bool option;
+ bindir : string option;
+ libdir : string option;
+ configdir : string option;
+ datadir : string option;
+ mandir : string option;
+ docdir : string option;
+ emacslib : string option;
+ coqdocdir : string option;
+ ocamlfindcmd : string option;
+ lablgtkdir : string option;
+ camlp5dir : string option;
+ arch : string option;
+ natdynlink : bool;
+ coqide : ide option;
+ macintegration : bool;
+ browser : string option;
+ withdoc : bool;
+ byteonly : bool;
+ flambda_flags : string list;
+ debug : bool;
+ profile : bool;
+ bin_annot : bool;
+ annot : bool;
+ bytecodecompiler : bool;
+ nativecompiler : bool;
+ coqwebsite : string;
+ force_caml_version : bool;
+ force_findlib_version : bool;
+ warn_error : bool;
+}
+
+module Profiles = struct
+
+let default = {
+ prefix = None;
+ local = false;
+ vmbyteflags = None;
+ custom = None;
+ bindir = None;
+ libdir = None;
+ configdir = None;
+ datadir = None;
+ mandir = None;
+ docdir = None;
+ emacslib = None;
+ coqdocdir = None;
+ ocamlfindcmd = None;
+ lablgtkdir = None;
+ camlp5dir = None;
+ arch = None;
+ natdynlink = true;
+ coqide = None;
+ macintegration = true;
+ browser = None;
+ withdoc = false;
+ byteonly = false;
+ flambda_flags = [];
+ debug = true;
+ profile = false;
+ bin_annot = false;
+ annot = false;
+ bytecodecompiler = true;
+ nativecompiler = not (os_type_win32 || os_type_cygwin);
+ coqwebsite = "http://coq.inria.fr/";
+ force_caml_version = false;
+ force_findlib_version = false;
+ warn_error = false;
+}
+
+let devel state = { state with
+ local = true;
+ bin_annot = true;
+ annot = true;
+ warn_error = true;
+}
+let devel_doc = "-local -annot -bin-annot -warn-error yes"
+
+let get = function
+ | "devel" -> devel
+ | s -> raise (Arg.Bad ("profile name expected instead of "^s))
+
+let doc =
+ "<profile> Sets a bunch of flags. Supported profiles:
+ devel = " ^ devel_doc
+
+end
+
+let prefs = ref Profiles.default
+
+
let get_bool = function
| "true" | "yes" | "y" | "all" -> true
| "false" | "no" | "n" -> false
@@ -246,123 +343,99 @@ let get_ide = function
| "no" -> No
| s -> raise (Arg.Bad ("(opt|byte|no) argument expected instead of "^s))
-let arg_bool r = Arg.String (fun s -> r := get_bool s)
-
-let arg_string_option r = Arg.String (fun s -> r := Some s)
-
-module Prefs = struct
- let prefix = ref (None : string option)
- let local = ref false
- let vmbyteflags = ref (None : string option)
- let custom = ref (None : bool option)
- let bindir = ref (None : string option)
- let libdir = ref (None : string option)
- let configdir = ref (None : string option)
- let datadir = ref (None : string option)
- let mandir = ref (None : string option)
- let docdir = ref (None : string option)
- let emacslib = ref (None : string option)
- let coqdocdir = ref (None : string option)
- let ocamlfindcmd = ref (None : string option)
- let lablgtkdir = ref (None : string option)
- let camlp5dir = ref (None : string option)
- let arch = ref (None : string option)
- let natdynlink = ref true
- let coqide = ref (None : ide option)
- let macintegration = ref true
- let browser = ref (None : string option)
- let withdoc = ref false
- let byteonly = ref false
- let flambda_flags = ref []
- let debug = ref true
- let profile = ref false
- let bin_annot = ref false
- let annot = ref false
- let bytecodecompiler = ref true
- let nativecompiler = ref (not (os_type_win32 || os_type_cygwin))
- let coqwebsite = ref "http://coq.inria.fr/"
- let force_caml_version = ref false
- let force_findlib_version = ref false
- let warn_error = ref false
-end
+let arg_bool f = Arg.String (fun s -> prefs := f !prefs (get_bool s))
+
+let arg_string f = Arg.String (fun s -> prefs := f !prefs s)
+let arg_string_option f = Arg.String (fun s -> prefs := f !prefs (Some s))
+let arg_string_list c f = Arg.String (fun s -> prefs := f !prefs (string_split c s))
+
+let arg_set f = Arg.Unit (fun () -> prefs := f !prefs true)
+let arg_clear f = Arg.Unit (fun () -> prefs := f !prefs false)
+
+let arg_set_option f = Arg.Unit (fun () -> prefs := f !prefs (Some true))
+let arg_clear_option f = Arg.Unit (fun () -> prefs := f !prefs (Some false))
+
+let arg_ide f = Arg.String (fun s -> prefs := f !prefs (Some (get_ide s)))
+
+let arg_profile = Arg.String (fun s -> prefs := Profiles.get s !prefs)
(* TODO : earlier any option -foo was also available as --foo *)
let args_options = Arg.align [
- "-prefix", arg_string_option Prefs.prefix,
+ "-prefix", arg_string_option (fun p prefix -> { p with prefix }),
"<dir> Set installation directory to <dir>";
- "-local", Arg.Set Prefs.local,
+ "-local", arg_set (fun p local -> { p with local }),
" Set installation directory to the current source tree";
- "-vmbyteflags", arg_string_option Prefs.vmbyteflags,
+ "-vmbyteflags", arg_string_option (fun p vmbyteflags -> { p with vmbyteflags }),
"<flags> Comma-separated link flags for the VM of coqtop.byte";
- "-custom", Arg.Unit (fun () -> Prefs.custom := Some true),
+ "-custom", arg_set_option (fun p custom -> { p with custom }),
" Build bytecode executables with -custom (not recommended)";
- "-no-custom", Arg.Unit (fun () -> Prefs.custom := Some false),
+ "-no-custom", arg_clear_option (fun p custom -> { p with custom }),
" Do not build with -custom on Windows and MacOS";
- "-bindir", arg_string_option Prefs.bindir,
+ "-bindir", arg_string_option (fun p bindir -> { p with bindir }),
"<dir> Where to install bin files";
- "-libdir", arg_string_option Prefs.libdir,
+ "-libdir", arg_string_option (fun p libdir -> { p with libdir }),
"<dir> Where to install lib files";
- "-configdir", arg_string_option Prefs.configdir,
+ "-configdir", arg_string_option (fun p configdir -> { p with configdir }),
"<dir> Where to install config files";
- "-datadir", arg_string_option Prefs.datadir,
+ "-datadir", arg_string_option (fun p datadir -> { p with datadir }),
"<dir> Where to install data files";
- "-mandir", arg_string_option Prefs.mandir,
+ "-mandir", arg_string_option (fun p mandir -> { p with mandir }),
"<dir> Where to install man files";
- "-docdir", arg_string_option Prefs.docdir,
+ "-docdir", arg_string_option (fun p docdir -> { p with docdir }),
"<dir> Where to install doc files";
- "-emacslib", arg_string_option Prefs.emacslib,
+ "-emacslib", arg_string_option (fun p emacslib -> { p with emacslib }),
"<dir> Where to install emacs files";
- "-coqdocdir", arg_string_option Prefs.coqdocdir,
+ "-coqdocdir", arg_string_option (fun p coqdocdir -> { p with coqdocdir }),
"<dir> Where to install Coqdoc style files";
- "-ocamlfind", arg_string_option Prefs.ocamlfindcmd,
+ "-ocamlfind", arg_string_option (fun p ocamlfindcmd -> { p with ocamlfindcmd }),
"<dir> Specifies the ocamlfind command to use";
- "-lablgtkdir", arg_string_option Prefs.lablgtkdir,
+ "-lablgtkdir", arg_string_option (fun p lablgtkdir -> { p with lablgtkdir }),
"<dir> Specifies the path to the Lablgtk library";
- "-camlp5dir",
- Arg.String (fun s -> Prefs.camlp5dir:=Some s),
+ "-camlp5dir", arg_string_option (fun p camlp5dir -> { p with camlp5dir }),
"<dir> Specifies where is the Camlp5 library and tells to use it";
- "-flambda-opts",
- Arg.String (fun s -> Prefs.flambda_flags := string_split ' ' s),
+ "-flambda-opts", arg_string_list ' ' (fun p flambda_flags -> { p with flambda_flags }),
"<flags> Specifies additional flags to be passed to the flambda optimizing compiler";
- "-arch", arg_string_option Prefs.arch,
+ "-arch", arg_string_option (fun p arch -> { p with arch }),
"<arch> Specifies the architecture";
- "-natdynlink", arg_bool Prefs.natdynlink,
+ "-natdynlink", arg_bool (fun p natdynlink -> { p with natdynlink }),
"(yes|no) Use dynamic loading of native code or not";
- "-coqide", Arg.String (fun s -> Prefs.coqide := Some (get_ide s)),
+ "-coqide", arg_ide (fun p coqide -> { p with coqide }),
"(opt|byte|no) Specifies whether or not to compile CoqIDE";
- "-nomacintegration", Arg.Clear Prefs.macintegration,
+ "-nomacintegration", arg_clear (fun p macintegration -> { p with macintegration }),
" Do not try to build CoqIDE MacOS integration";
- "-browser", arg_string_option Prefs.browser,
+ "-browser", arg_string_option (fun p browser -> { p with browser }),
"<command> Use <command> to open URL %s";
- "-with-doc", arg_bool Prefs.withdoc,
+ "-with-doc", arg_bool (fun p withdoc -> { p with withdoc }),
"(yes|no) Compile the documentation or not";
- "-byte-only", Arg.Set Prefs.byteonly,
+ "-byte-only", arg_set (fun p byteonly -> { p with byteonly }),
" Compiles only bytecode version of Coq";
- "-nodebug", Arg.Clear Prefs.debug,
+ "-nodebug", arg_clear (fun p debug -> { p with debug }),
" Do not add debugging information in the Coq executables";
- "-profile", Arg.Set Prefs.profile,
+ "-profiling", arg_set (fun p profile -> { p with profile }),
" Add profiling information in the Coq executables";
- "-annotate", Arg.Unit (fun () -> printf "*Warning* -annotate is deprecated. Please use -annot or -bin-annot instead.\n"),
+ "-annotate", Arg.Unit (fun () -> cprintf "*Warning* -annotate is deprecated. Please use -annot or -bin-annot instead."),
" Deprecated. Please use -annot or -bin-annot instead";
- "-annot", Arg.Set Prefs.annot,
+ "-annot", arg_set (fun p annot -> { p with annot }),
" Dumps ml text annotation files while compiling Coq (e.g. for Tuareg)";
- "-bin-annot", Arg.Set Prefs.bin_annot,
+ "-bin-annot", arg_set (fun p bin_annot -> { p with bin_annot }),
" Dumps ml binary annotation files while compiling Coq (e.g. for Merlin)";
- "-bytecode-compiler", arg_bool Prefs.bytecodecompiler,
+ "-bytecode-compiler", arg_bool (fun p bytecodecompiler -> { p with bytecodecompiler }),
"(yes|no) Enable Coq's bytecode reduction machine (VM)";
- "-native-compiler", arg_bool Prefs.nativecompiler,
+ "-native-compiler", arg_bool (fun p nativecompiler -> { p with nativecompiler }),
"(yes|no) Compilation to native code for conversion and normalization";
- "-coqwebsite", Arg.Set_string Prefs.coqwebsite,
+ "-coqwebsite", arg_string (fun p coqwebsite -> { p with coqwebsite }),
" URL of the coq website";
- "-force-caml-version", Arg.Set Prefs.force_caml_version,
+ "-force-caml-version", arg_set (fun p force_caml_version -> { p with force_caml_version }),
" Force OCaml version";
- "-force-findlib-version", Arg.Set Prefs.force_findlib_version,
+ "-force-findlib-version", arg_set (fun p force_findlib_version -> { p with force_findlib_version }),
" Force findlib version";
- "-warn-error", Arg.Set Prefs.warn_error,
- " Make OCaml warnings into errors";
+ "-warn-error", arg_bool (fun p warn_error -> { p with warn_error }),
+ "(yes|no) Make OCaml warnings into errors (default no)";
"-camldir", Arg.String (fun _ -> ()),
"<dir> Specifies path to 'ocaml' for running configure script";
+ "-profile", arg_profile,
+ Profiles.doc
]
let parse_args () =
@@ -370,7 +443,7 @@ let parse_args () =
args_options
(fun s -> raise (Arg.Bad ("Unknown option: "^s)))
"Available options for configure are:";
- if !Prefs.local && !Prefs.prefix <> None then
+ if !prefs.local && !prefs.prefix <> None then
die "Options -prefix and -local are incompatible."
let _ = parse_args ()
@@ -391,10 +464,10 @@ let reset_caml_lex c o = c.lex <- o
let reset_caml_top c o = c.top <- o
let reset_caml_find c o = c.find <- o
-let coq_debug_flag = if !Prefs.debug then "-g" else ""
-let coq_profile_flag = if !Prefs.profile then "-p" else ""
-let coq_annot_flag = if !Prefs.annot then "-annot" else ""
-let coq_bin_annot_flag = if !Prefs.bin_annot then "-bin-annot" else ""
+let coq_debug_flag = if !prefs.debug then "-g" else ""
+let coq_profile_flag = if !prefs.profile then "-p" else ""
+let coq_annot_flag = if !prefs.annot then "-annot" else ""
+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. *)
@@ -412,8 +485,8 @@ let arch_progs =
("/usr/ucb/arch", []) ]
let query_arch () =
- printf "I can not automatically find the name of your architecture.\n";
- printf "Give me a name, please [win32 for Win95, Win98 or WinNT]: %!";
+ cprintf "I can not automatically find the name of your architecture.";
+ cprintf "Give me a name, please [win32 for Win95, Win98 or WinNT]: %!";
read_line ()
let rec try_archs = function
@@ -423,7 +496,7 @@ let rec try_archs = function
| _ :: rest -> try_archs rest
| [] -> query_arch ()
-let arch = match !Prefs.arch with
+let arch = match !prefs.arch with
| Some a -> a
| None ->
let arch,_ = tryrun "uname" ["-s"] in
@@ -455,7 +528,7 @@ let vcs =
let _ =
let f = ".git/hooks/pre-commit" in
if vcs = "git" && dir_exists ".git/hooks" && not (Sys.file_exists f) then begin
- printf "Creating pre-commit hook in %s\n" f;
+ cprintf "Creating pre-commit hook in %s" f;
let o = open_out f in
let pr s = fprintf o s in
pr "#!/bin/sh\n";
@@ -470,7 +543,7 @@ let _ =
(** * Browser command *)
let browser =
- match !Prefs.browser with
+ match !prefs.browser with
| Some b -> b
| None when arch_is_win32 -> "start %s"
| None when arch = "Darwin" -> "open %s"
@@ -479,7 +552,7 @@ let browser =
(** * OCaml programs *)
let camlbin, caml_version, camllib, findlib_version =
- let () = match !Prefs.ocamlfindcmd with
+ let () = match !prefs.ocamlfindcmd with
| Some cmd -> reset_caml_find camlexec cmd
| None ->
try reset_caml_find camlexec (which camlexec.find)
@@ -521,11 +594,11 @@ let caml_version_nums =
let check_caml_version () =
if caml_version_nums >= [4;2;1] then
- printf "You have OCaml %s. Good!\n" caml_version
+ cprintf "You have OCaml %s. Good!" caml_version
else
- let () = printf "Your version of OCaml is %s.\n" caml_version in
- if !Prefs.force_caml_version then
- printf "*Warning* Your version of OCaml is outdated.\n"
+ let () = cprintf "Your version of OCaml is %s." caml_version in
+ if !prefs.force_caml_version then
+ cprintf "*Warning* Your version of OCaml is outdated."
else
die "You need OCaml 4.02.1 or later."
@@ -543,11 +616,11 @@ let findlib_version_nums =
let check_findlib_version () =
if findlib_version_nums >= [1;4;1] then
- printf "You have OCamlfind %s. Good!\n" findlib_version
+ cprintf "You have OCamlfind %s. Good!" findlib_version
else
- let () = printf "Your version of OCamlfind is %s.\n" findlib_version in
- if !Prefs.force_findlib_version then
- printf "*Warning* Your version of OCamlfind is outdated.\n"
+ let () = cprintf "Your version of OCamlfind is %s." findlib_version in
+ if !prefs.force_findlib_version then
+ cprintf "*Warning* Your version of OCamlfind is outdated."
else
die "You need OCamlfind 1.4.1 or later."
@@ -571,7 +644,7 @@ let camltag = match caml_version_list with
*)
let coq_warnings = "-w +a-4-9-27-41-42-44-45-48-50"
let coq_warn_error =
- if !Prefs.warn_error
+ if !prefs.warn_error
then "-warn-error +a"
^ (if caml_version_nums > [4;2;3]
then "-56"
@@ -611,7 +684,7 @@ let which_camlp5 base =
(* TODO: camlp5dir should rather be the *binary* location, just as camldir *)
(* TODO: remove the late attempts at finding gramlib.cma *)
-let check_camlp5 testcma = match !Prefs.camlp5dir with
+let check_camlp5 testcma = match !prefs.camlp5dir with
| Some dir ->
if Sys.file_exists (dir/testcma) then
let camlp5o =
@@ -636,7 +709,7 @@ let check_camlp5_version camlp5o =
let version = List.nth (string_split ' ' version_line) 2 in
match numeric_prefix_list version with
| major::minor::_ when s2i major > 6 || (s2i major, s2i minor) >= (6,6) ->
- printf "You have Camlp5 %s. Good!\n" version; version
+ cprintf "You have Camlp5 %s. Good!" version; version
| _ -> die "Error: unsupported Camlp5 (version < 6.06 or unrecognized).\n"
let config_camlp5 () =
@@ -659,22 +732,22 @@ let camlp5libdir = shorten_camllib fullcamlp5libdir
(** * Native compiler *)
let msg_byteonly () =
- printf "Only the bytecode version of Coq will be available.\n"
+ cprintf "Only the bytecode version of Coq will be available."
let msg_no_ocamlopt () =
- printf "Cannot find the OCaml native-code compiler.\n"; msg_byteonly ()
+ cprintf "Cannot find the OCaml native-code compiler."; msg_byteonly ()
let msg_no_camlp5_cmxa () =
- printf "Cannot find the native-code library of camlp5.\n"; msg_byteonly ()
+ cprintf "Cannot find the native-code library of camlp5."; msg_byteonly ()
let msg_no_dynlink_cmxa () =
- printf "Cannot find native-code dynlink library.\n"; msg_byteonly ();
- printf "For building a native-code Coq, you may try to first\n";
- printf "compile and install a dummy dynlink.cmxa (see dev/dynlink.ml)\n";
- printf "and then run ./configure -natdynlink no\n"
+ cprintf "Cannot find native-code dynlink library."; msg_byteonly ();
+ cprintf "For building a native-code Coq, you may try to first";
+ cprintf "compile and install a dummy dynlink.cmxa (see dev/dynlink.ml)";
+ cprintf "and then run ./configure -natdynlink no"
let check_native () =
- let () = if !Prefs.byteonly then raise Not_found in
+ let () = if !prefs.byteonly then raise Not_found in
let version, _ = tryrun camlexec.find ["opt";"-version"] in
if version = "" then let () = msg_no_ocamlopt () in raise Not_found
else if not (Sys.file_exists (fullcamlp5libdir/camlp5mod^".cmxa"))
@@ -684,16 +757,16 @@ let check_native () =
else
let () =
if version <> caml_version then
- printf
- "Warning: Native and bytecode compilers do not have the same version!\n"
- in printf "You have native-code compilation. Good!\n"
+ cprintf
+ "Warning: Native and bytecode compilers do not have the same version!"
+ in cprintf "You have native-code compilation. Good!"
let best_compiler =
try check_native (); "opt" with Not_found -> "byte"
(** * Native dynlink *)
-let hasnatdynlink = !Prefs.natdynlink && best_compiler = "opt"
+let hasnatdynlink = !prefs.natdynlink && best_compiler = "opt"
let natdynlinkflag =
if hasnatdynlink then "true" else "false"
@@ -723,7 +796,7 @@ let check_for_numlib () =
match numlib with
| "" ->
die "Num library not installed, required for OCaml 4.06 or later"
- | _ -> printf "You have the Num library installed. Good!\n"
+ | _ -> cprintf "You have the Num library installed. Good!"
let numlib =
check_for_numlib ()
@@ -740,7 +813,7 @@ let get_source = function
(** Is some location a suitable LablGtk2 installation ? *)
let check_lablgtkdir ?(fatal=false) src dir =
- let yell msg = if fatal then die msg else (printf "%s\n" msg; false) in
+ let yell msg = if fatal then die msg else (cprintf "%s" msg; false) in
let msg = get_source src in
if not (dir_exists dir) then
yell (sprintf "No such directory '%s' (%s)." dir msg)
@@ -753,7 +826,7 @@ let check_lablgtkdir ?(fatal=false) src dir =
(** Detect and/or verify the Lablgtk2 location *)
let get_lablgtkdir () =
- match !Prefs.lablgtkdir with
+ match !prefs.lablgtkdir with
| Some dir ->
let msg = Manual in
if check_lablgtkdir ~fatal:true msg dir then dir, msg
@@ -776,7 +849,7 @@ let get_lablgtkdir () =
let check_lablgtk_version src dir = match src with
| Manual | Stdlib ->
- printf "Warning: could not check the version of lablgtk2.\nMake sure your version is at least 2.18.3.\n";
+ cprintf "Warning: could not check the version of lablgtk2.\nMake sure your version is at least 2.18.3.";
(true, "an unknown version")
| OCamlFind ->
let v, _ = tryrun camlexec.find ["query"; "-format"; "%v"; "lablgtk2"] in
@@ -787,7 +860,7 @@ let check_lablgtk_version src dir = match src with
else if vi < [2; 18; 3] then
begin
(* Version 2.18.3 is known to report incorrectly as 2.18.0, and Launchpad packages report as version 2.16.0 due to a misconfigured META file; see https://bugs.launchpad.net/ubuntu/+source/lablgtk2/+bug/1577236 *)
- printf "Warning: Your installed lablgtk reports as %s.\n It is possible that the installed version is actually more recent\n but reports an incorrect version. If the installed version is\n actually more recent than 2.18.3, that's fine; if it is not,\n CoqIDE will compile but may be very unstable.\n" v;
+ cprintf "Warning: Your installed lablgtk reports as %s.\n It is possible that the installed version is actually more recent\n but reports an incorrect version. If the installed version is\n actually more recent than 2.18.3, that's fine; if it is not,\n CoqIDE will compile but may be very unstable." v;
(true, "an unknown version")
end
else
@@ -800,11 +873,11 @@ exception Ide of ide
(** If the user asks an impossible coqide, we abort the configuration *)
-let set_ide ide msg = match ide, !Prefs.coqide with
+let set_ide ide msg = match ide, !prefs.coqide with
| No, Some (Byte|Opt)
| Byte, Some Opt -> die (msg^":\n=> cannot build requested CoqIde")
| _ ->
- printf "%s:\n=> %s CoqIde will be built.\n" msg (pr_ide ide);
+ cprintf "%s:\n=> %s CoqIde will be built." msg (pr_ide ide);
raise (Ide ide)
let lablgtkdir = ref ""
@@ -813,7 +886,7 @@ let lablgtkdir = ref ""
This function also sets the lablgtkdir reference in case of success. *)
let check_coqide () =
- if !Prefs.coqide = Some No then set_ide No "CoqIde manually disabled";
+ if !prefs.coqide = Some No then set_ide No "CoqIde manually disabled";
let dir, via = get_lablgtkdir () in
if dir = "" then set_ide No "LablGtk2 not found";
let (ok, version) = check_lablgtk_version via dir in
@@ -821,7 +894,7 @@ let check_coqide () =
if not ok then set_ide No (found^", but too old (required >= 2.18.3, found " ^ version ^ ")");
(* We're now sure to produce at least one kind of coqide *)
lablgtkdir := shorten_camllib dir;
- if !Prefs.coqide = Some Byte then set_ide Byte (found^", bytecode requested");
+ if !prefs.coqide = Some Byte then set_ide Byte (found^", bytecode requested");
if best_compiler<>"opt" then set_ide Byte (found^", but no native compiler");
if not (Sys.file_exists (dir/"gtkThread.cmx")) then
set_ide Byte (found^", but no native LablGtk2");
@@ -844,7 +917,7 @@ let idearchdef = ref "X11"
let coqide_flags () =
if !lablgtkdir <> "" then lablgtkincludes := sprintf "-I %S" !lablgtkdir;
match coqide, arch with
- | "opt", "Darwin" when !Prefs.macintegration ->
+ | "opt", "Darwin" when !prefs.macintegration ->
let osxdir,_ = tryrun camlexec.find ["query";"lablgtkosx"] in
if osxdir <> "" then begin
lablgtkincludes := sprintf "%s -I %S" !lablgtkincludes osxdir;
@@ -870,7 +943,7 @@ let strip =
if arch = "Darwin" then
if hasnatdynlink then "true" else "strip"
else
- if !Prefs.profile || !Prefs.debug then "true" else begin
+ if !prefs.profile || !prefs.debug then "true" else begin
let _, all = run camlexec.find ["ocamlc";"-config"] in
let strip = String.concat "" (List.map (fun l ->
match string_split ' ' l with
@@ -886,11 +959,11 @@ let strip =
let check_doc () =
let err s =
- printf "%s was not found; documentation will not be available\n" s;
+ ceprintf "%s was not found; documentation will not be available" s;
raise Not_found
in
try
- if not !Prefs.withdoc then raise Not_found;
+ if not !prefs.withdoc then raise Not_found;
if not (program_in_path "latex") then err "latex";
if not (program_in_path "hevea") then err "hevea";
if not (program_in_path "hacha") then err "hacha";
@@ -908,28 +981,28 @@ let coqtop = Sys.getcwd ()
let unix = os_type_cygwin || not arch_is_win32
-(** Variable name, description, ref in Prefs, default dir, prefix-relative *)
+(** Variable name, description, ref in prefs, default dir, prefix-relative *)
type path_style =
| Absolute of string (* Should start with a "/" *)
| Relative of string (* Should not start with a "/" *)
let install = [
- "BINDIR", "the Coq binaries", Prefs.bindir,
+ "BINDIR", "the Coq binaries", !prefs.bindir,
Relative "bin", Relative "bin", Relative "bin";
- "COQLIBINSTALL", "the Coq library", Prefs.libdir,
+ "COQLIBINSTALL", "the Coq library", !prefs.libdir,
Relative "lib", Relative "lib/coq", Relative "";
- "CONFIGDIR", "the Coqide configuration files", Prefs.configdir,
+ "CONFIGDIR", "the Coqide configuration files", !prefs.configdir,
Relative "config", Absolute "/etc/xdg/coq", Relative "ide";
- "DATADIR", "the Coqide data files", Prefs.datadir,
+ "DATADIR", "the Coqide data files", !prefs.datadir,
Relative "share", Relative "share/coq", Relative "ide";
- "MANDIR", "the Coq man pages", Prefs.mandir,
+ "MANDIR", "the Coq man pages", !prefs.mandir,
Relative "man", Relative "share/man", Relative "man";
- "DOCDIR", "the Coq documentation", Prefs.docdir,
+ "DOCDIR", "the Coq documentation", !prefs.docdir,
Relative "doc", Relative "share/doc/coq", Relative "doc";
- "EMACSLIB", "the Coq Emacs mode", Prefs.emacslib,
+ "EMACSLIB", "the Coq Emacs mode", !prefs.emacslib,
Relative "emacs", Relative "share/emacs/site-lisp", Relative "tools";
- "COQDOCDIR", "the Coqdoc LaTeX files", Prefs.coqdocdir,
+ "COQDOCDIR", "the Coqdoc LaTeX files", !prefs.coqdocdir,
Relative "latex", Relative "share/texmf/tex/latex/misc", Relative "tools/coqdoc";
]
@@ -959,8 +1032,8 @@ let find_suffix prefix path = match prefix with
let do_one_instdir (var,msg,uservalue,selfcontainedlayout,unixlayout,locallayout) =
let dir,suffix =
- if !Prefs.local then (use_suffix coqtop locallayout,locallayout)
- else match !uservalue, !Prefs.prefix with
+ if !prefs.local then (use_suffix coqtop locallayout,locallayout)
+ else match uservalue, !prefs.prefix with
| Some d, p -> d,find_suffix p d
| _, Some p ->
let suffix = if arch_is_win32 then selfcontainedlayout else relativize unixlayout in
@@ -992,7 +1065,7 @@ let datadir,datadirsuffix = let (_,_,d,s) = select "DATADIR" in d,s
let custom_os = arch_is_win32 || arch = "Darwin"
-let use_custom = match !Prefs.custom with
+let use_custom = match !prefs.custom with
| Some b -> b
| None -> custom_os
@@ -1002,10 +1075,10 @@ let build_loadpath =
ref "# you might want to set CAML_LD_LIBRARY_PATH by hand!"
let config_runtime () =
- match !Prefs.vmbyteflags with
+ match !prefs.vmbyteflags with
| Some flags -> string_split ',' flags
| _ when use_custom -> [custom_flag]
- | _ when !Prefs.local ->
+ | _ when !prefs.local ->
["-dllib";"-lcoqrun";"-dllpath";coqtop/"kernel/byterun"]
| _ ->
let ld="CAML_LD_LIBRARY_PATH" in
@@ -1029,7 +1102,7 @@ let print_summary () =
pr " OCaml version : %s\n" caml_version;
pr " OCaml binaries in : %s\n" (esc camlbin);
pr " OCaml library in : %s\n" (esc camllib);
- pr " OCaml flambda flags : %s\n" (String.concat " " !Prefs.flambda_flags);
+ pr " OCaml flambda flags : %s\n" (String.concat " " !prefs.flambda_flags);
pr " Camlp5 version : %s\n" camlp5_version;
pr " Camlp5 binaries in : %s\n" (esc camlp5bindir);
pr " Camlp5 library in : %s\n" (esc camlp5libdir);
@@ -1043,10 +1116,10 @@ let print_summary () =
pr " Documentation : %s\n"
(if withdoc then "All" else "None");
pr " Web browser : %s\n" browser;
- pr " Coq web site : %s\n" !Prefs.coqwebsite;
- pr " Bytecode VM enabled : %B\n" !Prefs.bytecodecompiler;
- pr " Native Compiler enabled : %B\n\n" !Prefs.nativecompiler;
- if !Prefs.local then
+ pr " Coq web site : %s\n" !prefs.coqwebsite;
+ pr " Bytecode VM enabled : %B\n" !prefs.bytecodecompiler;
+ pr " Native Compiler enabled : %B\n\n" !prefs.nativecompiler;
+ if !prefs.local then
pr " Local build, no installation...\n"
else
(pr " Paths for true installation:\n";
@@ -1095,7 +1168,7 @@ let write_configml f =
pr "(* DO NOT EDIT THIS FILE: automatically generated by ../configure *)\n";
pr "(* Exact command that generated this file: *)\n";
pr "(* %s *)\n\n" (String.concat " " (Array.to_list Sys.argv));
- pr_b "local" !Prefs.local;
+ pr_b "local" !prefs.local;
pr "let vmbyteflags = ["; List.iter (pr "%S;") vmbyteflags; pr "]\n";
pr_s "coqlib" coqlib;
pr_s "configdir" configdir;
@@ -1130,17 +1203,17 @@ let write_configml f =
pr "let gtk_platform = `%s\n" !idearchdef;
pr_b "has_natdynlink" hasnatdynlink;
pr_s "natdynlinkflag" natdynlinkflag;
- pr_l "flambda_flags" !Prefs.flambda_flags;
+ pr_l "flambda_flags" !prefs.flambda_flags;
pr_i "vo_magic_number" vo_magic;
pr_i "state_magic_number" state_magic;
pr_s "browser" browser;
- pr_s "wwwcoq" !Prefs.coqwebsite;
- pr_s "wwwbugtracker" (!Prefs.coqwebsite ^ "bugs/");
- pr_s "wwwrefman" (!Prefs.coqwebsite ^ "distrib/" ^ coq_version ^ "/refman/");
- pr_s "wwwstdlib" (!Prefs.coqwebsite ^ "distrib/" ^ coq_version ^ "/stdlib/");
+ pr_s "wwwcoq" !prefs.coqwebsite;
+ pr_s "wwwbugtracker" (!prefs.coqwebsite ^ "bugs/");
+ pr_s "wwwrefman" (!prefs.coqwebsite ^ "distrib/" ^ coq_version ^ "/refman/");
+ pr_s "wwwstdlib" (!prefs.coqwebsite ^ "distrib/" ^ coq_version ^ "/stdlib/");
pr_s "localwwwrefman" ("file:/" ^ docdir ^ "/html/refman");
- pr_b "bytecode_compiler" !Prefs.bytecodecompiler;
- pr_b "native_compiler" !Prefs.nativecompiler;
+ pr_b "bytecode_compiler" !prefs.bytecodecompiler;
+ pr_b "native_compiler" !prefs.nativecompiler;
let core_src_dirs = [ "config"; "dev"; "lib"; "clib"; "kernel"; "library";
"engine"; "pretyping"; "interp"; "parsing"; "proofs";
@@ -1197,7 +1270,7 @@ let write_makefile f =
pr "#Variable used to detect whether ./configure has run successfully.\n";
pr "COQ_CONFIGURED=yes\n\n";
pr "# Local use (no installation)\n";
- pr "LOCAL=%B\n\n" !Prefs.local;
+ pr "LOCAL=%B\n\n" !prefs.local;
pr "# Bytecode link flags : should we use -custom or not ?\n";
pr "CUSTOM=%s\n" custom_flag;
pr "VMBYTEFLAGS=%s\n" (String.concat " " vmbyteflags);
@@ -1226,7 +1299,7 @@ let write_makefile f =
pr "# User compilation flag\n";
pr "USERFLAGS=\n\n";
(* XXX make this configurable *)
- pr "FLAMBDA_FLAGS=%s\n" (String.concat " " !Prefs.flambda_flags);
+ pr "FLAMBDA_FLAGS=%s\n" (String.concat " " !prefs.flambda_flags);
pr "# Flags for GCC\n";
pr "CFLAGS=%s\n\n" cflags;
pr "# Compilation debug flags\n";
@@ -1271,7 +1344,7 @@ let write_makefile f =
pr "# Option to control compilation and installation of the documentation\n";
pr "WITHDOC=%s\n\n" (if withdoc then "all" else "no");
pr "# Option to produce precompiled files for native_compute\n";
- pr "NATIVECOMPUTE=%s\n" (if !Prefs.nativecompiler then "-native-compiler" else "");
+ pr "NATIVECOMPUTE=%s\n" (if !prefs.nativecompiler then "-native-compiler" else "");
close_out o;
Unix.chmod f 0o444
diff --git a/dev/build/windows/MakeCoq_MinGW.bat b/dev/build/windows/MakeCoq_MinGW.bat
index 665d54176..ccf22cc86 100644
--- a/dev/build/windows/MakeCoq_MinGW.bat
+++ b/dev/build/windows/MakeCoq_MinGW.bat
@@ -78,6 +78,9 @@ SET GTK_FROM_SOURCES=N
REM see -threads in ReadMe.txt
SET MAKE_THREADS=8
+REM see -addon in ReadMe.txt
+SET "COQ_ADDONS= "
+
REM ========== PARSE COMMAND LINE PARAMETERS ==========
SHIFT
@@ -233,6 +236,14 @@ IF "%~0" == "-threads" (
GOTO Parse
)
+IF "%~0" == "-addon" (
+ SET "COQ_ADDONS=%COQ_ADDONS% %~1"
+ SHIFT
+ SHIFT
+ GOTO Parse
+)
+
+
IF NOT "%~0" == "" (
ECHO Install cygwin and download, compile and install OCaml and Coq for MinGW
ECHO !!! Illegal parameter %~0
@@ -426,6 +437,7 @@ ECHO ========== BATCH FUNCTIONS ==========
ECHO -coqver ^<Coq version to install^>
ECHO -gtksrc ^<Y or N^> build GTK ^(90 min^) or use cygwin version
ECHO -threads ^<1..N^> Number of make threads
+ ECHO -addon ^<name^> Enable building selected addon (can be repeated)
ECHO(
ECHO See ReadMe.txt for a detailed description of all parameters
ECHO(
@@ -447,6 +459,7 @@ ECHO ========== BATCH FUNCTIONS ==========
ECHO -coqver = %COQ_VERSION%
ECHO -gtksrc = %GTK_FROM_SOURCES%
ECHO -threads = %MAKE_THREADS%
+ ECHO -addon = %COQ_ADDONS%
GOTO :EOF
:CheckYN
diff --git a/dev/build/windows/ReadMe.txt b/dev/build/windows/ReadMe.txt
index 7e80e33c6..93851aeb8 100644
--- a/dev/build/windows/ReadMe.txt
+++ b/dev/build/windows/ReadMe.txt
@@ -61,6 +61,7 @@ The Script MakeCoq_MinGW does:
- either installs MinGW GTK via Cygwin or compiles it fom sources
- download, compile and install OCaml, CamlP5, Menhir, lablgtk
- download, compile and install Coq
+- download, compile and install selected addons
- create a Windows installer (NSIS based)
The parameters are described below. Mostly paths and the HTTP proxy need to be
@@ -335,6 +336,10 @@ Possible values: 1..N.
Should not be more than 1.5x the number of cores.
Should not be more than available RAM/2GB (e.g. 4 for 8GB)
+===== -addon =====
+
+Enable build and installation of selected Coq package (can be repeated for
+selecting more packages)
==================== TODO ====================
diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh
index d8cde39f8..bea30b1a7 100644
--- a/dev/build/windows/makecoq_mingw.sh
+++ b/dev/build/windows/makecoq_mingw.sh
@@ -223,6 +223,12 @@ function get_expand_source_tar {
cp "$SOURCE_LOCAL_CACHE_CFMT/$name.$3" $TARBALLS
else
wget $1/$2.$3
+ if file -i $2.$3 | grep text/html; then
+ echo Download failed: $1/$2.$3
+ echo The file wget downloaded is an html file:
+ cat $2.$3
+ exit 1
+ fi
if [ ! "$2.$3" == "$name.$3" ] ; then
mv $2.$3 $name.$3
fi
@@ -1280,7 +1286,8 @@ function make_coq_installer {
# Prepare the file lists for the installer. We created to file list dumps of the target folder during the build:
# ocaml: ocaml + menhir + camlp5 + findlib
- # ocal_coq: as above + coq
+ # ocaml_coq: as above + coq
+ # ocaml_coq_addons: as above + lib/user-contrib/*
# Create coq file list as ocaml_coq / ocaml
diff_files coq ocaml_coq ocaml
@@ -1294,11 +1301,17 @@ function make_coq_installer {
# Coq objects objects required for plugin development = coq objects except those for pre installed plugins
diff_files coq_plugindev coq_objects coq_objects_plugins
+ # Addons (TODO: including objects that could go to the plugindev thing, but
+ # then one would have to make that package depend on this one, so not
+ # implemented yet)
+ diff_files coq_addons ocaml_coq_addons ocaml_coq
+
# Coq files, except objects needed only for plugin development
diff_files coq_base coq coq_plugindev
# Convert section files to NSIS format
files_to_nsis coq_base
+ files_to_nsis coq_addons
files_to_nsis coq_plugindev
files_to_nsis ocaml
@@ -1314,12 +1327,30 @@ function make_coq_installer {
cp ../patches/ReplaceInFile.nsh dev/nsis
VERSION=`grep '^VERSION=' config/Makefile | cut -d = -f 2 | tr -d '\r'`
cd dev/nsis
- logn nsis-installer "$NSIS" -DVERSION=$VERSION -DARCH=$ARCH -DCOQ_SRC_PATH="$PREFIXCOQ" -DCOQ_ICON=..\\..\\ide\\coq.ico coq_new.nsi
+ logn nsis-installer "$NSIS" -DVERSION=$VERSION -DARCH=$ARCH -DCOQ_SRC_PATH="$PREFIXCOQ" -DCOQ_ICON=..\\..\\ide\\coq.ico -DCOQ_ADDONS="$COQ_ADDONS" coq_new.nsi
build_post
fi
}
+###################### ADDONS #####################
+
+function make_addon_bignums {
+ if build_prep https://github.com/coq/bignums/archive/ master zip 1 bignums-8.8.0; then
+ # To make command lines shorter :-(
+ echo 'COQ_SRC_SUBDIRS:=$(filter-out plugins/%,$(COQ_SRC_SUBDIRS)) plugins/syntax' >> Makefile.coq.local
+ logn make make all
+ logn make-install make install
+ build_post
+ fi
+}
+
+function make_addons {
+ for addon in $COQ_ADDONS; do
+ make_addon_$addon
+ done
+}
+
###################### TOP LEVEL BUILD #####################
make_sed
@@ -1337,6 +1368,10 @@ fi
list_files ocaml_coq
+make_addons
+
+list_files ocaml_coq_addons
+
if [ "$MAKEINSTALLER" == "Y" ] ; then
make_coq_installer
fi
diff --git a/dev/build/windows/patches_coq/coq_new.nsi b/dev/build/windows/patches_coq/coq_new.nsi
index 2c2f0fa47..55fba6d5a 100644
--- a/dev/build/windows/patches_coq/coq_new.nsi
+++ b/dev/build/windows/patches_coq/coq_new.nsi
@@ -9,6 +9,7 @@
; ARCH The target architecture, either x86_64 or i686
; COQ_SRC_PATH path of Coq installation in Windows or MinGW format (either \\ or /, but with drive letter)
; COQ_ICON path of Coq icon file in Windows or MinGW format
+; COQ_ADDONS list of addons that are shipped
; Enable compression after debugging.
; SetCompress off
@@ -69,7 +70,8 @@ Var INSTDIR_DBS ; INSTDIR with \\ instead of \
;Description
LangString DESC_1 ${LANG_ENGLISH} "This package contains Coq and CoqIDE."
- LangString DESC_2 ${LANG_ENGLISH} "This package contains an OCaml compiler for Coq native compute and plugin development."
+ LangString DESC_2 ${LANG_ENGLISH} "This package contains the following extra Coq packages: ${COQ_ADDONS}"
+ ;LangString DESC_2 ${LANG_ENGLISH} "This package contains an OCaml compiler for Coq native compute and plugin development."
LangString DESC_3 ${LANG_ENGLISH} "This package contains the development files needed in order to build a plugin for Coq."
LangString DESC_4 ${LANG_ENGLISH} "Set the OCAMLLIB environment variable for the current user."
LangString DESC_5 ${LANG_ENGLISH} "Set the OCAMLLIB environment variable for all users."
@@ -150,6 +152,11 @@ SectionEnd
;OCAML !insertmacro ReplaceInFile "$INSTDIR\etc\findlib.conf" "$COQ_SRC_PATH_DBS" "$INSTDIR_DBS"
;OCAML SectionEnd
+Section "Coq packages" Sec2
+ SetOutPath "$INSTDIR\"
+ !include "..\..\..\filelists\coq_addons.nsh"
+SectionEnd
+
Section "Coq files for plugin developers" Sec3
SetOutPath "$INSTDIR\"
!include "..\..\..\filelists\coq_plugindev.nsh"
@@ -176,7 +183,7 @@ SectionEnd
!insertmacro MUI_FUNCTION_DESCRIPTION_BEGIN
!insertmacro MUI_DESCRIPTION_TEXT ${Sec1} $(DESC_1)
- ;OCAML !insertmacro MUI_DESCRIPTION_TEXT ${Sec2} $(DESC_2)
+ !insertmacro MUI_DESCRIPTION_TEXT ${Sec2} $(DESC_2)
!insertmacro MUI_DESCRIPTION_TEXT ${Sec3} $(DESC_3)
;OCAML !insertmacro MUI_DESCRIPTION_TEXT ${Sec4} $(DESC_4)
;OCAML !insertmacro MUI_DESCRIPTION_TEXT ${Sec5} $(DESC_5)
diff --git a/dev/ci/appveyor.bat b/dev/ci/appveyor.bat
index dec6f0d18..85a71baf7 100644
--- a/dev/ci/appveyor.bat
+++ b/dev/ci/appveyor.bat
@@ -23,6 +23,7 @@ if %USEOPAM% == false (
call %APPVEYOR_BUILD_FOLDER%\dev\build\windows\MakeCoq_MinGW.bat -threads=1 ^
-arch=%ARCH% -installer=Y -coqver=%APPVEYOR_BUILD_FOLDER_CFMT% ^
-destcyg=%CYGROOT% -destcoq=%DESTCOQ% -cygcache=%CYGCACHE% ^
+ -addon=bignums -make=N ^
-setup %CYGROOT%\%SETUP% || GOTO ErrorExit
copy "%CYGROOT%\build\coq-local\dev\nsis\*.exe" dev\nsis || GOTO ErrorExit
7z a coq-opensource-archive-windows-%ARCHLONG%.zip %CYGROOT%\build\tarballs\* || GOTO ErrorExit
diff --git a/dev/doc/setup.txt b/dev/doc/setup.txt
index 0003a2c21..c48c2d5d1 100644
--- a/dev/doc/setup.txt
+++ b/dev/doc/setup.txt
@@ -41,15 +41,15 @@ Building coqtop:
cd ~/git/coq
git checkout trunk
make distclean
- ./configure -annotate -local
+ ./configure -profile devel
make clean
make -j4 coqide printers
-The "-annotate" option is essential when one wants to use Merlin.
+The "-profile devel" enables all options recommended for developers (like
+warnings, support for Merlin, etc). Moreover Coq is configured so that
+it can be run without installing it (i.e. from the current directory).
-The "-local" option is useful if one wants to run the coqtop and coqide binaries without running make install
-
-Then check if
+Once the compilation is over check if
- bin/coqtop
- bin/coqide
behave as expected.
diff --git a/dev/header.c b/dev/header.c
new file mode 100644
index 000000000..663c43b3d
--- /dev/null
+++ b/dev/header.c
@@ -0,0 +1,9 @@
+/************************************************************************/
+/* * 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 --git a/dev/header b/dev/header.ml
index 7c3ee6004..7c3ee6004 100644
--- a/dev/header
+++ b/dev/header.ml
diff --git a/dev/header.py b/dev/header.py
new file mode 100644
index 000000000..f81c8aa6a
--- /dev/null
+++ b/dev/header.py
@@ -0,0 +1,9 @@
+##########################################################################
+## # 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 --git a/doc/LICENSE b/doc/LICENSE
index ada22e669..0aa0d629e 100644
--- a/doc/LICENSE
+++ b/doc/LICENSE
@@ -25,16 +25,6 @@ the PostScript, PDF and html outputs) are copyright (c) INRIA
distributed under the terms of the Lesser General Public License
version 2.1 or later.
-The FAQ (Coq for the Clueless) is a work by Pierre Castéran, Hugo
-Herbelin, Florent Kirchner, Benjamin Monate, and Julien Narboux. All
-documents (the LaTeX source and the PostScript, PDF and html outputs)
-are copyright (c) INRIA 2004-2006. The material connected to the FAQ
-(Coq for the Clueless) may be distributed only subject to the terms
-and conditions set forth in the Open Publication License, v1.0 or
-later (the latest version is presently available at
-http://www.opencontent.org/openpub/). Options A and B are *not*
-elected.
-
The Tutorial on [Co-]Inductive Types in Coq is a work by Pierre
Castéran and Eduardo Gimenez. All related documents (the LaTeX and
BibTeX sources and the PostScript, PDF and html outputs) are copyright
diff --git a/doc/refman/Classes.tex b/doc/refman/Classes.tex
index 6e76d04e7..da798a238 100644
--- a/doc/refman/Classes.tex
+++ b/doc/refman/Classes.tex
@@ -492,26 +492,6 @@ control on the triggering of instances. For example, forcing a constant
to explicitely appear in the pattern will make it never apply on a goal
where there is a hole in that place.
-\subsection{\tt Set Typeclasses Legacy Resolution}
-\optindex{Typeclasses Legacy Resolution}
-\emph{Deprecated since 8.7}
-
-This option (off by default) uses the 8.5 implementation of resolution.
-Use for compatibility purposes only (porting and debugging).
-
-\subsection{\tt Set Typeclasses Module Eta}
-\optindex{Typeclasses Modulo Eta}
-\emph{Deprecated since 8.7}
-
-This option allows eta-conversion for functions and records during
-unification of type-classes. This option is unsupported since 8.6 with
-{\tt Typeclasses Filtered Unification} set, but still affects the
-default unification strategy, and the one used in {\tt Legacy
- Resolution} mode. It is \emph{unset} by default. If {\tt Typeclasses
- Filtered Unification} is set, this has no effect and unification will
-find solutions up-to eta conversion. Note however that syntactic
-pattern-matching is not up-to eta.
-
\subsection{\tt Set Typeclasses Limit Intros}
\optindex{Typeclasses Limit Intros}
@@ -525,13 +505,6 @@ invertibility status of the product introduction rule, resulting in
potentially more expensive proof-search (i.e. more useless
backtracking).
-\subsection{\tt Set Typeclass Resolution After Apply}
-\optindex{Typeclass Resolution After Apply}
-\emph{Deprecated since 8.6}
-
-This option (off by default in Coq 8.6 and 8.5) controls the resolution
-of typeclass subgoals generated by the {\tt apply} tactic.
-
\subsection{\tt Set Typeclass Resolution For Conversion}
\optindex{Typeclass Resolution For Conversion}
diff --git a/doc/refman/RefMan-com.tex b/doc/refman/RefMan-com.tex
index 04a8a25c1..5b73ac00a 100644
--- a/doc/refman/RefMan-com.tex
+++ b/doc/refman/RefMan-com.tex
@@ -241,6 +241,20 @@ The following command-line options are recognized by the commands {\tt
Collapse the universe hierarchy of {\Coq}. Warning: this makes the
logic inconsistent.
+\item[{\tt -mangle-names} {\em ident}]\ %
+
+ Experimental: Do not depend on this option.
+
+ Replace Coq's auto-generated name scheme with names of the form
+ {\tt ident0}, {\tt ident1}, \ldots etc.
+ The command {\tt Set Mangle Names}\optindex{Mangle Names} turns
+ the behavior on in a document, and {\tt Set Mangle Names Prefix "ident"}
+ \optindex{Mangle Names Prefix} changes the used prefix.
+
+ This feature is intended to be used as a linter for developments that want
+ to be robust to changes in the auto-generated name scheme. The options are
+ provided to facilitate tracking down problems.
+
\item[{\tt -compat} {\em version}]\ %
Attempt to maintain some backward-compatibility with a previous version.
diff --git a/doc/refman/RefMan-ltac.tex b/doc/refman/RefMan-ltac.tex
index c4c0435c5..0a4d0ef9a 100644
--- a/doc/refman/RefMan-ltac.tex
+++ b/doc/refman/RefMan-ltac.tex
@@ -1156,16 +1156,6 @@ without having to cut manually the proof in smaller lemmas.
It may be useful to generate lemmas minimal w.r.t. the assumptions they depend
on. This can be obtained thanks to the option below.
-\begin{quote}
-\optindex{Shrink Abstract}
-{\tt Set Shrink Abstract}
-\end{quote}
-\emph{Deprecated since 8.7}
-
-When set (default), all lemmas generated through \texttt{abstract {\tacexpr}}
-and \texttt{transparent\_abstract {\tacexpr}} are quantified only over the
-variables that appear in the term constructed by \texttt{\tacexpr}.
-
\begin{Variants}
\item \texttt{abstract {\tacexpr} using {\ident}}.\\
Give explicitly the name of the auxiliary lemma.
diff --git a/doc/refman/RefMan-pro.tex b/doc/refman/RefMan-pro.tex
index 6b24fdde7..bd74a40d7 100644
--- a/doc/refman/RefMan-pro.tex
+++ b/doc/refman/RefMan-pro.tex
@@ -298,15 +298,19 @@ subgoals which clutter your screen.
\begin{Variant}
\item {\tt Focus {\num}.}\\
This focuses the attention on the $\num^{th}$ subgoal to prove.
-
\end{Variant}
+\emph{This command is deprecated since 8.8: prefer the use of bullets or
+ focusing brackets instead, including {\tt {\num}: \{}}.
+
\subsection[\tt Unfocus.]{\tt Unfocus.\comindex{Unfocus}}
This command restores to focus the goal that were suspended by the
last {\tt Focus} command.
+\emph{This command is deprecated since 8.8.}
+
\subsection[\tt Unfocused.]{\tt Unfocused.\comindex{Unfocused}}
-Succeeds in the proof is fully unfocused, fails is there are some
+Succeeds in the proof if fully unfocused, fails if there are some
goals out of focus.
\subsection[\tt \{ \textrm{and} \}]{\tt \{ \textrm{and} \}\comindex{\{}\comindex{\}}}\label{curlybacket}
diff --git a/doc/refman/RefMan-sch.tex b/doc/refman/RefMan-sch.tex
index 30724759d..600471123 100644
--- a/doc/refman/RefMan-sch.tex
+++ b/doc/refman/RefMan-sch.tex
@@ -127,7 +127,6 @@ conclusion is {\tt (n:nat)(even n)->(Q n)}.
\optindex{Boolean Equality Schemes}
\optindex{Elimination Schemes}
\optindex{Nonrecursive Elimination Schemes}
-\optindex{Record Elimination Schemes}
\optindex{Case Analysis Schemes}
\optindex{Decidable Equality Schemes}
\optindex{Rewriting Schemes}
@@ -144,7 +143,6 @@ and {\tt Record} (see~\ref{Record}) do not have an automatic
declaration of the induction principles. It can be activated with the
command {\tt Set Nonrecursive Elimination Schemes}. It can be
deactivated again with {\tt Unset Nonrecursive Elimination Schemes}.
-{\tt Record Elimination Schemes} is a deprecated alias of {\tt Nonrecursive Elimination Schemes}.
In addition, the {\tt Case Analysis Schemes} flag governs the generation of
case analysis lemmas for inductive types, i.e. corresponding to the
diff --git a/doc/refman/RefMan-tac.tex b/doc/refman/RefMan-tac.tex
index 6dca314b4..40ba43b6c 100644
--- a/doc/refman/RefMan-tac.tex
+++ b/doc/refman/RefMan-tac.tex
@@ -4589,7 +4589,6 @@ incompatibilities.
\end{Variants}
\optindex{Intuition Negation Unfolding}
-\optindex{Intuition Iff Unfolding}
Some aspects of the tactic {\tt intuition} can be
controlled using options. To avoid that inner negations which do not
@@ -4609,17 +4608,6 @@ To do that all negations of the goal are unfolded even inner ones
To avoid that inner occurrence of {\tt iff} which do not need to be
unfolded are unfolded (this is the default), use:
-\begin{quote}
-{\tt Unset Intuition Iff Unfolding}
-\end{quote}
-
-To do that all negations of the goal are unfolded even inner ones
-(this is the default), use:
-
-\begin{quote}
-{\tt Set Intuition Iff Unfolding}
-\end{quote}
-
% En attente d'un moyen de valoriser les fichiers de demos
%\SeeAlso file \texttt{contrib/Rocq/DEMOS/Demo\_tauto.v}
diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template
index a2739e457..8c09b23a5 100644
--- a/doc/stdlib/index-list.html.template
+++ b/doc/stdlib/index-list.html.template
@@ -598,5 +598,6 @@ through the <tt>Require Import</tt> command.</p>
theories/Compat/AdmitAxiom.v
theories/Compat/Coq86.v
theories/Compat/Coq87.v
+ theories/Compat/Coq88.v
</dd>
</dl>
diff --git a/engine/evarutil.ml b/engine/evarutil.ml
index 7674cf67a..6b3ce048f 100644
--- a/engine/evarutil.ml
+++ b/engine/evarutil.ml
@@ -89,15 +89,15 @@ let nf_evars_universes evm =
(Evd.universe_subst evm)
let nf_evars_and_universes evm =
- let evm = Evd.nf_constraints evm in
+ let evm = Evd.minimize_universes evm in
evm, nf_evars_universes evm
let e_nf_evars_and_universes evdref =
- evdref := Evd.nf_constraints !evdref;
+ evdref := Evd.minimize_universes !evdref;
nf_evars_universes !evdref, Evd.universe_subst !evdref
let nf_evar_map_universes evm =
- let evm = Evd.nf_constraints evm in
+ let evm = Evd.minimize_universes evm in
let subst = Evd.universe_subst evm in
if Univ.LMap.is_empty subst then evm, nf_evar0 evm
else
diff --git a/engine/evd.ml b/engine/evd.ml
index e7d542d12..b7b87370e 100644
--- a/engine/evd.ml
+++ b/engine/evd.ml
@@ -253,21 +253,8 @@ let instantiate_evar_array info c args =
| [] -> c
| _ -> replace_vars inst c
-type evar_universe_context = UState.t
-type 'a in_evar_universe_context = 'a * evar_universe_context
-
-let empty_evar_universe_context = UState.empty
-let union_evar_universe_context = UState.union
-let evar_universe_context_set = UState.context_set
-let evar_universe_context_constraints = UState.constraints
-let evar_context_universe_context = UState.context
-let evar_universe_context_of = UState.of_context_set
-let evar_universe_context_subst = UState.subst
-let add_constraints_context = UState.add_constraints
-let add_universe_constraints_context = UState.add_universe_constraints
-let constrain_variables = UState.constrain_variables
-let evar_universe_context_of_binders = UState.of_binders
+type 'a in_evar_universe_context = 'a * UState.t
(*******************************************************************)
(* Metamaps *)
@@ -421,13 +408,15 @@ let key id (_, idtoev) =
end
+type goal_kind = ToShelve | ToGiveUp
+
type evar_map = {
(** Existential variables *)
defn_evars : evar_info EvMap.t;
undf_evars : evar_info EvMap.t;
evar_names : EvNames.t;
(** Universes *)
- universes : evar_universe_context;
+ universes : UState.t;
(** Conversion problems *)
conv_pbs : evar_constraint list;
last_mods : Evar.Set.t;
@@ -445,6 +434,7 @@ type evar_map = {
name) of the evar which
will be instantiated with
a term containing [e]. *)
+ future_goals_status : goal_kind EvMap.t;
extras : Store.t;
}
@@ -484,7 +474,8 @@ let remove d e =
| Some e' -> if Evar.equal e e' then None else d.principal_future_goal
in
let future_goals = List.filter (fun e' -> not (Evar.equal e e')) d.future_goals in
- { d with undf_evars; defn_evars; principal_future_goal; future_goals }
+ let future_goals_status = EvMap.remove e d.future_goals_status in
+ { d with undf_evars; defn_evars; principal_future_goal; future_goals; future_goals_status }
let find d e =
try EvMap.find e d.undf_evars
@@ -558,10 +549,10 @@ let existential_type d (n, args) =
instantiate_evar_array info info.evar_concl args
let add_constraints d c =
- { d with universes = add_constraints_context d.universes c }
+ { d with universes = UState.add_constraints d.universes c }
let add_universe_constraints d c =
- { d with universes = add_universe_constraints_context d.universes c }
+ { d with universes = UState.add_universe_constraints d.universes c }
(*** /Lifting... ***)
@@ -586,7 +577,7 @@ let create_evar_defs sigma = { sigma with
let empty = {
defn_evars = EvMap.empty;
undf_evars = EvMap.empty;
- universes = empty_evar_universe_context;
+ universes = UState.empty;
conv_pbs = [];
last_mods = Evar.Set.empty;
metas = Metamap.empty;
@@ -594,6 +585,7 @@ let empty = {
evar_names = EvNames.empty; (* id<->key for undefined evars *)
future_goals = [];
principal_future_goal = None;
+ future_goals_status = EvMap.empty;
extras = Store.empty;
}
@@ -609,14 +601,14 @@ let evars_reset_evd ?(with_conv_pbs=false) ?(with_univs=true) evd d =
let last_mods = if with_conv_pbs then evd.last_mods else d.last_mods in
let universes =
if not with_univs then evd.universes
- else union_evar_universe_context evd.universes d.universes
+ else UState.union evd.universes d.universes
in
{ evd with
metas = d.metas;
last_mods; conv_pbs; universes }
let merge_universe_context evd uctx' =
- { evd with universes = union_evar_universe_context evd.universes uctx' }
+ { evd with universes = UState.union evd.universes uctx' }
let set_universe_context evd uctx' =
{ evd with universes = uctx' }
@@ -798,16 +790,6 @@ let make_flexible_variable evd ~algebraic u =
{ evd with universes =
UState.make_flexible_variable evd.universes ~algebraic u }
-let make_evar_universe_context e l =
- let uctx = UState.make (Environ.universes e) in
- match l with
- | None -> uctx
- | Some us ->
- List.fold_left
- (fun uctx { CAst.loc; v = id } ->
- fst (UState.new_univ_variable ?loc univ_rigid (Some id) uctx))
- uctx us
-
(****************************************)
(* Operations on constants *)
(****************************************)
@@ -910,10 +892,6 @@ let check_eq evd s s' =
let check_leq evd s s' =
UGraph.check_leq (UState.ugraph evd.universes) s s'
-let normalize_evar_universe_context_variables = UState.normalize_variables
-
-let abstract_undefined_variables = UState.abstract_undefined_variables
-
let fix_undefined_variables evd =
{ evd with universes = UState.fix_undefined_variables evd.universes }
@@ -922,16 +900,14 @@ let refresh_undefined_universes evd =
let evd' = cmap (subst_univs_level_constr subst) {evd with universes = uctx'} in
evd', subst
-let normalize_evar_universe_context = UState.normalize
-
-let nf_univ_variables evd =
- let subst, uctx' = normalize_evar_universe_context_variables evd.universes in
+let nf_univ_variables evd =
+ let subst, uctx' = UState.normalize_variables evd.universes in
let evd' = {evd with universes = uctx'} in
evd', subst
-let nf_constraints evd =
- let subst, uctx' = normalize_evar_universe_context_variables evd.universes in
- let uctx' = normalize_evar_universe_context uctx' in
+let minimize_universes evd =
+ let subst, uctx' = UState.normalize_variables evd.universes in
+ let uctx' = UState.minimize uctx' in
{evd with universes = uctx'}
let universe_of_name evd s = UState.universe_of_name evd.universes s
@@ -958,25 +934,72 @@ let drop_side_effects evd =
let eval_side_effects evd = evd.effects
(* Future goals *)
-let declare_future_goal evk evd =
- { evd with future_goals = evk::evd.future_goals }
+let declare_future_goal ?tag evk evd =
+ { evd with future_goals = evk::evd.future_goals;
+ future_goals_status = Option.fold_right (EvMap.add evk) tag evd.future_goals_status }
-let declare_principal_goal evk evd =
+let declare_principal_goal ?tag evk evd =
match evd.principal_future_goal with
| None -> { evd with
future_goals = evk::evd.future_goals;
- principal_future_goal=Some evk; }
+ principal_future_goal=Some evk;
+ future_goals_status = Option.fold_right (EvMap.add evk) tag evd.future_goals_status;
+ }
| Some _ -> CErrors.user_err Pp.(str "Only one main subgoal per instantiation.")
+type future_goals = Evar.t list * Evar.t option * goal_kind EvMap.t
+
let future_goals evd = evd.future_goals
let principal_future_goal evd = evd.principal_future_goal
-let reset_future_goals evd =
- { evd with future_goals = [] ; principal_future_goal=None }
+let save_future_goals evd =
+ (evd.future_goals, evd.principal_future_goal, evd.future_goals_status)
-let restore_future_goals evd gls pgl =
- { evd with future_goals = gls ; principal_future_goal = pgl }
+let reset_future_goals evd =
+ { evd with future_goals = [] ; principal_future_goal = None;
+ future_goals_status = EvMap.empty }
+
+let restore_future_goals evd (gls,pgl,map) =
+ { evd with future_goals = gls ; principal_future_goal = pgl;
+ future_goals_status = map }
+
+let fold_future_goals f sigma (gls,pgl,map) =
+ List.fold_left f sigma gls
+
+let map_filter_future_goals f (gls,pgl,map) =
+ (* Note: map is now a superset of filtered evs, but its size should
+ not be too big, so that's probably ok not to update it *)
+ (List.map_filter f gls,Option.bind pgl f,map)
+
+let filter_future_goals f (gls,pgl,map) =
+ (List.filter f gls,Option.bind pgl (fun a -> if f a then Some a else None),map)
+
+let dispatch_future_goals_gen distinguish_shelf (gls,pgl,map) =
+ let rec aux (comb,shelf,givenup as acc) = function
+ | [] -> acc
+ | evk :: gls ->
+ let acc =
+ try match EvMap.find evk map with
+ | ToGiveUp -> (comb,shelf,evk::givenup)
+ | ToShelve ->
+ if distinguish_shelf then (comb,evk::shelf,givenup)
+ else raise Not_found
+ with Not_found -> (evk::comb,shelf,givenup) in
+ aux acc gls in
+ (* Note: this reverses the order of initial list on purpose *)
+ let (comb,shelf,givenup) = aux ([],[],[]) gls in
+ (comb,shelf,givenup,pgl)
+
+let dispatch_future_goals =
+ dispatch_future_goals_gen true
+
+let extract_given_up_future_goals goals =
+ let (comb,_,givenup,_) = dispatch_future_goals_gen false goals in
+ (comb,givenup)
+
+let shelve_on_future_goals shelved (gls,pgl,map) =
+ (shelved @ gls, pgl, List.fold_right (fun evk -> EvMap.add evk ToShelve) shelved map)
(**********************************************************)
(* Accessing metas *)
@@ -993,6 +1016,7 @@ let set_metas evd metas = {
effects = evd.effects;
evar_names = evd.evar_names;
future_goals = evd.future_goals;
+ future_goals_status = evd.future_goals_status;
principal_future_goal = evd.principal_future_goal;
extras = evd.extras;
}
@@ -1076,7 +1100,7 @@ let clear_metas evd = {evd with metas = Metamap.empty}
let meta_merge ?(with_univs = true) evd1 evd2 =
let metas = Metamap.fold Metamap.add evd1.metas evd2.metas in
let universes =
- if with_univs then union_evar_universe_context evd2.universes evd1.universes
+ if with_univs then UState.union evd2.universes evd1.universes
else evd2.universes
in
{evd2 with universes; metas; }
@@ -1176,3 +1200,25 @@ module Monad =
(* Failure explanation *)
type unsolvability_explanation = SeveralInstancesFound of int
+
+(** Deprecated *)
+type evar_universe_context = UState.t
+let empty_evar_universe_context = UState.empty
+let union_evar_universe_context = UState.union
+let evar_universe_context_set = UState.context_set
+let evar_universe_context_constraints = UState.constraints
+let evar_context_universe_context = UState.context
+let evar_universe_context_of = UState.of_context_set
+let evar_universe_context_subst = UState.subst
+let add_constraints_context = UState.add_constraints
+let constrain_variables = UState.constrain_variables
+let evar_universe_context_of_binders = UState.of_binders
+let make_evar_universe_context e l =
+ let g = Environ.universes e in
+ match l with
+ | None -> UState.make g
+ | Some l -> UState.make_with_initial_binders g l
+let normalize_evar_universe_context_variables = UState.normalize_variables
+let abstract_undefined_variables = UState.abstract_undefined_variables
+let normalize_evar_universe_context = UState.minimize
+let nf_constraints = minimize_universes
diff --git a/engine/evd.mli b/engine/evd.mli
index 55b8e3a83..bd9d75c6b 100644
--- a/engine/evd.mli
+++ b/engine/evd.mli
@@ -282,11 +282,13 @@ val drop_side_effects : evar_map -> evar_map
(** {5 Future goals} *)
-val declare_future_goal : Evar.t -> evar_map -> evar_map
+type goal_kind = ToShelve | ToGiveUp
+
+val declare_future_goal : ?tag:goal_kind -> Evar.t -> evar_map -> evar_map
(** Adds an existential variable to the list of future goals. For
internal uses only. *)
-val declare_principal_goal : Evar.t -> evar_map -> evar_map
+val declare_principal_goal : ?tag:goal_kind -> Evar.t -> evar_map -> evar_map
(** Adds an existential variable to the list of future goals and make
it principal. Only one existential variable can be made principal, an
error is raised otherwise. For internal uses only. *)
@@ -299,16 +301,41 @@ val principal_future_goal : evar_map -> Evar.t option
(** Retrieves the name of the principal existential variable if there
is one. Used by the [refine] primitive of the tactic engine. *)
+type future_goals
+
+val save_future_goals : evar_map -> future_goals
+(** Retrieves the list of future goals including the principal future
+ goal. Used by the [refine] primitive of the tactic engine. *)
+
val reset_future_goals : evar_map -> evar_map
(** Clears the list of future goals (as well as the principal future
goal). Used by the [refine] primitive of the tactic engine. *)
-val restore_future_goals : evar_map -> Evar.t list -> Evar.t option -> evar_map
+val restore_future_goals : evar_map -> future_goals -> evar_map
(** Sets the future goals (including the principal future goal) to a
previous value. Intended to be used after a local list of future
goals has been consumed. Used by the [refine] primitive of the
tactic engine. *)
+val fold_future_goals : (evar_map -> Evar.t -> evar_map) -> evar_map -> future_goals -> evar_map
+(** Fold future goals *)
+
+val map_filter_future_goals : (Evar.t -> Evar.t option) -> future_goals -> future_goals
+(** Applies a function on the future goals *)
+
+val filter_future_goals : (Evar.t -> bool) -> future_goals -> future_goals
+(** Applies a filter on the future goals *)
+
+val dispatch_future_goals : future_goals -> Evar.t list * Evar.t list * Evar.t list * Evar.t option
+(** Returns the future_goals dispatched into regular, shelved, given_up
+ goals; last argument is the goal tagged as principal if any *)
+
+val extract_given_up_future_goals : future_goals -> Evar.t list * Evar.t list
+(** An ad hoc variant for Proof.proof; not for general use *)
+
+val shelve_on_future_goals : Evar.t list -> future_goals -> future_goals
+(** Push goals on the shelve of future goals *)
+
(** {5 Sort variables}
Evar maps also keep track of the universe constraints defined at a given
@@ -320,8 +347,8 @@ exception UniversesDiffer
val add_universe_constraints : evar_map -> Universes.Constraints.t -> evar_map
(** Add the given universe unification constraints to the evar map.
- @raises UniversesDiffer in case a first-order unification fails.
- @raises UniverseInconsistency
+ @raise UniversesDiffer in case a first-order unification fails.
+ @raise UniverseInconsistency .
*)
(** {5 Extra data}
@@ -493,22 +520,31 @@ val univ_flexible_alg : rigid
type 'a in_evar_universe_context = 'a * UState.t
val evar_universe_context_set : UState.t -> Univ.ContextSet.t
+[@@ocaml.deprecated "Alias of UState.context_set"]
val evar_universe_context_constraints : UState.t -> Univ.Constraint.t
+[@@ocaml.deprecated "Alias of UState.constraints"]
val evar_context_universe_context : UState.t -> Univ.UContext.t
[@@ocaml.deprecated "alias of UState.context"]
val evar_universe_context_of : Univ.ContextSet.t -> UState.t
+[@@ocaml.deprecated "Alias of UState.of_context_set"]
val empty_evar_universe_context : UState.t
+[@@ocaml.deprecated "Alias of UState.empty"]
val union_evar_universe_context : UState.t -> UState.t ->
UState.t
+[@@ocaml.deprecated "Alias of UState.union"]
val evar_universe_context_subst : UState.t -> Universes.universe_opt_subst
+[@@ocaml.deprecated "Alias of UState.subst"]
val constrain_variables : Univ.LSet.t -> UState.t -> UState.t
+[@@ocaml.deprecated "Alias of UState.constrain_variables"]
val evar_universe_context_of_binders :
Universes.universe_binders -> UState.t
+[@@ocaml.deprecated "Alias of UState.of_binders"]
val make_evar_universe_context : env -> Misctypes.lident list option -> UState.t
+[@@ocaml.deprecated "Use UState.make or UState.make_with_initial_binders"]
val restrict_universe_context : evar_map -> Univ.LSet.t -> evar_map
(** Raises Not_found if not a name for a universe in this map. *)
val universe_of_name : evar_map -> Id.t -> Univ.Level.t
@@ -516,13 +552,15 @@ val universe_of_name : evar_map -> Id.t -> Univ.Level.t
val universe_binders : evar_map -> Universes.universe_binders
val add_constraints_context : UState.t ->
Univ.Constraint.t -> UState.t
+[@@ocaml.deprecated "Alias of UState.add_constraints"]
val normalize_evar_universe_context_variables : UState.t ->
Univ.universe_subst in_evar_universe_context
+[@@ocaml.deprecated "Alias of UState.normalize_variables"]
-val normalize_evar_universe_context : UState.t ->
- UState.t
+val normalize_evar_universe_context : UState.t -> UState.t
+[@@ocaml.deprecated "Alias of UState.minimize"]
val new_univ_level_variable : ?loc:Loc.t -> ?name:Id.t -> rigid -> evar_map -> evar_map * Univ.Level.t
val new_univ_variable : ?loc:Loc.t -> ?name:Id.t -> rigid -> evar_map -> evar_map * Univ.Universe.t
@@ -581,12 +619,16 @@ val with_context_set : ?loc:Loc.t -> rigid -> evar_map -> 'a Univ.in_universe_co
val nf_univ_variables : evar_map -> evar_map * Univ.universe_subst
val abstract_undefined_variables : UState.t -> UState.t
+[@@ocaml.deprecated "Alias of UState.abstract_undefined_variables"]
val fix_undefined_variables : evar_map -> evar_map
val refresh_undefined_universes : evar_map -> evar_map * Univ.universe_level_subst
+(** Universe minimization *)
+val minimize_universes : evar_map -> evar_map
val nf_constraints : evar_map -> evar_map
+[@@ocaml.deprecated "Alias of Evd.minimize_universes"]
val update_sigma_env : evar_map -> env -> evar_map
diff --git a/engine/namegen.ml b/engine/namegen.ml
index 33570ac73..d66b77b57 100644
--- a/engine/namegen.ml
+++ b/engine/namegen.ml
@@ -192,9 +192,45 @@ let it_mkLambda_or_LetIn_name env sigma b hyps =
(**********************************************************************)
(* Fresh names *)
+(* Introduce a mode where auto-generated names are mangled
+ to test dependence of scripts on auto-generated names *)
+
+let mangle_names = ref false
+
+let _ = Goptions.(
+ declare_bool_option
+ { optdepr = false;
+ optname = "mangle auto-generated names";
+ optkey = ["Mangle";"Names"];
+ optread = (fun () -> !mangle_names);
+ optwrite = (:=) mangle_names; })
+
+let mangle_names_prefix = ref (Id.of_string "_0")
+let set_prefix x = mangle_names_prefix := forget_subscript x
+
+let set_mangle_names_mode x = begin
+ set_prefix x;
+ mangle_names := true
+ end
+
+let _ = Goptions.(
+ declare_string_option
+ { optdepr = false;
+ optname = "mangled names prefix";
+ optkey = ["Mangle";"Names";"Prefix"];
+ optread = (fun () -> Id.to_string !mangle_names_prefix);
+ optwrite = begin fun x ->
+ set_prefix
+ (try Id.of_string x
+ with CErrors.UserError _ -> CErrors.user_err Pp.(str ("Not a valid identifier: \"" ^ x ^ "\".")))
+ end })
+
+let mangle_id id = if !mangle_names then !mangle_names_prefix else id
+
(* Looks for next "good" name by lifting subscript *)
let next_ident_away_from id bad =
+ let id = mangle_id id in
let rec name_rec id = if bad id then name_rec (increment_subscript id) else id in
name_rec id
@@ -293,6 +329,7 @@ let next_global_ident_away id avoid =
looks for same name with lower available subscript *)
let next_ident_away id avoid =
+ let id = mangle_id id in
if Id.Set.mem id avoid then
next_ident_away_from (restart_subscript id) (fun id -> Id.Set.mem id avoid)
else id
@@ -423,23 +460,3 @@ let rename_bound_vars_as_displayed sigma avoid env c =
| _ -> c
in
rename avoid env c
-
-(**********************************************************************)
-(* "H"-based naming strategy introduced June 2014 for hypotheses in
- Prop produced by case/elim/destruct/induction, in place of the
- strategy that was using the first letter of the type, leading to
- inelegant "n:~A", "e:t=u", etc. when eliminating sumbool or similar
- types *)
-
-let h_based_elimination_names = ref false
-
-let use_h_based_elimination_names () = !h_based_elimination_names
-
-open Goptions
-
-let _ = declare_bool_option
- { optdepr = true; (* remove in 8.8 *)
- optname = "use of \"H\"-based proposition names in elimination tactics";
- optkey = ["Standard";"Proposition";"Elimination";"Names"];
- optread = (fun () -> !h_based_elimination_names);
- optwrite = (:=) h_based_elimination_names }
diff --git a/engine/namegen.mli b/engine/namegen.mli
index d26634706..1b70ef68d 100644
--- a/engine/namegen.mli
+++ b/engine/namegen.mli
@@ -116,7 +116,6 @@ val compute_displayed_name_in_gen :
(evar_map -> int -> 'a -> bool) ->
evar_map -> Id.Set.t -> Name.t -> 'a -> Name.t * Id.Set.t
-(**********************************************************************)
-(* Naming strategy for arguments in Prop when eliminating inductive types *)
-
-val use_h_based_elimination_names : unit -> bool
+val set_mangle_names_mode : Id.t -> unit
+(** Turn on mangled names mode and with the given prefix.
+ @raise UserError if the argument is invalid as an identifier. *)
diff --git a/engine/proofview.ml b/engine/proofview.ml
index 25c8e2d80..22271dd02 100644
--- a/engine/proofview.ml
+++ b/engine/proofview.ml
@@ -127,7 +127,7 @@ let focus_context (left,right) =
(** This (internal) function extracts a sublist between two indices,
and returns this sublist together with its context: if it returns
- [(a,(b,c))] then [a] is the sublist and (rev b)@a@c is the
+ [(a,(b,c))] then [a] is the sublist and [(rev b) @ a @ c] is the
original list. The focused list has lenght [j-i-1] and contains
the goals from number [i] to number [j] (both included) the first
goal of the list being numbered [1]. [focus_sublist i j l] raises
@@ -572,8 +572,8 @@ let tclDISPATCHL tacs = tclDISPATCHGEN CList.rev tacs
(** [extend_to_list startxs rx endxs l] builds a list
- [startxs@[rx,...,rx]@endxs] of the same length as [l]. Raises
- [SizeMismatch] if [startxs@endxs] is already longer than [l]. *)
+ [startxs @ [rx,...,rx] @ endxs] of the same length as [l]. Raises
+ [SizeMismatch] if [startxs @ endxs] is already longer than [l]. *)
let extend_to_list startxs rx endxs l =
(* spiwack: I use [l] essentially as a natural number *)
let rec duplicate acc = function
@@ -768,10 +768,11 @@ let with_shelf tac =
tac >>= fun ans ->
Pv.get >>= fun npv ->
let { shelf = gls; solution = sigma } = npv in
+ (* The pending future goals are necessarily coming from V82.tactic *)
+ (* and thus considered as to shelve, as in Proof.run_tactic *)
let gls' = Evd.future_goals sigma in
- let fgoals = Evd.future_goals solution in
- let pgoal = Evd.principal_future_goal solution in
- let sigma = Evd.restore_future_goals sigma fgoals pgoal in
+ let fgoals = Evd.save_future_goals solution in
+ let sigma = Evd.restore_future_goals sigma fgoals in
(* Ensure we mark and return only unsolved goals *)
let gls' = undefined_evars sigma (CList.rev_append gls' gls) in
let sigma = CList.fold_left (mark_in_evm ~goal:false) sigma gls' in
@@ -1011,6 +1012,15 @@ module Unsafe = struct
let tclSETGOALS = Comb.set
+ let tclGETSHELF = Shelf.get
+
+ let tclSETSHELF = Shelf.set
+
+ let tclPUTSHELF to_shelve =
+ tclBIND tclGETSHELF (fun shelf -> tclSETSHELF (to_shelve@shelf))
+
+ let tclPUTGIVENUP = Giveup.put
+
let tclEVARSADVANCE evd =
Pv.modify (fun ps -> { ps with solution = evd; comb = undefined evd ps.comb })
diff --git a/engine/proofview.mli b/engine/proofview.mli
index 486279187..e7be66552 100644
--- a/engine/proofview.mli
+++ b/engine/proofview.mli
@@ -435,6 +435,18 @@ module Unsafe : sig
(** [tclGETGOALS] returns the list of goals under focus. *)
val tclGETGOALS : Proofview_monad.goal_with_state list tactic
+ (** [tclSETSHELF gls] sets goals [gls] as the current shelf. *)
+ val tclSETSHELF : Evar.t list -> unit tactic
+
+ (** [tclGETSHELF] returns the list of goals on the shelf. *)
+ val tclGETSHELF : Evar.t list tactic
+
+ (** [tclPUTSHELF] appends goals to the shelf. *)
+ val tclPUTSHELF : Evar.t list -> unit tactic
+
+ (** [tclPUTGIVENUP] add an given up goal. *)
+ val tclPUTGIVENUP : Evar.t list -> unit tactic
+
(** Sets the evar universe context. *)
val tclEVARUNIVCONTEXT : UState.t -> unit tactic
diff --git a/engine/termops.ml b/engine/termops.ml
index c615155d1..35258762a 100644
--- a/engine/termops.ml
+++ b/engine/termops.ml
@@ -294,12 +294,11 @@ let reference_of_level evd l = UState.reference_of_level (Evd.evar_universe_cont
let pr_evar_universe_context ctx =
let open UState in
- let open Evd in
let prl = pr_uctx_level ctx in
if UState.is_empty ctx then mt ()
else
(str"UNIVERSES:"++brk(0,1)++
- h 0 (Univ.pr_universe_context_set prl (evar_universe_context_set ctx)) ++ fnl () ++
+ h 0 (Univ.pr_universe_context_set prl (UState.context_set ctx)) ++ fnl () ++
str"ALGEBRAIC UNIVERSES:"++brk(0,1)++
h 0 (Univ.LSet.pr prl (UState.algebraics ctx)) ++ fnl() ++
str"UNDEFINED UNIVERSES:"++brk(0,1)++
diff --git a/engine/uState.ml b/engine/uState.ml
index 00825208b..e57afd743 100644
--- a/engine/uState.ml
+++ b/engine/uState.ml
@@ -476,6 +476,13 @@ let new_univ_variable ?loc rigid name
uctx_initial_universes = initial}
in uctx', u
+let make_with_initial_binders e us =
+ let uctx = make e in
+ List.fold_left
+ (fun uctx { CAst.loc; v = id } ->
+ fst (new_univ_variable ?loc univ_rigid (Some id) uctx))
+ uctx us
+
let add_global_univ uctx u =
let initial =
UGraph.add_universe u true uctx.uctx_initial_universes
@@ -578,7 +585,7 @@ let refresh_undefined_univ_variables uctx =
uctx_initial_universes = initial } in
uctx', subst
-let normalize uctx =
+let minimize uctx =
let ((vars',algs'), us') =
Universes.normalize_context_set uctx.uctx_local uctx.uctx_univ_variables
uctx.uctx_univ_algebraic
@@ -606,3 +613,6 @@ let update_sigma_env uctx env =
uctx_universes = univs }
in
merge true univ_rigid eunivs eunivs.uctx_local
+
+(** Deprecated *)
+let normalize = minimize
diff --git a/engine/uState.mli b/engine/uState.mli
index 68fe350c0..9a2bc706b 100644
--- a/engine/uState.mli
+++ b/engine/uState.mli
@@ -26,6 +26,8 @@ val empty : t
val make : UGraph.t -> t
+val make_with_initial_binders : UGraph.t -> Misctypes.lident list -> t
+
val is_empty : t -> bool
val union : t -> t -> t
@@ -131,7 +133,10 @@ val fix_undefined_variables : t -> t
val refresh_undefined_univ_variables : t -> t * Univ.universe_level_subst
+(** Universe minimization *)
+val minimize : t -> t
val normalize : t -> t
+[@@ocaml.deprecated "Alias of UState.minimize"]
type universe_decl =
(Misctypes.lident list, Univ.Constraint.t) Misctypes.gen_universe_decl
diff --git a/grammar/tacextend.mlp b/grammar/tacextend.mlp
index 6c072e36a..525be6432 100644
--- a/grammar/tacextend.mlp
+++ b/grammar/tacextend.mlp
@@ -13,15 +13,6 @@
open Q_util
open Argextend
-(** 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 plugin_name = <:expr< __coq_plugin_name >>
let mlexpr_of_ident id =
@@ -29,112 +20,33 @@ let mlexpr_of_ident id =
let id = "$" ^ id in
<:expr< Names.Id.of_string_soft $str:id$ >>
-let rec make_patt = function
- | [] -> <:patt< [] >>
- | ExtNonTerminal (_, Some p) :: l ->
- <:patt< [ $lid:p$ :: $make_patt l$ ] >>
- | _::l -> make_patt l
-
-let rec make_let raw e = function
- | [] -> <:expr< fun $lid:"ist"$ -> $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 raw e l in
- let v =
- if raw then <:expr< Genarg.out_gen $make_rawwit loc t$ $lid:p$ >>
- else <:expr< Tacinterp.Value.cast $make_topwit loc t$ $lid:p$ >> in
- <:expr< let $lid:p$ = $v$ in $e$ >>
- | _::l -> make_let raw e l
-
-let make_clause (pt,e) =
- (make_patt pt,
- ploc_vala None,
- make_let false e pt)
-
-let make_fun_clauses loc s l =
- let map c = make_fun loc [make_clause c] in
- mlexpr_of_list map l
-
-let get_argt e = <:expr< (fun e -> match e with [ Genarg.ExtraArg tag -> tag | _ -> assert False ]) $e$ >>
-
let rec mlexpr_of_symbol = function
-| Ulist1 s -> <:expr< Extend.Ulist1 $mlexpr_of_symbol s$ >>
-| Ulist1sep (s,sep) -> <:expr< Extend.Ulist1sep $mlexpr_of_symbol s$ $str:sep$ >>
-| Ulist0 s -> <:expr< Extend.Ulist0 $mlexpr_of_symbol s$ >>
-| Ulist0sep (s,sep) -> <:expr< Extend.Ulist0sep $mlexpr_of_symbol s$ $str:sep$ >>
-| Uopt s -> <:expr< Extend.Uopt $mlexpr_of_symbol s$ >>
+| 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 arg = get_argt <:expr< $lid:"wit_"^e$ >> in
- <:expr< Extend.Uentry (Genarg.ArgT.Any $arg$) >>
+ let wit = <:expr< $lid:"wit_"^e$ >> in
+ <:expr< Extend.TUentry (Genarg.get_arg_tag $wit$) >>
| Uentryl (e, l) ->
assert (e = "tactic");
- let arg = get_argt <:expr< Tacarg.wit_tactic >> in
- <:expr< Extend.Uentryl (Genarg.ArgT.Any $arg$) $mlexpr_of_int l$>>
-
-let make_prod_item = function
- | ExtTerminal s -> <:expr< Tacentries.TacTerm $str:s$ >>
- | ExtNonTerminal (g, id) ->
- <:expr< Tacentries.TacNonTerm (Loc.tag ( $mlexpr_of_symbol g$ , $mlexpr_of_option mlexpr_of_ident id$ ) ) >>
-
-let mlexpr_of_clause cl =
- mlexpr_of_list (fun (a,_) -> mlexpr_of_list make_prod_item a) cl
-
-(** Special treatment of constr entries *)
-let is_constr_gram = function
-| ExtTerminal _ -> false
-| ExtNonTerminal (Uentry "constr", _) -> true
-| _ -> false
-
-let make_var = function
- | ExtNonTerminal (_, p) -> p
- | _ -> assert false
-
-let declare_tactic loc tacname ~level clause = match clause with
-| [(ExtTerminal name) :: rem, tac] when List.for_all is_constr_gram rem ->
- (** The extension is only made of a name followed by constr entries: we do not
- add any grammar nor printing rule and add it as a true Ltac definition. *)
- let patt = make_patt rem in
- let vars = List.map make_var rem in
- let vars = mlexpr_of_list (mlexpr_of_name mlexpr_of_ident) vars in
- let entry = mlexpr_of_string tacname in
- let se = <:expr< { Tacexpr.mltac_tactic = $entry$; Tacexpr.mltac_plugin = $plugin_name$ } >> in
- let ml = <:expr< { Tacexpr.mltac_name = $se$; Tacexpr.mltac_index = 0 } >> in
- let name = mlexpr_of_string name in
- let tac = match rem with
- | [] ->
- (** Special handling of tactics without arguments: such tactics do not do
- a Proofview.Goal.nf_enter to compute their arguments. It matters for some
- whole-prof tactics like [shelve_unifiable]. *)
- <:expr< fun _ $lid:"ist"$ -> $tac$ >>
- | _ ->
- let f = make_fun loc [patt, ploc_vala None, <:expr< fun $lid:"ist"$ -> $tac$ >>] in
- <:expr< Tacinterp.lift_constr_tac_to_ml_tac $vars$ $f$ >>
- in
- (** Arguments are not passed directly to the ML tactic in the TacML node,
- the ML tactic retrieves its arguments in the [ist] environment instead.
- This is the rôle of the [lift_constr_tac_to_ml_tac] function. *)
- let body = <:expr< Tacexpr.TacFun ($vars$, Tacexpr.TacML (Loc.tag ( $ml$ , []))) >> in
- let name = <:expr< Names.Id.of_string $name$ >> in
- declare_str_items loc
- [ <:str_item< do {
- let obj () = Tacenv.register_ltac True False $name$ $body$ in
- let () = Tacenv.register_ml_tactic $se$ [|$tac$|] in
- Mltop.declare_cache_obj obj $plugin_name$ } >>
- ]
-| _ ->
- (** Otherwise we add parsing and printing rules to generate a call to a
- TacML tactic. *)
- let entry = mlexpr_of_string tacname in
- let se = <:expr< { Tacexpr.mltac_tactic = $entry$; Tacexpr.mltac_plugin = $plugin_name$ } >> in
- let gl = mlexpr_of_clause clause in
- let level = mlexpr_of_int level in
- let obj = <:expr< fun () -> Tacentries.add_ml_tactic_notation $se$ ~{ level = $level$ } $gl$ >> in
- declare_str_items loc
- [ <:str_item< do {
- Tacenv.register_ml_tactic $se$ (Array.of_list $make_fun_clauses loc tacname clause$);
- Mltop.declare_cache_obj $obj$ $plugin_name$; } >>
- ]
+ 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$) >>
+| ExtNonTerminal(g,None) :: cl ->
+ <:expr< TyAnonArg(Loc.tag($mlexpr_of_symbol g$), $mlexpr_of_clause cl$) >>
+| ExtNonTerminal(g,Some id) :: cl ->
+ <:expr< TyArg(Loc.tag($mlexpr_of_symbol g$, $mlexpr_of_ident id$), $mlexpr_of_clause cl$) >>
+
+let rec binders_of_clause e = function
+| [] -> <:expr< fun ist -> $e$ >>
+| ExtNonTerminal(_,None) :: cl -> binders_of_clause e cl
+| ExtNonTerminal(_,Some id) :: cl -> <:expr< fun $lid:id$ -> $binders_of_clause e cl$ >>
+| _ :: cl -> binders_of_clause e cl
open Pcaml
@@ -146,13 +58,17 @@ EXTEND
OPT "|"; l = LIST1 tacrule SEP "|";
"END" ->
let level = match level with Some i -> int_of_string i | None -> 0 in
- declare_tactic loc s ~level l ] ]
+ let level = mlexpr_of_int level in
+ let l = <:expr< Tacentries.($mlexpr_of_list (fun x -> x) l$) >> in
+ declare_str_items loc [ <:str_item< Tacentries.tactic_extend $plugin_name$ $str:s$ ~{ level = $level$ } $l$ >> ] ] ]
;
tacrule:
[ [ "["; l = LIST1 tacargs; "]";
- "->"; "["; e = Pcaml.expr; "]" -> (l,e)
+ "->"; "["; e = Pcaml.expr; "]" ->
+ <:expr< TyML($mlexpr_of_clause l$, $binders_of_clause e l$) >>
] ]
;
+
tacargs:
[ [ e = LIDENT; "("; s = LIDENT; ")" ->
let e = parse_user_entry e "" in
diff --git a/grammar/vernacextend.mlp b/grammar/vernacextend.mlp
index 24ee0042b..a2872d07f 100644
--- a/grammar/vernacextend.mlp
+++ b/grammar/vernacextend.mlp
@@ -12,7 +12,6 @@
open Q_util
open Argextend
-open Tacextend
type rule = {
r_head : string option;
@@ -27,6 +26,21 @@ type rule = {
(** 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 ->
diff --git a/interp/constrintern.ml b/interp/constrintern.ml
index 84162ca89..918e12e5c 100644
--- a/interp/constrintern.ml
+++ b/interp/constrintern.ml
@@ -1077,7 +1077,7 @@ type 'a raw_cases_pattern_expr_r =
| RCPatAlias of 'a raw_cases_pattern_expr * Misctypes.lname
| RCPatCstr of Globnames.global_reference
* 'a raw_cases_pattern_expr list * 'a raw_cases_pattern_expr list
- (** [RCPatCstr (loc, c, l1, l2)] represents ((@c l1) l2) *)
+ (** [RCPatCstr (loc, c, l1, l2)] represents [((@ c l1) l2)] *)
| RCPatAtom of (Misctypes.lident * (Notation_term.tmp_scope_name option * Notation_term.scope_name list)) option
| RCPatOr of 'a raw_cases_pattern_expr list
and 'a raw_cases_pattern_expr = ('a raw_cases_pattern_expr_r, 'a) DAst.t
diff --git a/interp/modintern.ml b/interp/modintern.ml
index 92264fb72..887685585 100644
--- a/interp/modintern.ml
+++ b/interp/modintern.ml
@@ -62,18 +62,19 @@ let lookup_module lqid = fst (lookup_module_or_modtype Module lqid)
let transl_with_decl env = function
| CWith_Module ((_,fqid),qid) ->
WithMod (fqid,lookup_module qid), Univ.ContextSet.empty
- | CWith_Definition ((_,fqid),c) ->
- let sigma = Evd.from_env env in
+ | CWith_Definition ((_,fqid),udecl,c) ->
+ let sigma, udecl = Univdecls.interp_univ_decl_opt env udecl in
let c, ectx = interp_constr env sigma c in
- if Flags.is_universe_polymorphism () then
- let ctx = UState.context ectx in
- let inst, ctx = Univ.abstract_universes ctx in
- let c = EConstr.Vars.subst_univs_level_constr (Univ.make_instance_subst inst) c in
- let c = EConstr.to_constr sigma c in
- WithDef (fqid,(c, Some ctx)), Univ.ContextSet.empty
- else
- let c = EConstr.to_constr sigma c in
- WithDef (fqid,(c, None)), UState.context_set ectx
+ begin match UState.check_univ_decl ~poly:(Flags.is_universe_polymorphism()) ectx udecl with
+ | Entries.Polymorphic_const_entry ctx ->
+ let inst, ctx = Univ.abstract_universes ctx in
+ let c = EConstr.Vars.subst_univs_level_constr (Univ.make_instance_subst inst) c in
+ let c = EConstr.to_constr sigma c in
+ WithDef (fqid,(c, Some ctx)), Univ.ContextSet.empty
+ | Entries.Monomorphic_const_entry ctx ->
+ let c = EConstr.to_constr sigma c in
+ WithDef (fqid,(c, None)), ctx
+ end
let loc_of_module l = l.CAst.loc
diff --git a/intf/constrexpr.ml b/intf/constrexpr.ml
index 474b80ec4..31f811bc8 100644
--- a/intf/constrexpr.ml
+++ b/intf/constrexpr.ml
@@ -17,6 +17,11 @@ open Decl_kinds
(** [constr_expr] is the abstract syntax tree produced by the parser *)
+type universe_decl_expr = (lident list, glob_constraint list) gen_universe_decl
+
+type ident_decl = lident * universe_decl_expr option
+type name_decl = lname * universe_decl_expr option
+
type notation = string
type explicitation =
@@ -51,7 +56,7 @@ type cases_pattern_expr_r =
| CPatAlias of cases_pattern_expr * lname
| CPatCstr of reference
* cases_pattern_expr list option * cases_pattern_expr list
- (** [CPatCstr (_, c, Some l1, l2)] represents (@c l1) l2 *)
+ (** [CPatCstr (_, c, Some l1, l2)] represents [(@ c l1) l2] *)
| CPatAtom of reference option
| CPatOr of cases_pattern_expr list
| CPatNotation of notation * cases_pattern_notation_substitution
@@ -121,7 +126,7 @@ and recursion_order_expr =
| CWfRec of constr_expr
| CMeasureRec of constr_expr * constr_expr option (** measure, relation *)
-(** Anonymous defs allowed ?? *)
+(* Anonymous defs allowed ?? *)
and local_binder_expr =
| CLocalAssum of lname list * binder_kind * constr_expr
| CLocalDef of lname * constr_expr * constr_expr option
@@ -139,7 +144,7 @@ type constr_pattern_expr = constr_expr
type with_declaration_ast =
| CWith_Module of Id.t list Loc.located * qualid Loc.located
- | CWith_Definition of Id.t list Loc.located * constr_expr
+ | CWith_Definition of Id.t list Loc.located * universe_decl_expr option * constr_expr
type module_ast_r =
| CMident of qualid
diff --git a/intf/extend.ml b/intf/extend.ml
index 10c9b3dc1..734b859f6 100644
--- a/intf/extend.ml
+++ b/intf/extend.ml
@@ -85,6 +85,15 @@ type 'a user_symbol =
| Uentry of 'a
| Uentryl of 'a * int
+type ('a,'b,'c) ty_user_symbol =
+| TUlist1 : ('a,'b,'c) ty_user_symbol -> ('a list,'b list,'c list) ty_user_symbol
+| TUlist1sep : ('a,'b,'c) ty_user_symbol * string -> ('a list,'b list,'c list) ty_user_symbol
+| TUlist0 : ('a,'b,'c) ty_user_symbol -> ('a list,'b list,'c list) ty_user_symbol
+| TUlist0sep : ('a,'b,'c) ty_user_symbol * string -> ('a list,'b list,'c list) ty_user_symbol
+| TUopt : ('a,'b,'c) ty_user_symbol -> ('a option, 'b option, 'c option) ty_user_symbol
+| TUentry : ('a, 'b, 'c) Genarg.ArgT.tag -> ('a,'b,'c) ty_user_symbol
+| TUentryl : ('a, 'b, 'c) Genarg.ArgT.tag * int -> ('a,'b,'c) ty_user_symbol
+
(** {5 Type-safe grammar extension} *)
type ('self, 'a) symbol =
diff --git a/intf/vernacexpr.ml b/intf/vernacexpr.ml
index 7e9bc8caa..0a6e5b3b3 100644
--- a/intf/vernacexpr.ml
+++ b/intf/vernacexpr.ml
@@ -160,11 +160,6 @@ type option_ref_value =
(** Identifier and optional list of bound universes and constraints. *)
-type universe_decl_expr = (lident list, glob_constraint list) gen_universe_decl
-
-type ident_decl = lident * universe_decl_expr option
-type name_decl = lname * universe_decl_expr option
-
type sort_expr = Sorts.family
type definition_expr =
@@ -536,3 +531,14 @@ type vernac_when =
| VtNow
| VtLater
type vernac_classification = vernac_type * vernac_when
+
+
+(** Deprecated stuff *)
+type universe_decl_expr = Constrexpr.universe_decl_expr
+[@@ocaml.deprecated "alias of Constrexpr.universe_decl_expr"]
+
+type ident_decl = Constrexpr.ident_decl
+[@@ocaml.deprecated "alias of Constrexpr.ident_decl"]
+
+type name_decl = Constrexpr.name_decl
+[@@ocaml.deprecated "alias of Constrexpr.name_decl"]
diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml
index c5a8c7b23..11faef02c 100644
--- a/kernel/cClosure.ml
+++ b/kernel/cClosure.ml
@@ -798,7 +798,7 @@ let drop_parameters depth n argstk =
s.
@assumes [t] is an irreducible term, and not a constructor. [ind] is the inductive
of the constructor term [c]
- @raises Not_found if the inductive is not a primitive record, or if the
+ @raise Not_found if the inductive is not a primitive record, or if the
constructor is partially applied.
*)
let eta_expand_ind_stack env ind m s (f, s') =
diff --git a/kernel/cClosure.mli b/kernel/cClosure.mli
index 71453a04b..b9c71d72a 100644
--- a/kernel/cClosure.mli
+++ b/kernel/cClosure.mli
@@ -216,7 +216,7 @@ val whd_stack :
s.
@assumes [t] is a rigid term, and not a constructor. [ind] is the inductive
of the constructor term [c]
- @raises Not_found if the inductive is not a primitive record, or if the
+ @raise Not_found if the inductive is not a primitive record, or if the
constructor is partially applied.
*)
val eta_expand_ind_stack : env -> inductive -> fconstr -> stack ->
diff --git a/kernel/environ.mli b/kernel/environ.mli
index 51388b8f3..4e6ac1e72 100644
--- a/kernel/environ.mli
+++ b/kernel/environ.mli
@@ -201,7 +201,7 @@ val lookup_modtype : ModPath.t -> env -> module_type_body
(** {5 Universe constraints } *)
(** Add universe constraints to the environment.
- @raises UniverseInconsistency
+ @raise UniverseInconsistency .
*)
val add_constraints : Univ.Constraint.t -> env -> env
diff --git a/kernel/inductive.ml b/kernel/inductive.ml
index 91c042130..9bed598bb 100644
--- a/kernel/inductive.ml
+++ b/kernel/inductive.ml
@@ -1069,6 +1069,9 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) =
try find_inductive env a
with Not_found ->
raise_err env i (RecursionNotOnInductiveType a) in
+ let mib,_ = lookup_mind_specif env (out_punivs mind) in
+ if mib.mind_finite != Finite then
+ raise_err env i (RecursionNotOnInductiveType a);
(mind, (env', b))
else check_occur env' (n+1) b
else anomaly ~label:"check_one_fix" (Pp.str "Bad occurrence of recursive call.")
diff --git a/kernel/reduction.ml b/kernel/reduction.ml
index e9be1b35d..b3e689414 100644
--- a/kernel/reduction.ml
+++ b/kernel/reduction.ml
@@ -269,8 +269,9 @@ let convert_constructors_gen cmp_instances cmp_cumul (mind, ind, cns) nargs u1 u
if not (Int.equal num_cnstr_args nargs) then
cmp_instances u1 u2 s
else
- let csts = get_cumulativity_constraints CONV cumi u1 u2 in
- cmp_cumul csts s
+ (** By invariant, both constructors have a common supertype,
+ so they are convertible _at that type_. *)
+ s
let convert_constructors ctor nargs u1 u2 (s, check) =
convert_constructors_gen (check.compare_instances ~flex:false) check.compare_cumul_instances
diff --git a/kernel/uGraph.mli b/kernel/uGraph.mli
index 97745771e..d4fba63fb 100644
--- a/kernel/uGraph.mli
+++ b/kernel/uGraph.mli
@@ -43,7 +43,7 @@ val check_constraint : t -> univ_constraint -> bool
val check_constraints : Constraint.t -> t -> bool
(** Adds a universe to the graph, ensuring it is >= or > Set.
- @raises AlreadyDeclared if the level is already declared in the graph. *)
+ @raise AlreadyDeclared if the level is already declared in the graph. *)
exception AlreadyDeclared
diff --git a/lib/coqProject_file.ml4 b/lib/coqProject_file.ml4
index 40945939f..d6c340f69 100644
--- a/lib/coqProject_file.ml4
+++ b/lib/coqProject_file.ml4
@@ -8,27 +8,32 @@
(* * (see LICENSE file for the text of the license) *)
(************************************************************************)
+type arg_source = CmdLine | ProjectFile
+
+type 'a sourced = { thing : 'a; source : arg_source }
+
type project = {
project_file : string option;
makefile : string option;
install_kind : install option;
use_ocamlopt : bool;
- v_files : string list;
- mli_files : string list;
- ml4_files : string list;
- ml_files : string list;
- mllib_files : string list;
- mlpack_files : string list;
-
- ml_includes : path list;
- r_includes : (path * logic_path) list;
- q_includes : (path * logic_path) list;
- extra_args : string list;
- defs : (string * string) list;
-
- extra_targets : extra_target list;
- subdirs : string list;
+ v_files : string sourced list;
+ mli_files : string sourced list;
+ ml4_files : string sourced list;
+ ml_files : string sourced list;
+ mllib_files : string sourced list;
+ mlpack_files : string sourced list;
+
+ ml_includes : path sourced list;
+ r_includes : (path * logic_path) sourced list;
+ q_includes : (path * logic_path) sourced list;
+ extra_args : string sourced list;
+ defs : (string * string) sourced list;
+
+ (* deprecated in favor of a Makefile.local using :: rules *)
+ extra_targets : extra_target sourced list;
+ subdirs : string sourced list;
}
and extra_target = {
target : string;
@@ -114,6 +119,7 @@ let exists_dir dir =
let process_cmd_line orig_dir proj args =
let parsing_project_file = ref (proj.project_file <> None) in
+ let sourced x = { thing = x; source = if !parsing_project_file then ProjectFile else CmdLine } in
let orig_dir = (* avoids turning foo.v in ./foo.v *)
if orig_dir = "." then "" else orig_dir in
let error s = Format.eprintf "@[%a]@@\n%!" Pp.pp_with Pp.(str (s^".")); exit 1 in
@@ -143,17 +149,17 @@ let process_cmd_line orig_dir proj args =
aux { proj with install_kind = Some install } r
| "-extra" :: target :: dependencies :: command :: r ->
let tgt = { target; dependencies; phony = false; command } in
- aux { proj with extra_targets = proj.extra_targets @ [tgt] } r
+ aux { proj with extra_targets = proj.extra_targets @ [sourced tgt] } r
| "-extra-phony" :: target :: dependencies :: command :: r ->
let tgt = { target; dependencies; phony = true; command } in
- aux { proj with extra_targets = proj.extra_targets @ [tgt] } r
+ aux { proj with extra_targets = proj.extra_targets @ [sourced tgt] } r
| "-Q" :: d :: lp :: r ->
- aux { proj with q_includes = proj.q_includes @ [mk_path d,lp] } r
+ aux { proj with q_includes = proj.q_includes @ [sourced (mk_path d,lp)] } r
| "-I" :: d :: r ->
- aux { proj with ml_includes = proj.ml_includes @ [mk_path d] } r
+ aux { proj with ml_includes = proj.ml_includes @ [sourced (mk_path d)] } r
| "-R" :: d :: lp :: r ->
- aux { proj with r_includes = proj.r_includes @ [mk_path d,lp] } r
+ aux { proj with r_includes = proj.r_includes @ [sourced (mk_path d,lp)] } r
| "-f" :: file :: r ->
if !parsing_project_file then
@@ -178,20 +184,21 @@ let process_cmd_line orig_dir proj args =
error "Option -o given more than once";
aux { proj with makefile = Some file } r
| v :: "=" :: def :: r ->
- aux { proj with defs = proj.defs @ [v,def] } r
+ aux { proj with defs = proj.defs @ [sourced (v,def)] } r
| "-arg" :: a :: r ->
- aux { proj with extra_args = proj.extra_args @ [a] } r
+ aux { proj with extra_args = proj.extra_args @ [sourced a] } r
| f :: r ->
let f = CUnix.correct_path f orig_dir in
let proj =
- if exists_dir f then { proj with subdirs = proj.subdirs @ [f] }
+ if exists_dir f then { proj with subdirs = proj.subdirs @ [sourced f] }
else match CUnix.get_extension f with
- | ".v" -> { proj with v_files = proj.v_files @ [f] }
- | ".ml" -> { proj with ml_files = proj.ml_files @ [f] }
- | ".ml4" -> { proj with ml4_files = proj.ml4_files @ [f] }
- | ".mli" -> { proj with mli_files = proj.mli_files @ [f] }
- | ".mllib" -> { proj with mllib_files = proj.mllib_files @ [f] }
- | ".mlpack" -> { proj with mlpack_files = proj.mlpack_files @ [f] }
+ | ".v" ->
+ { proj with v_files = proj.v_files @ [sourced f] }
+ | ".ml" -> { proj with ml_files = proj.ml_files @ [sourced f] }
+ | ".ml4" -> { proj with ml4_files = proj.ml4_files @ [sourced f] }
+ | ".mli" -> { proj with mli_files = proj.mli_files @ [sourced f] }
+ | ".mllib" -> { proj with mllib_files = proj.mllib_files @ [sourced f] }
+ | ".mlpack" -> { proj with mlpack_files = proj.mlpack_files @ [sourced f] }
| _ -> raise (Parsing_error ("Unknown option "^f)) in
aux proj r
in
@@ -215,16 +222,34 @@ let rec find_project_file ~from ~projfile_name =
else find_project_file ~from:newdir ~projfile_name
;;
+let all_files { v_files; ml_files; mli_files; ml4_files;
+ mllib_files; mlpack_files } =
+ v_files @ mli_files @ ml4_files @ ml_files @ mllib_files @ mlpack_files
+
+let map_sourced_list f l = List.map (fun x -> f x.thing) l
+;;
+
+let map_cmdline f l = CList.map_filter (function
+ | {thing=x; source=CmdLine} -> Some (f x)
+ | {source=ProjectFile} -> None) l
+
let coqtop_args_from_project
{ ml_includes; r_includes; q_includes; extra_args }
=
- let map = List.map in
+ let map = map_sourced_list in
let args =
map (fun { canonical_path = i } -> ["-I"; i]) ml_includes @
map (fun ({ canonical_path = i }, l) -> ["-Q"; i; l]) q_includes @
map (fun ({ canonical_path = p }, l) -> ["-R"; p; l]) r_includes @
- [extra_args] in
+ [map (fun x -> x) extra_args] in
List.flatten args
;;
+let filter_cmdline l = CList.map_filter
+ (function {thing; source=CmdLine} -> Some thing | {source=ProjectFile} -> None)
+ l
+;;
+
+let forget_source {thing} = thing
+
(* vim:set ft=ocaml: *)
diff --git a/lib/coqProject_file.mli b/lib/coqProject_file.mli
index 5a4dd3659..5780bb5d7 100644
--- a/lib/coqProject_file.mli
+++ b/lib/coqProject_file.mli
@@ -10,29 +10,32 @@
exception Parsing_error of string
+type arg_source = CmdLine | ProjectFile
+
+type 'a sourced = { thing : 'a; source : arg_source }
+
type project = {
project_file : string option;
makefile : string option;
install_kind : install option;
use_ocamlopt : bool;
- v_files : string list;
- mli_files : string list;
- ml4_files : string list;
- ml_files : string list;
- mllib_files : string list;
- mlpack_files : string list;
+ v_files : string sourced list;
+ mli_files : string sourced list;
+ ml4_files : string sourced list;
+ ml_files : string sourced list;
+ mllib_files : string sourced list;
+ mlpack_files : string sourced list;
- ml_includes : path list;
- r_includes : (path * logic_path) list;
- q_includes : (path * logic_path) list;
- extra_args : string list;
- defs : (string * string) list;
+ ml_includes : path sourced list;
+ r_includes : (path * logic_path) sourced list;
+ q_includes : (path * logic_path) sourced list;
+ extra_args : string sourced list;
+ defs : (string * string) sourced list;
(* deprecated in favor of a Makefile.local using :: rules *)
- extra_targets : extra_target list;
- subdirs : string list;
-
+ extra_targets : extra_target sourced list;
+ subdirs : string sourced list;
}
and extra_target = {
target : string;
@@ -52,3 +55,14 @@ val read_project_file : string -> project
val coqtop_args_from_project : project -> string list
val find_project_file : from:string -> projfile_name:string -> string option
+val all_files : project -> string sourced list
+
+val map_sourced_list : ('a -> 'b) -> 'a sourced list -> 'b list
+
+(** Only uses the elements with source=CmdLine *)
+val map_cmdline : ('a -> 'b) -> 'a sourced list -> 'b list
+
+(** Only uses the elements with source=CmdLine *)
+val filter_cmdline : 'a sourced list -> 'a list
+
+val forget_source : 'a sourced -> 'a
diff --git a/lib/genarg.ml b/lib/genarg.ml
index cf3a2bee7..209d1b271 100644
--- a/lib/genarg.ml
+++ b/lib/genarg.ml
@@ -174,19 +174,22 @@ sig
val default : ('raw, 'glb, 'top) genarg_type -> ('raw, 'glb, 'top) obj option
end
+let get_arg_tag = function
+| ExtraArg s -> s
+| _ -> assert false
+
module Register (M : GenObj) =
struct
module GenMap = ArgMap(struct type ('r, 'g, 't) t = ('r, 'g, 't) M.obj end)
let arg0_map = ref GenMap.empty
- let register0 arg f = match arg with
- | ExtraArg s ->
+ let register0 arg f =
+ let s = get_arg_tag arg in
if GenMap.mem s !arg0_map then
let msg = str M.name ++ str " function already registered: " ++ str (ArgT.repr s) ++ str "." in
CErrors.anomaly msg
else
arg0_map := GenMap.add s (GenMap.Pack f) !arg0_map
- | _ -> assert false
let get_obj0 name =
try
@@ -199,8 +202,6 @@ struct
(** For now, the following function is quite dummy and should only be applied
to an extra argument type, otherwise, it will badly fail. *)
- let obj t = match t with
- | ExtraArg s -> get_obj0 s
- | _ -> assert false
+ let obj t = get_obj0 @@ get_arg_tag t
end
diff --git a/lib/genarg.mli b/lib/genarg.mli
index d49cb334a..bb85f99e3 100644
--- a/lib/genarg.mli
+++ b/lib/genarg.mli
@@ -159,6 +159,9 @@ val unquote : ('a, 'co) abstract_argument_type -> argument_type
This is boilerplate code used here and there in the code of Coq. *)
+val get_arg_tag : ('a, 'b, 'c) genarg_type -> ('a, 'b, 'c) ArgT.tag
+(** Works only on base objects (ExtraArg), otherwise fails badly. *)
+
module type GenObj =
sig
type ('raw, 'glb, 'top) obj
diff --git a/lib/lib.mllib b/lib/lib.mllib
index b2260ba09..089185942 100644
--- a/lib/lib.mllib
+++ b/lib/lib.mllib
@@ -15,7 +15,6 @@ CWarnings
Rtree
System
Explore
-RTree
CProfile
Future
Spawn
diff --git a/library/summary.ml b/library/summary.ml
index 6ca871555..7ef19fbfb 100644
--- a/library/summary.ml
+++ b/library/summary.ml
@@ -89,6 +89,16 @@ let unfreeze_single name state =
Pp.(seq [str "Error unfreezing summary "; str name; fnl (); CErrors.iprint e]);
iraise e
+let warn_summary_out_of_scope =
+ let name = "summary-out-of-scope" in
+ let category = "dev" in
+ let default = CWarnings.Disabled in
+ CWarnings.create ~name ~category ~default (fun name ->
+ Pp.str (Printf.sprintf
+ "A Coq plugin was loaded inside a local scope (such as a Section). It is recommended to load plugins at the start of the file. Summary entry: %s"
+ name)
+ )
+
let unfreeze_summaries ?(partial=false) { summaries; ml_module } =
(* The unfreezing of [ml_modules_summary] has to be anticipated since it
* may modify the content of [summaries] by loading new ML modules *)
@@ -101,7 +111,7 @@ let unfreeze_summaries ?(partial=false) { summaries; ml_module } =
try decl.unfreeze_function String.Map.(find name summaries)
with Not_found ->
if not partial then begin
- Feedback.msg_warning Pp.(str "Summary was captured out of module scope for entry " ++ str name);
+ warn_summary_out_of_scope name;
decl.init_function ()
end;
in
diff --git a/man/coqdep.1 b/man/coqdep.1
index ed727db7c..c417402c2 100644
--- a/man/coqdep.1
+++ b/man/coqdep.1
@@ -80,6 +80,9 @@ Prints the dependencies of Caml modules.
\" of each Coq file given as argument and complete (if needed)
\" the list of Caml modules. The new command is printed on
\" the standard output. No dependency is computed with this option.
+.TP
+.BI \-f \ file
+Read filenames and options -I, -R and -Q from a _CoqProject FILE.
.TP
.BI \-I/\-Q/\-R \ options
Have the same effects on load path and modules names as for other
diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4
index 430d18893..e393c2bbf 100644
--- a/parsing/g_proofs.ml4
+++ b/parsing/g_proofs.ml4
@@ -21,6 +21,24 @@ let thm_token = G_vernac.thm_token
let hint = Gram.entry_create "hint"
+let warn_deprecated_focus =
+ CWarnings.create ~name:"deprecated-focus" ~category:"deprecated"
+ (fun () ->
+ Pp.strbrk
+ "The Focus command is deprecated; use bullets or focusing brackets instead"
+ )
+
+let warn_deprecated_focus_n n =
+ CWarnings.create ~name:"deprecated-focus" ~category:"deprecated"
+ (fun () ->
+ Pp.(str "The Focus command is deprecated;" ++ spc ()
+ ++ str "use '" ++ int n ++ str ": {' instead")
+ )
+
+let warn_deprecated_unfocus =
+ CWarnings.create ~name:"deprecated-unfocus" ~category:"deprecated"
+ (fun () -> Pp.strbrk "The Unfocus command is deprecated")
+
(* Proof commands *)
GEXTEND Gram
GLOBAL: hint command;
@@ -51,9 +69,15 @@ GEXTEND Gram
| IDENT "Undo" -> VernacUndo 1
| IDENT "Undo"; n = natural -> VernacUndo n
| IDENT "Undo"; IDENT "To"; n = natural -> VernacUndoTo n
- | IDENT "Focus" -> VernacFocus None
- | IDENT "Focus"; n = natural -> VernacFocus (Some n)
- | IDENT "Unfocus" -> VernacUnfocus
+ | IDENT "Focus" ->
+ warn_deprecated_focus ~loc:!@loc ();
+ VernacFocus None
+ | IDENT "Focus"; n = natural ->
+ warn_deprecated_focus_n n ~loc:!@loc ();
+ VernacFocus (Some n)
+ | IDENT "Unfocus" ->
+ warn_deprecated_unfocus ~loc:!@loc ();
+ VernacUnfocus
| IDENT "Unfocused" -> VernacUnfocused
| IDENT "Show" -> VernacShow (ShowGoal OpenSubgoals)
| IDENT "Show"; n = natural -> VernacShow (ShowGoal (NthGoal n))
diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4
index 595a60f33..feaef3161 100644
--- a/parsing/g_vernac.ml4
+++ b/parsing/g_vernac.ml4
@@ -12,10 +12,10 @@ open Pp
open CErrors
open Util
open Names
+open Vernacexpr
open Constrexpr
open Constrexpr_ops
open Extend
-open Vernacexpr
open Decl_kinds
open Declarations
open Misctypes
@@ -142,7 +142,7 @@ let name_of_ident_decl : ident_decl -> name_decl =
(* Gallina declarations *)
GEXTEND Gram
GLOBAL: gallina gallina_ext thm_token def_body of_type_with_opt_coercion
- record_field decl_notation rec_definition ident_decl;
+ record_field decl_notation rec_definition ident_decl univ_decl;
gallina:
(* Definition, Theorem, Variable, Axiom, ... *)
@@ -557,8 +557,8 @@ GEXTEND Gram
[ [ qid = qualid -> CAst.make ~loc:!@loc @@ CMident (snd qid) | "("; me = module_expr; ")" -> me ] ]
;
with_declaration:
- [ [ "Definition"; fqid = fullyqualid; ":="; c = Constr.lconstr ->
- CWith_Definition (fqid,c)
+ [ [ "Definition"; fqid = fullyqualid; udecl = OPT univ_decl; ":="; c = Constr.lconstr ->
+ CWith_Definition (fqid,udecl,c)
| IDENT "Module"; fqid = fullyqualid; ":="; qid = qualid ->
CWith_Module (fqid,qid)
] ]
diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml
index 9aae251f1..258c4bb11 100644
--- a/parsing/pcoq.ml
+++ b/parsing/pcoq.ml
@@ -442,6 +442,7 @@ module Prim =
let name = Gram.entry_create "Prim.name"
let identref = Gram.entry_create "Prim.identref"
+ let univ_decl = Gram.entry_create "Prim.univ_decl"
let ident_decl = Gram.entry_create "Prim.ident_decl"
let pattern_ident = Gram.entry_create "pattern_ident"
let pattern_identref = Gram.entry_create "pattern_identref"
diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli
index 8592968dc..e66aa4ade 100644
--- a/parsing/pcoq.mli
+++ b/parsing/pcoq.mli
@@ -198,6 +198,7 @@ module Prim :
val ident : Id.t Gram.entry
val name : lname Gram.entry
val identref : lident Gram.entry
+ val univ_decl : universe_decl_expr Gram.entry
val ident_decl : ident_decl Gram.entry
val pattern_ident : Id.t Gram.entry
val pattern_identref : lident Gram.entry
diff --git a/plugins/extraction/ExtrOcamlNatBigInt.v b/plugins/extraction/ExtrOcamlNatBigInt.v
index 264b48a08..c403f7c5a 100644
--- a/plugins/extraction/ExtrOcamlNatBigInt.v
+++ b/plugins/extraction/ExtrOcamlNatBigInt.v
@@ -46,7 +46,7 @@ Extract Constant EqNat.eq_nat_decide => "Big.eq".
Extract Constant Peano_dec.eq_nat_dec => "Big.eq".
-Extract Constant Compare_dec.nat_compare =>
+Extract Constant Nat.compare =>
"Big.compare_case Eq Lt Gt".
Extract Constant Compare_dec.leb => "Big.le".
diff --git a/plugins/extraction/ExtrOcamlNatInt.v b/plugins/extraction/ExtrOcamlNatInt.v
index 35af71417..a2f809a0c 100644
--- a/plugins/extraction/ExtrOcamlNatInt.v
+++ b/plugins/extraction/ExtrOcamlNatInt.v
@@ -59,7 +59,7 @@ Extract Inlined Constant EqNat.eq_nat_decide => "(=)".
Extract Inlined Constant Peano_dec.eq_nat_dec => "(=)".
-Extract Constant Compare_dec.nat_compare =>
+Extract Constant Nat.compare =>
"fun n m -> if n=m then Eq else if n<m then Lt else Gt".
Extract Inlined Constant Compare_dec.leb => "(<=)".
Extract Inlined Constant Compare_dec.le_lt_dec => "(<=)".
diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml
index 722b3990c..a4e8c44cd 100644
--- a/plugins/extraction/extract_env.ml
+++ b/plugins/extraction/extract_env.ml
@@ -137,22 +137,25 @@ let check_arity env cb =
let t = cb.const_type in
if Reduction.is_arity env t then raise Impossible
-let check_fix env cb i =
+let get_body lbody =
+ EConstr.of_constr (Mod_subst.force_constr lbody)
+
+let check_fix env sg cb i =
match cb.const_body with
| Def lbody ->
- (match Constr.kind (Mod_subst.force_constr lbody) with
- | Fix ((_,j),recd) when Int.equal i j -> check_arity env cb; (true,recd)
+ (match EConstr.kind sg (get_body lbody) with
+ | Fix ((_,j),recd) when Int.equal i j -> check_arity env cb; (true,recd)
| CoFix (j,recd) when Int.equal i j -> check_arity env cb; (false,recd)
| _ -> raise Impossible)
| Undef _ | OpaqueDef _ -> raise Impossible
-let prec_declaration_equal (na1, ca1, ta1) (na2, ca2, ta2) =
+let prec_declaration_equal sg (na1, ca1, ta1) (na2, ca2, ta2) =
Array.equal Name.equal na1 na2 &&
- Array.equal Constr.equal ca1 ca2 &&
- Array.equal Constr.equal ta1 ta2
+ Array.equal (EConstr.eq_constr sg) ca1 ca2 &&
+ Array.equal (EConstr.eq_constr sg) ta1 ta2
-let factor_fix env l cb msb =
- let _,recd as check = check_fix env cb 0 in
+let factor_fix env sg l cb msb =
+ let _,recd as check = check_fix env sg cb 0 in
let n = Array.length (let fi,_,_ = recd in fi) in
if Int.equal n 1 then [|l|], recd, msb
else begin
@@ -163,9 +166,9 @@ let factor_fix env l cb msb =
(fun j ->
function
| (l,SFBconst cb') ->
- let check' = check_fix env cb' (j+1) in
- if not ((fst check : bool) == (fst check') &&
- prec_declaration_equal (snd check) (snd check'))
+ let check' = check_fix env sg cb' (j+1) in
+ if not ((fst check : bool) == (fst check') &&
+ prec_declaration_equal sg (snd check) (snd check'))
then raise Impossible;
labels.(j+1) <- l;
| _ -> raise Impossible) msb';
@@ -248,7 +251,9 @@ and extract_mexpr_spec env mp1 (me_struct_o,me_alg) = match me_alg with
let me_struct,delta = flatten_modtype env mp1 me' me_struct_o in
let env' = env_for_mtb_with_def env mp1 me_struct delta idl in
let mt = extract_mexpr_spec env mp1 (None,me') in
- (match extract_with_type env' c with (* cb may contain some kn *)
+ let sg = Evd.from_env env in
+ (match extract_with_type env' sg (EConstr.of_constr c) with
+ (* cb may contain some kn *)
| None -> mt
| Some (vl,typ) ->
type_iter_references Visit.add_ref typ;
@@ -299,12 +304,13 @@ let rec extract_structure env mp reso ~all = function
| [] -> []
| (l,SFBconst cb) :: struc ->
(try
- let vl,recd,struc = factor_fix env l cb struc in
+ let sg = Evd.from_env env in
+ let vl,recd,struc = factor_fix env sg l cb struc in
let vc = Array.map (make_cst reso mp) vl in
let ms = extract_structure env mp reso ~all struc in
let b = Array.exists Visit.needed_cst vc in
if all || b then
- let d = extract_fixpoint env vc recd in
+ let d = extract_fixpoint env sg vc recd in
if (not b) && (logical_decl d) then ms
else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end
else ms
@@ -572,8 +578,8 @@ let print_structure_to_file (fn,si,mo) dry struc =
let reset () =
Visit.reset (); reset_tables (); reset_renaming_tables Everything
-let init ?(compute=false) modular library =
- check_inside_section (); check_inside_module ();
+let init ?(compute=false) ?(inner=false) modular library =
+ if not inner then (check_inside_section (); check_inside_module ());
set_keywords (descr ()).keywords;
set_modular modular;
set_library library;
@@ -701,10 +707,9 @@ let flatten_structure struc =
and flatten_elems l = List.flatten (List.map flatten_elem l)
in flatten_elems (List.flatten (List.map snd struc))
-let structure_for_compute c =
+let structure_for_compute env sg c =
init false false ~compute:true;
- let env = Global.env () in
- let ast, mlt = Extraction.extract_constr env c in
+ let ast, mlt = Extraction.extract_constr env sg c in
let ast = Mlutil.normalize ast in
let refs = ref Refset.empty in
let add_ref r = refs := Refset.add r !refs in
@@ -744,3 +749,20 @@ let extract_and_compile l =
let base = Filename.chop_suffix f ".ml" in
let () = remove (base^".cmo"); remove (base^".cmi") in
Feedback.msg_notice (str "Extracted code successfully compiled")
+
+(* Show the extraction of the current ongoing proof *)
+
+let show_extraction () =
+ init ~inner:true false false;
+ let prf = Proof_global.give_me_the_proof () in
+ let sigma, env = Pfedit.get_current_context () in
+ let trms = Proof.partial_proof prf in
+ let extr_term t =
+ let ast, ty = extract_constr env sigma t in
+ let mp = Lib.current_mp () in
+ let l = Label.of_id (Proof_global.get_current_proof_name ()) in
+ let fake_ref = ConstRef (Constant.make2 mp l) in
+ let decl = Dterm (fake_ref, ast, ty) in
+ print_one_decl [] mp decl
+ in
+ Feedback.msg_notice (Pp.prlist_with_sep Pp.fnl extr_term trms)
diff --git a/plugins/extraction/extract_env.mli b/plugins/extraction/extract_env.mli
index 464f109be..591d3bb86 100644
--- a/plugins/extraction/extract_env.mli
+++ b/plugins/extraction/extract_env.mli
@@ -36,4 +36,9 @@ val print_one_decl :
(* Used by Extraction Compute *)
val structure_for_compute :
- Constr.t -> (Miniml.ml_decl list) * Miniml.ml_ast * Miniml.ml_type
+ Environ.env -> Evd.evar_map -> EConstr.t ->
+ Miniml.ml_decl list * Miniml.ml_ast * Miniml.ml_type
+
+(* Show the extraction of the current ongoing proof *)
+
+val show_extraction : unit -> unit
diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml
index ce4970056..f25f63624 100644
--- a/plugins/extraction/extraction.ml
+++ b/plugins/extraction/extraction.ml
@@ -13,7 +13,6 @@ open Util
open Names
open Term
open Constr
-open Vars
open Declarations
open Declareops
open Environ
@@ -36,20 +35,18 @@ exception I of inductive_kind
(* A set of all fixpoint functions currently being extracted *)
let current_fixpoints = ref ([] : Constant.t list)
-let none = Evd.empty
-
(* NB: In OCaml, [type_of] and [get_of] might raise
[SingletonInductiveBecomeProp]. This exception will be caught
in late wrappers around the exported functions of this file,
in order to display the location of the issue. *)
-let type_of env c =
+let type_of env sg c =
let polyprop = (lang() == Haskell) in
- EConstr.Unsafe.to_constr (Retyping.get_type_of ~polyprop env none (strip_outer_cast none (EConstr.of_constr c)))
+ Retyping.get_type_of ~polyprop env sg (strip_outer_cast sg c)
-let sort_of env c =
+let sort_of env sg c =
let polyprop = (lang() == Haskell) in
- Retyping.get_sort_family_of ~polyprop env none (strip_outer_cast none (EConstr.of_constr c))
+ Retyping.get_sort_family_of ~polyprop env sg (strip_outer_cast sg c)
(*S Generation of flags and signatures. *)
@@ -73,61 +70,91 @@ type scheme = TypeScheme | Default
type flag = info * scheme
-let whd_all env t =
- EConstr.Unsafe.to_constr (whd_all env none (EConstr.of_constr t))
-
-let whd_betaiotazeta t =
- EConstr.Unsafe.to_constr (whd_betaiotazeta none (EConstr.of_constr t))
-
(*s [flag_of_type] transforms a type [t] into a [flag].
Really important function. *)
-let rec flag_of_type env t : flag =
- let t = whd_all env t in
- match Constr.kind t with
- | Prod (x,t,c) -> flag_of_type (push_rel (LocalAssum (x,t)) env) c
- | Sort s when Sorts.is_prop s -> (Logic,TypeScheme)
+let rec flag_of_type env sg t : flag =
+ let t = whd_all env sg t in
+ match EConstr.kind sg t with
+ | Prod (x,t,c) -> flag_of_type (EConstr.push_rel (LocalAssum (x,t)) env) sg c
+ | Sort s when Sorts.is_prop (EConstr.ESorts.kind sg s) -> (Logic,TypeScheme)
| Sort _ -> (Info,TypeScheme)
- | _ -> if (sort_of env t) == InProp then (Logic,Default) else (Info,Default)
+ | _ -> if (sort_of env sg t) == InProp then (Logic,Default) else (Info,Default)
(*s Two particular cases of [flag_of_type]. *)
-let is_default env t = match flag_of_type env t with
+let is_default env sg t = match flag_of_type env sg t with
| (Info, Default) -> true
| _ -> false
exception NotDefault of kill_reason
-let check_default env t =
- match flag_of_type env t with
+let check_default env sg t =
+ match flag_of_type env sg t with
| _,TypeScheme -> raise (NotDefault Ktype)
| Logic,_ -> raise (NotDefault Kprop)
| _ -> ()
-let is_info_scheme env t = match flag_of_type env t with
+let is_info_scheme env sg t = match flag_of_type env sg t with
| (Info, TypeScheme) -> true
| _ -> false
let push_rel_assum (n, t) env =
- Environ.push_rel (LocalAssum (n, t)) env
+ EConstr.push_rel (LocalAssum (n, t)) env
+
+let push_rels_assum assums =
+ EConstr.push_rel_context (List.map (fun (x,t) -> LocalAssum (x,t)) assums)
+
+let get_body lconstr = EConstr.of_constr (Mod_subst.force_constr lconstr)
+
+let get_opaque env c =
+ EConstr.of_constr
+ (Opaqueproof.force_proof (Environ.opaque_tables env) c)
+
+let applistc c args = EConstr.mkApp (c, Array.of_list args)
+
+(* Same as [Environ.push_rec_types], but for [EConstr.t] *)
+let push_rec_types (lna,typarray,_) env =
+ let ctxt =
+ Array.map2_i
+ (fun i na t -> LocalAssum (na, EConstr.Vars.lift i t)) lna typarray
+ in
+ Array.fold_left (fun e assum -> EConstr.push_rel assum e) env ctxt
+
+(* Same as [Termops.nb_lam], but for [EConstr.t] *)
+let nb_lam sg c = List.length (fst (EConstr.decompose_lam sg c))
+
+(* Same as [Term.decompose_lam_n] but for [EConstr.t] *)
+let decompose_lam_n sg n =
+ let rec lamdec_rec l n c =
+ if n <= 0 then l,c
+ else match EConstr.kind sg c with
+ | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) (n-1) c
+ | Cast (c,_,_) -> lamdec_rec l n c
+ | _ -> raise Not_found
+ in
+ lamdec_rec [] n
(*s [type_sign] gernerates a signature aimed at treating a type application. *)
-let rec type_sign env c =
- match Constr.kind (whd_all env c) with
+let rec type_sign env sg c =
+ match EConstr.kind sg (whd_all env sg c) with
| Prod (n,t,d) ->
- (if is_info_scheme env t then Keep else Kill Kprop)
- :: (type_sign (push_rel_assum (n,t) env) d)
+ (if is_info_scheme env sg t then Keep else Kill Kprop)
+ :: (type_sign (push_rel_assum (n,t) env) sg d)
| _ -> []
-let rec type_scheme_nb_args env c =
- match Constr.kind (whd_all env c) with
+let rec type_scheme_nb_args env sg c =
+ match EConstr.kind sg (whd_all env sg c) with
| Prod (n,t,d) ->
- let n = type_scheme_nb_args (push_rel_assum (n,t) env) d in
- if is_info_scheme env t then n+1 else n
+ let n = type_scheme_nb_args (push_rel_assum (n,t) env) sg d in
+ if is_info_scheme env sg t then n+1 else n
| _ -> 0
-let _ = Hook.set type_scheme_nb_args_hook type_scheme_nb_args
+let type_scheme_nb_args' env c =
+ type_scheme_nb_args env (Evd.from_env env) (EConstr.of_constr c)
+
+let _ = Hook.set type_scheme_nb_args_hook type_scheme_nb_args'
(*s [type_sign_vl] does the same, plus a type var list. *)
@@ -147,19 +174,19 @@ let make_typvar n vl =
let vl = Id.Set.of_list vl in
next_ident_away id' vl
-let rec type_sign_vl env c =
- match Constr.kind (whd_all env c) with
+let rec type_sign_vl env sg c =
+ match EConstr.kind sg (whd_all env sg c) with
| Prod (n,t,d) ->
- let s,vl = type_sign_vl (push_rel_assum (n,t) env) d in
- if not (is_info_scheme env t) then Kill Kprop::s, vl
- else Keep::s, (make_typvar n vl) :: vl
+ let s,vl = type_sign_vl (push_rel_assum (n,t) env) sg d in
+ if not (is_info_scheme env sg t) then Kill Kprop::s, vl
+ else Keep::s, (make_typvar n vl) :: vl
| _ -> [],[]
-let rec nb_default_params env c =
- match Constr.kind (whd_all env c) with
+let rec nb_default_params env sg c =
+ match EConstr.kind sg (whd_all env sg c) with
| Prod (n,t,d) ->
- let n = nb_default_params (push_rel_assum (n,t) env) d in
- if is_default env t then n+1 else n
+ let n = nb_default_params (push_rel_assum (n,t) env) sg d in
+ if is_default env sg t then n+1 else n
| _ -> 0
(* Enriching a signature with implicit information *)
@@ -226,62 +253,62 @@ let parse_ind_args si args relmax =
generate ML type var anymore (in subterms for example). *)
-let rec extract_type env db j c args =
- match Constr.kind (whd_betaiotazeta c) with
+let rec extract_type env sg db j c args =
+ match EConstr.kind sg (whd_betaiotazeta sg c) with
| App (d, args') ->
- (* We just accumulate the arguments. *)
- extract_type env db j d (Array.to_list args' @ args)
+ (* We just accumulate the arguments. *)
+ extract_type env sg db j d (Array.to_list args' @ args)
| Lambda (_,_,d) ->
(match args with
| [] -> assert false (* A lambda cannot be a type. *)
- | a :: args -> extract_type env db j (subst1 a d) args)
+ | a :: args -> extract_type env sg db j (EConstr.Vars.subst1 a d) args)
| Prod (n,t,d) ->
assert (List.is_empty args);
let env' = push_rel_assum (n,t) env in
- (match flag_of_type env t with
+ (match flag_of_type env sg t with
| (Info, Default) ->
(* Standard case: two [extract_type] ... *)
- let mld = extract_type env' (0::db) j d [] in
+ let mld = extract_type env' sg (0::db) j d [] in
(match expand env mld with
| Tdummy d -> Tdummy d
- | _ -> Tarr (extract_type env db 0 t [], mld))
+ | _ -> Tarr (extract_type env sg db 0 t [], mld))
| (Info, TypeScheme) when j > 0 ->
(* A new type var. *)
- let mld = extract_type env' (j::db) (j+1) d [] in
+ let mld = extract_type env' sg (j::db) (j+1) d [] in
(match expand env mld with
| Tdummy d -> Tdummy d
| _ -> Tarr (Tdummy Ktype, mld))
| _,lvl ->
- let mld = extract_type env' (0::db) j d [] in
+ let mld = extract_type env' sg (0::db) j d [] in
(match expand env mld with
| Tdummy d -> Tdummy d
| _ ->
let reason = if lvl == TypeScheme then Ktype else Kprop in
Tarr (Tdummy reason, mld)))
| Sort _ -> Tdummy Ktype (* The two logical cases. *)
- | _ when sort_of env (applistc c args) == InProp -> Tdummy Kprop
+ | _ when sort_of env sg (applistc c args) == InProp -> Tdummy Kprop
| Rel n ->
- (match lookup_rel n env with
- | LocalDef (_,t,_) -> extract_type env db j (lift n t) args
+ (match EConstr.lookup_rel n env with
+ | LocalDef (_,t,_) ->
+ extract_type env sg db j (EConstr.Vars.lift n t) args
| _ ->
(* Asks [db] a translation for [n]. *)
if n > List.length db then Tunknown
else let n' = List.nth db (n-1) in
if Int.equal n' 0 then Tunknown else Tvar n')
- | Const (kn,u as c) ->
- let r = ConstRef kn in
- let cb = lookup_constant kn env in
- let typ = Typeops.type_of_constant_in env c in
- (match flag_of_type env typ with
+ | Const (kn,u) ->
+ let r = ConstRef kn in
+ let typ = type_of env sg (EConstr.mkConstU (kn,u)) in
+ (match flag_of_type env sg typ with
| (Logic,_) -> assert false (* Cf. logical cases above *)
| (Info, TypeScheme) ->
- let mlt = extract_type_app env db (r, type_sign env typ) args in
- (match cb.const_body with
+ let mlt = extract_type_app env sg db (r, type_sign env sg typ) args in
+ (match (lookup_constant kn env).const_body with
| Undef _ | OpaqueDef _ -> mlt
- | Def _ when is_custom r -> mlt
+ | Def _ when is_custom (ConstRef kn) -> mlt
| Def lbody ->
- let newc = applistc (Mod_subst.force_constr lbody) args in
- let mlt' = extract_type env db j newc [] in
+ let newc = applistc (get_body lbody) args in
+ let mlt' = extract_type env sg db j newc [] in
(* ML type abbreviations interact badly with Coq *)
(* reduction, so [mlt] and [mlt'] might be different: *)
(* The more precise is [mlt'], extracted after reduction *)
@@ -290,36 +317,51 @@ let rec extract_type env db j c args =
if eq_ml_type (expand env mlt) (expand env mlt') then mlt else mlt')
| (Info, Default) ->
(* Not an ML type, for example [(c:forall X, X->X) Type nat] *)
- (match cb.const_body with
+ (match (lookup_constant kn env).const_body with
| Undef _ | OpaqueDef _ -> Tunknown (* Brutal approx ... *)
| Def lbody ->
(* We try to reduce. *)
- let newc = applistc (Mod_subst.force_constr lbody) args in
- extract_type env db j newc []))
+ let newc = applistc (get_body lbody) args in
+ extract_type env sg db j newc []))
| Ind ((kn,i),u) ->
- let s = (extract_ind env kn).ind_packets.(i).ip_sign in
- extract_type_app env db (IndRef (kn,i),s) args
+ let s = (extract_ind env kn).ind_packets.(i).ip_sign in
+ extract_type_app env sg db (IndRef (kn,i),s) args
| Proj (p,t) ->
(* Let's try to reduce, if it hasn't already been done. *)
if Projection.unfolded p then Tunknown
- else extract_type env db j (mkProj (Projection.unfold p, t)) args
+ else
+ extract_type env sg db j (EConstr.mkProj (Projection.unfold p, t)) args
| Case _ | Fix _ | CoFix _ -> Tunknown
- | Var _ | Meta _ | Evar _ | Cast _ | LetIn _ | Construct _ -> assert false
+ | Evar _ | Meta _ -> Taxiom (* only possible during Show Extraction *)
+ | Var v ->
+ (* For Show Extraction *)
+ let open Context.Named.Declaration in
+ (match EConstr.lookup_named v env with
+ | LocalDef (_,body,_) ->
+ extract_type env sg db j (EConstr.applist (body,args)) []
+ | LocalAssum (_,ty) ->
+ let r = VarRef v in
+ (match flag_of_type env sg ty with
+ | (Logic,_) -> assert false (* Cf. logical cases above *)
+ | (Info, TypeScheme) ->
+ extract_type_app env sg db (r, type_sign env sg ty) args
+ | (Info, Default) -> Tunknown))
+ | Cast _ | LetIn _ | Construct _ -> assert false
(*s Auxiliary function dealing with type application.
Precondition: [r] is a type scheme represented by the signature [s],
and is completely applied: [List.length args = List.length s]. *)
-and extract_type_app env db (r,s) args =
+and extract_type_app env sg db (r,s) args =
let ml_args =
List.fold_right
(fun (b,c) a -> if b == Keep then
- let p = List.length (fst (splay_prod env none (EConstr.of_constr (type_of env c)))) in
+ let p = List.length (fst (splay_prod env sg (type_of env sg c))) in
let db = iterate (fun l -> 0 :: l) p db in
- (extract_type_scheme env db c p) :: a
+ (extract_type_scheme env sg db c p) :: a
else a)
(List.combine s args) []
- in Tglob (r, ml_args)
+ in Tglob (r, ml_args)
(*S Extraction of a type scheme. *)
@@ -330,19 +372,18 @@ and extract_type_app env db (r,s) args =
(* [db] is a context for translating Coq [Rel] into ML type [Tvar]. *)
-and extract_type_scheme env db c p =
- if Int.equal p 0 then extract_type env db 0 c []
+and extract_type_scheme env sg db c p =
+ if Int.equal p 0 then extract_type env sg db 0 c []
else
- let c = whd_betaiotazeta c in
- match Constr.kind c with
+ let c = whd_betaiotazeta sg c in
+ match EConstr.kind sg c with
| Lambda (n,t,d) ->
- extract_type_scheme (push_rel_assum (n,t) env) db d (p-1)
+ extract_type_scheme (push_rel_assum (n,t) env) sg db d (p-1)
| _ ->
- let rels = fst (splay_prod env none (EConstr.of_constr (type_of env c))) in
- let rels = List.map (on_snd EConstr.Unsafe.to_constr) rels in
+ let rels = fst (splay_prod env sg (type_of env sg c)) in
let env = push_rels_assum rels env in
- let eta_args = List.rev_map mkRel (List.interval 1 p) in
- extract_type env db 0 (lift p c) eta_args
+ let eta_args = List.rev_map EConstr.mkRel (List.interval 1 p) in
+ extract_type env sg db 0 (EConstr.Vars.lift p c) eta_args
(*S Extraction of an inductive type. *)
@@ -384,6 +425,7 @@ and extract_really_ind env kn mib =
let mip0 = mib.mind_packets.(0) in
let npar = mib.mind_nparams in
let epar = push_rel_context mib.mind_params_ctxt env in
+ let sg = Evd.from_env env in
(* First pass: we store inductive signatures together with *)
(* their type var list. *)
let packets =
@@ -391,8 +433,9 @@ and extract_really_ind env kn mib =
(fun i mip ->
let (_,u),_ = Universes.fresh_inductive_instance env (kn,i) in
let ar = Inductive.type_of_inductive env ((mib,mip),u) in
- let info = (fst (flag_of_type env ar) = Info) in
- let s,v = if info then type_sign_vl env ar else [],[] in
+ let ar = EConstr.of_constr ar in
+ let info = (fst (flag_of_type env sg ar) = Info) in
+ let s,v = if info then type_sign_vl env sg ar else [],[] in
let t = Array.make (Array.length mip.mind_nf_lc) [] in
{ ip_typename = mip.mind_typename;
ip_consnames = mip.mind_consnames;
@@ -424,7 +467,8 @@ and extract_really_ind env kn mib =
in
let dbmap = parse_ind_args p.ip_sign args (nprods + npar) in
let db = db_from_ind dbmap npar in
- p.ip_types.(j) <- extract_type_cons epar db dbmap t (npar+1)
+ p.ip_types.(j) <-
+ extract_type_cons epar sg db dbmap (EConstr.of_constr t) (npar+1)
done
done;
(* Third pass: we determine special cases. *)
@@ -477,10 +521,9 @@ and extract_really_ind env kn mib =
(* Is this record officially declared with its projections ? *)
(* If so, we use this information. *)
begin try
- let n = nb_default_params env
- (Inductive.type_of_inductive env ((mib,mip0),u))
- in
- let check_proj kn = if Cset.mem kn !projs then add_projection n kn ip
+ let ty = Inductive.type_of_inductive env ((mib,mip0),u) in
+ let n = nb_default_params env sg (EConstr.of_constr ty) in
+ let check_proj kn = if Cset.mem kn !projs then add_projection n kn ip
in
List.iter (Option.iter check_proj) (lookup_projections ip)
with Not_found -> ()
@@ -505,13 +548,13 @@ and extract_really_ind env kn mib =
- [i] is the rank of the current product (initially [params_nb+1])
*)
-and extract_type_cons env db dbmap c i =
- match Constr.kind (whd_all env c) with
+and extract_type_cons env sg db dbmap c i =
+ match EConstr.kind sg (whd_all env sg c) with
| Prod (n,t,d) ->
let env' = push_rel_assum (n,t) env in
let db' = (try Int.Map.find i dbmap with Not_found -> 0) :: db in
- let l = extract_type_cons env' db' dbmap d (i+1) in
- (extract_type env db 0 t []) :: l
+ let l = extract_type_cons env' sg db' dbmap d (i+1) in
+ (extract_type env sg db 0 t []) :: l
| _ -> []
(*s Recording the ML type abbreviation of a Coq type scheme constant. *)
@@ -526,16 +569,17 @@ and mlt_env env r = match r with
match lookup_typedef kn cb with
| Some _ as o -> o
| None ->
- let typ = cb.const_type
+ let sg = Evd.from_env env in
+ let typ = EConstr.of_constr cb.const_type
(* FIXME not sure if we should instantiate univs here *) in
- match flag_of_type env typ with
- | Info,TypeScheme ->
- let body = Mod_subst.force_constr l_body in
- let s = type_sign env typ in
- let db = db_from_sign s in
- let t = extract_type_scheme env db body (List.length s)
- in add_typedef kn cb t; Some t
- | _ -> None
+ match flag_of_type env sg typ with
+ | Info,TypeScheme ->
+ let body = get_body l_body in
+ let s = type_sign env sg typ in
+ let db = db_from_sign s in
+ let t = extract_type_scheme env sg db body (List.length s)
+ in add_typedef kn cb t; Some t
+ | _ -> None
and expand env = type_expand (mlt_env env)
and type2signature env = type_to_signature (mlt_env env)
@@ -545,16 +589,16 @@ let type_expunge_from_sign env = type_expunge_from_sign (mlt_env env)
(*s Extraction of the type of a constant. *)
-let record_constant_type env kn opt_typ =
+let record_constant_type env sg kn opt_typ =
let cb = lookup_constant kn env in
match lookup_cst_type kn cb with
| Some schema -> schema
| None ->
let typ = match opt_typ with
- | None -> cb.const_type
+ | None -> EConstr.of_constr cb.const_type
| Some typ -> typ
in
- let mlt = extract_type env [] 1 typ [] in
+ let mlt = extract_type env sg [] 1 typ [] in
let schema = (type_maxvar mlt, mlt) in
let () = add_cst_type kn cb schema in
schema
@@ -566,75 +610,86 @@ let record_constant_type env kn opt_typ =
(* [mle] is a ML environment [Mlenv.t]. *)
(* [mlt] is the ML type we want our extraction of [(c args)] to have. *)
-let rec extract_term env mle mlt c args =
- match Constr.kind c with
+let rec extract_term env sg mle mlt c args =
+ match EConstr.kind sg c with
| App (f,a) ->
- extract_term env mle mlt f (Array.to_list a @ args)
+ extract_term env sg mle mlt f (Array.to_list a @ args)
| Lambda (n, t, d) ->
let id = id_of_name n in
(match args with
| a :: l ->
(* We make as many [LetIn] as possible. *)
- let d' = mkLetIn (Name id,a,t,applistc d (List.map (lift 1) l))
- in extract_term env mle mlt d' []
+ let l' = List.map (EConstr.Vars.lift 1) l in
+ let d' = EConstr.mkLetIn (Name id,a,t,applistc d l') in
+ extract_term env sg mle mlt d' []
| [] ->
let env' = push_rel_assum (Name id, t) env in
let id, a =
- try check_default env t; Id id, new_meta()
- with NotDefault d -> Dummy, Tdummy d
+ try check_default env sg t; Id id, new_meta()
+ with NotDefault d -> Dummy, Tdummy d
in
let b = new_meta () in
(* If [mlt] cannot be unified with an arrow type, then magic! *)
let magic = needs_magic (mlt, Tarr (a, b)) in
- let d' = extract_term env' (Mlenv.push_type mle a) b d [] in
+ let d' = extract_term env' sg (Mlenv.push_type mle a) b d [] in
put_magic_if magic (MLlam (id, d')))
| LetIn (n, c1, t1, c2) ->
let id = id_of_name n in
- let env' = push_rel (LocalDef (Name id, c1, t1)) env in
+ let env' = EConstr.push_rel (LocalDef (Name id, c1, t1)) env in
(* We directly push the args inside the [LetIn].
TODO: the opt_let_app flag is supposed to prevent that *)
- let args' = List.map (lift 1) args in
+ let args' = List.map (EConstr.Vars.lift 1) args in
(try
- check_default env t1;
+ check_default env sg t1;
let a = new_meta () in
- let c1' = extract_term env mle a c1 [] in
+ let c1' = extract_term env sg mle a c1 [] in
(* The type of [c1'] is generalized and stored in [mle]. *)
let mle' =
if generalizable c1'
then Mlenv.push_gen mle a
else Mlenv.push_type mle a
in
- MLletin (Id id, c1', extract_term env' mle' mlt c2 args')
+ MLletin (Id id, c1', extract_term env' sg mle' mlt c2 args')
with NotDefault d ->
let mle' = Mlenv.push_std_type mle (Tdummy d) in
- ast_pop (extract_term env' mle' mlt c2 args'))
+ ast_pop (extract_term env' sg mle' mlt c2 args'))
| Const (kn,_) ->
- extract_cst_app env mle mlt kn args
+ extract_cst_app env sg mle mlt kn args
| Construct (cp,_) ->
- extract_cons_app env mle mlt cp args
+ extract_cons_app env sg mle mlt cp args
| Proj (p, c) ->
- let term = Retyping.expand_projection env (Evd.from_env env) p (EConstr.of_constr c) [] in
- let term = EConstr.Unsafe.to_constr term in
- extract_term env mle mlt term args
+ let term = Retyping.expand_projection env (Evd.from_env env) p c [] in
+ extract_term env sg mle mlt term args
| Rel n ->
(* As soon as the expected [mlt] for the head is known, *)
(* we unify it with an fresh copy of the stored type of [Rel n]. *)
let extract_rel mlt = put_magic (mlt, Mlenv.get mle n) (MLrel n)
- in extract_app env mle mlt extract_rel args
+ in extract_app env sg mle mlt extract_rel args
| Case ({ci_ind=ip},_,c0,br) ->
- extract_app env mle mlt (extract_case env mle (ip,c0,br)) args
+ extract_app env sg mle mlt (extract_case env sg mle (ip,c0,br)) args
| Fix ((_,i),recd) ->
- extract_app env mle mlt (extract_fix env mle i recd) args
+ extract_app env sg mle mlt (extract_fix env sg mle i recd) args
| CoFix (i,recd) ->
- extract_app env mle mlt (extract_fix env mle i recd) args
- | Cast (c,_,_) -> extract_term env mle mlt c args
- | Ind _ | Prod _ | Sort _ | Meta _ | Evar _ | Var _ -> assert false
+ extract_app env sg mle mlt (extract_fix env sg mle i recd) args
+ | Cast (c,_,_) -> extract_term env sg mle mlt c args
+ | Evar _ | Meta _ -> MLaxiom
+ | Var v ->
+ (* Only during Show Extraction *)
+ let open Context.Named.Declaration in
+ let ty = match EConstr.lookup_named v env with
+ | LocalAssum (_,ty) -> ty
+ | LocalDef (_,_,ty) -> ty
+ in
+ let vty = extract_type env sg [] 0 ty [] in
+ let extract_var mlt = put_magic (mlt,vty) (MLglob (VarRef v)) in
+ extract_app env sg mle mlt extract_var args
+ | Ind _ | Prod _ | Sort _ -> assert false
(*s [extract_maybe_term] is [extract_term] for usual terms, else [MLdummy] *)
-and extract_maybe_term env mle mlt c =
- try check_default env (type_of env c);
- extract_term env mle mlt c []
+and extract_maybe_term env sg mle mlt c =
+ try check_default env sg (type_of env sg c);
+ extract_term env sg mle mlt c []
with NotDefault d ->
put_magic (mlt, Tdummy d) (MLdummy d)
@@ -644,28 +699,28 @@ and extract_maybe_term env mle mlt c =
This gives us the expected type of the head. Then we use the
[mk_head] to produce the ML head from this type. *)
-and extract_app env mle mlt mk_head args =
+and extract_app env sg mle mlt mk_head args =
let metas = List.map new_meta args in
let type_head = type_recomp (metas, mlt) in
- let mlargs = List.map2 (extract_maybe_term env mle) metas args in
+ let mlargs = List.map2 (extract_maybe_term env sg mle) metas args in
mlapp (mk_head type_head) mlargs
(*s Auxiliary function used to extract arguments of constant or constructor. *)
-and make_mlargs env e s args typs =
+and make_mlargs env sg e s args typs =
let rec f = function
| [], [], _ -> []
- | a::la, t::lt, [] -> extract_maybe_term env e t a :: (f (la,lt,[]))
- | a::la, t::lt, Keep::s -> extract_maybe_term env e t a :: (f (la,lt,s))
+ | a::la, t::lt, [] -> extract_maybe_term env sg e t a :: (f (la,lt,[]))
+ | a::la, t::lt, Keep::s -> extract_maybe_term env sg e t a :: (f (la,lt,s))
| _::la, _::lt, _::s -> f (la,lt,s)
| _ -> assert false
in f (args,typs,s)
(*s Extraction of a constant applied to arguments. *)
-and extract_cst_app env mle mlt kn args =
+and extract_cst_app env sg mle mlt kn args =
(* First, the [ml_schema] of the constant, in expanded version. *)
- let nb,t = record_constant_type env kn None in
+ let nb,t = record_constant_type env sg kn None in
let schema = nb, expand env t in
(* Can we instantiate types variables for this constant ? *)
(* In Ocaml, inside the definition of this constant, the answer is no. *)
@@ -691,7 +746,7 @@ and extract_cst_app env mle mlt kn args =
let ls = List.length s in
let la = List.length args in
(* The ml arguments, already expunged from known logical ones *)
- let mla = make_mlargs env mle s args metas in
+ let mla = make_mlargs env sg mle s args metas in
let mla =
if magic1 || lang () != Ocaml then mla
else
@@ -736,7 +791,7 @@ and extract_cst_app env mle mlt kn args =
they are fixed, and thus are not used for the computation.
\end{itemize} *)
-and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args =
+and extract_cons_app env sg mle mlt (((kn,i) as ip,j) as cp) args =
(* First, we build the type of the constructor, stored in small pieces. *)
let mi = extract_ind env kn in
let params_nb = mi.ind_nparams in
@@ -777,7 +832,7 @@ and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args =
put_magic_if magic2
(dummy_lams (anonym_or_dummy_lams head' s) (params_nb - la))
else
- let mla = make_mlargs env mle s args' metas in
+ let mla = make_mlargs env sg mle s args' metas in
if Int.equal la (ls + params_nb)
then put_magic_if (magic2 && not magic1) (head mla)
else (* [ params_nb <= la <= ls + params_nb ] *)
@@ -788,7 +843,7 @@ and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args =
(*S Extraction of a case. *)
-and extract_case env mle ((kn,i) as ip,c,br) mlt =
+and extract_case env sg mle ((kn,i) as ip,c,br) mlt =
(* [br]: bodies of each branch (in functional form) *)
(* [ni]: number of arguments without parameters in each branch *)
let ni = constructors_nrealargs_env env ip in
@@ -799,9 +854,9 @@ and extract_case env mle ((kn,i) as ip,c,br) mlt =
MLexn "absurd case"
end else
(* [c] has an inductive type, and is not a type scheme type. *)
- let t = type_of env c in
+ let t = type_of env sg c in
(* The only non-informative case: [c] is of sort [Prop] *)
- if (sort_of env t) == InProp then
+ if (sort_of env sg t) == InProp then
begin
add_recursors env kn; (* May have passed unseen if logical ... *)
(* Logical singleton case: *)
@@ -809,7 +864,7 @@ and extract_case env mle ((kn,i) as ip,c,br) mlt =
assert (Int.equal br_size 1);
let s = iterate (fun l -> Kill Kprop :: l) ni.(0) [] in
let mlt = iterate (fun t -> Tarr (Tdummy Kprop, t)) ni.(0) mlt in
- let e = extract_maybe_term env mle mlt br.(0) in
+ let e = extract_maybe_term env sg mle mlt br.(0) in
snd (case_expunge s e)
end
else
@@ -818,7 +873,7 @@ and extract_case env mle ((kn,i) as ip,c,br) mlt =
let metas = Array.init (List.length oi.ip_vars) new_meta in
(* The extraction of the head. *)
let type_head = Tglob (IndRef ip, Array.to_list metas) in
- let a = extract_term env mle type_head c [] in
+ let a = extract_term env sg mle type_head c [] in
(* The extraction of each branch. *)
let extract_branch i =
let r = ConstructRef (ip,i+1) in
@@ -829,7 +884,7 @@ and extract_case env mle ((kn,i) as ip,c,br) mlt =
let s = List.map (type2sign env) oi.ip_types.(i) in
let s = sign_with_implicits r s mi.ind_nparams in
(* Extraction of the branch (in functional form). *)
- let e = extract_maybe_term env mle (type_recomp (l,mlt)) br.(i) in
+ let e = extract_maybe_term env sg mle (type_recomp (l,mlt)) br.(i) in
(* We suppress dummy arguments according to signature. *)
let ids,e = case_expunge s e in
(List.rev ids, Pusual r, e)
@@ -851,12 +906,12 @@ and extract_case env mle ((kn,i) as ip,c,br) mlt =
(*s Extraction of a (co)-fixpoint. *)
-and extract_fix env mle i (fi,ti,ci as recd) mlt =
+and extract_fix env sg mle i (fi,ti,ci as recd) mlt =
let env = push_rec_types recd env in
let metas = Array.map new_meta fi in
metas.(i) <- mlt;
let mle = Array.fold_left Mlenv.push_type mle metas in
- let ei = Array.map2 (extract_maybe_term env mle) metas ci in
+ let ei = Array.map2 (extract_maybe_term env sg mle) metas ci in
MLfix (i, Array.map id_of_name fi, ei)
(*S ML declarations. *)
@@ -864,34 +919,34 @@ and extract_fix env mle i (fi,ti,ci as recd) mlt =
(* [decomp_lams_eta env c t] finds the number [n] of products in the type [t],
and decompose the term [c] in [n] lambdas, with eta-expansion if needed. *)
-let decomp_lams_eta_n n m env c t =
- let rels = fst (splay_prod_n env none n (EConstr.of_constr t)) in
- let rels = List.map (fun (LocalAssum (id,c) | LocalDef (id,_,c)) -> (id,EConstr.Unsafe.to_constr c)) rels in
- let rels',c = decompose_lam c in
+let decomp_lams_eta_n n m env sg c t =
+ let rels = fst (splay_prod_n env sg n t) in
+ let rels = List.map (fun (LocalAssum (id,c) | LocalDef (id,_,c)) -> (id,c)) rels in
+ let rels',c = EConstr.decompose_lam sg c in
let d = n - m in
(* we'd better keep rels' as long as possible. *)
let rels = (List.firstn d rels) @ rels' in
- let eta_args = List.rev_map mkRel (List.interval 1 d) in
- rels, applistc (lift d c) eta_args
+ let eta_args = List.rev_map EConstr.mkRel (List.interval 1 d) in
+ rels, applistc (EConstr.Vars.lift d c) eta_args
(* Let's try to identify some situation where extracted code
will allow generalisation of type variables *)
-let rec gentypvar_ok c = match Constr.kind c with
+let rec gentypvar_ok sg c = match EConstr.kind sg c with
| Lambda _ | Const _ -> true
| App (c,v) ->
(* if all arguments are variables, these variables will
disappear after extraction (see [empty_s] below) *)
- Array.for_all isRel v && gentypvar_ok c
- | Cast (c,_,_) -> gentypvar_ok c
+ Array.for_all (EConstr.isRel sg) v && gentypvar_ok sg c
+ | Cast (c,_,_) -> gentypvar_ok sg c
| _ -> false
(*s From a constant to a ML declaration. *)
-let extract_std_constant env kn body typ =
+let extract_std_constant env sg kn body typ =
reset_meta_count ();
(* The short type [t] (i.e. possibly with abbreviations). *)
- let t = snd (record_constant_type env kn (Some typ)) in
+ let t = snd (record_constant_type env sg kn (Some typ)) in
(* The real type [t']: without head products, expanded, *)
(* and with [Tvar] translated to [Tvar'] (not instantiable). *)
let l,t' = type_decomp (expand env (var2var' t)) in
@@ -906,14 +961,14 @@ let extract_std_constant env kn body typ =
break user's clever let-ins and partial applications). *)
let rels, c =
let n = List.length s
- and m = nb_lam Evd.empty (EConstr.of_constr body) (** FIXME *) in
- if n <= m then decompose_lam_n n body
+ and m = nb_lam sg body in
+ if n <= m then decompose_lam_n sg n body
else
let s,s' = List.chop m s in
if List.for_all ((==) Keep) s' &&
(lang () == Haskell || sign_kind s != UnsafeLogicalSig)
- then decompose_lam_n m body
- else decomp_lams_eta_n n m env body typ
+ then decompose_lam_n sg m body
+ else decomp_lams_eta_n n m env sg body typ
in
(* Should we do one eta-expansion to avoid non-generalizable '_a ? *)
let rels, c =
@@ -921,9 +976,9 @@ let extract_std_constant env kn body typ =
let s,s' = List.chop n s in
let k = sign_kind s in
let empty_s = (k == EmptySig || k == SafeLogicalSig) in
- if lang () == Ocaml && empty_s && not (gentypvar_ok c)
+ if lang () == Ocaml && empty_s && not (gentypvar_ok sg c)
&& not (List.is_empty s') && not (Int.equal (type_maxvar t) 0)
- then decomp_lams_eta_n (n+1) n env body typ
+ then decomp_lams_eta_n (n+1) n env sg body typ
else rels,c
in
let n = List.length rels in
@@ -937,16 +992,16 @@ let extract_std_constant env kn body typ =
(* The according Coq environment. *)
let env = push_rels_assum rels env in
(* The real extraction: *)
- let e = extract_term env mle t' c [] in
+ let e = extract_term env sg mle t' c [] in
(* Expunging term and type from dummy lambdas. *)
let trm = term_expunge s (ids,e) in
trm, type_expunge_from_sign env s t
(* Extracts the type of an axiom, honors the Extraction Implicit declaration. *)
-let extract_axiom env kn typ =
+let extract_axiom env sg kn typ =
reset_meta_count ();
(* The short type [t] (i.e. possibly with abbreviations). *)
- let t = snd (record_constant_type env kn (Some typ)) in
+ let t = snd (record_constant_type env sg kn (Some typ)) in
(* The real type [t']: without head products, expanded, *)
(* and with [Tvar] translated to [Tvar'] (not instantiable). *)
let l,_ = type_decomp (expand env (var2var' t)) in
@@ -955,18 +1010,19 @@ let extract_axiom env kn typ =
let s = sign_with_implicits (ConstRef kn) s 0 in
type_expunge_from_sign env s t
-let extract_fixpoint env vkn (fi,ti,ci) =
+let extract_fixpoint env sg vkn (fi,ti,ci) =
let n = Array.length vkn in
let types = Array.make n (Tdummy Kprop)
and terms = Array.make n (MLdummy Kprop) in
let kns = Array.to_list vkn in
current_fixpoints := kns;
(* for replacing recursive calls [Rel ..] by the corresponding [Const]: *)
- let sub = List.rev_map mkConst kns in
+ let sub = List.rev_map EConstr.mkConst kns in
for i = 0 to n-1 do
- if sort_of env ti.(i) != InProp then
+ if sort_of env sg ti.(i) != InProp then
try
- let e,t = extract_std_constant env vkn.(i) (substl sub ci.(i)) ti.(i) in
+ let e,t = extract_std_constant env sg vkn.(i)
+ (EConstr.Vars.substl sub ci.(i)) ti.(i) in
terms.(i) <- e;
types.(i) <- t;
with SingletonInductiveBecomesProp id ->
@@ -976,32 +1032,33 @@ let extract_fixpoint env vkn (fi,ti,ci) =
Dfix (Array.map (fun kn -> ConstRef kn) vkn, terms, types)
let extract_constant env kn cb =
+ let sg = Evd.from_env env in
let r = ConstRef kn in
- let typ = cb.const_type in
+ let typ = EConstr.of_constr cb.const_type in
let warn_info () = if not (is_custom r) then add_info_axiom r in
let warn_log () = if not (constant_has_body cb) then add_log_axiom r
in
let mk_typ_ax () =
- let n = type_scheme_nb_args env typ in
+ let n = type_scheme_nb_args env sg typ in
let ids = iterate (fun l -> anonymous_name::l) n [] in
Dtype (r, ids, Taxiom)
in
let mk_typ c =
- let s,vl = type_sign_vl env typ in
+ let s,vl = type_sign_vl env sg typ in
let db = db_from_sign s in
- let t = extract_type_scheme env db c (List.length s)
+ let t = extract_type_scheme env sg db c (List.length s)
in Dtype (r, vl, t)
in
let mk_ax () =
- let t = extract_axiom env kn typ in
+ let t = extract_axiom env sg kn typ in
Dterm (r, MLaxiom, t)
in
let mk_def c =
- let e,t = extract_std_constant env kn c typ in
+ let e,t = extract_std_constant env sg kn c typ in
Dterm (r,e,t)
in
try
- match flag_of_type env typ with
+ match flag_of_type env sg typ with
| (Logic,TypeScheme) -> warn_log (); Dtype (r, [], Tdummy Ktype)
| (Logic,Default) -> warn_log (); Dterm (r, MLdummy Kprop, Tdummy Kprop)
| (Info,TypeScheme) ->
@@ -1009,73 +1066,72 @@ let extract_constant env kn cb =
| Undef _ -> warn_info (); mk_typ_ax ()
| Def c ->
(match cb.const_proj with
- | None -> mk_typ (Mod_subst.force_constr c)
- | Some pb -> mk_typ pb.proj_body)
+ | None -> mk_typ (get_body c)
+ | Some pb -> mk_typ (EConstr.of_constr pb.proj_body))
| OpaqueDef c ->
add_opaque r;
- if access_opaque () then
- mk_typ (Opaqueproof.force_proof (Environ.opaque_tables env) c)
+ if access_opaque () then mk_typ (get_opaque env c)
else mk_typ_ax ())
| (Info,Default) ->
(match cb.const_body with
| Undef _ -> warn_info (); mk_ax ()
| Def c ->
(match cb.const_proj with
- | None -> mk_def (Mod_subst.force_constr c)
- | Some pb -> mk_def pb.proj_body)
+ | None -> mk_def (get_body c)
+ | Some pb -> mk_def (EConstr.of_constr pb.proj_body))
| OpaqueDef c ->
add_opaque r;
- if access_opaque () then
- mk_def (Opaqueproof.force_proof (Environ.opaque_tables env) c)
+ if access_opaque () then mk_def (get_opaque env c)
else mk_ax ())
with SingletonInductiveBecomesProp id ->
error_singleton_become_prop id (Some (ConstRef kn))
let extract_constant_spec env kn cb =
+ let sg = Evd.from_env env in
let r = ConstRef kn in
- let typ = cb.const_type in
+ let typ = EConstr.of_constr cb.const_type in
try
- match flag_of_type env typ with
+ match flag_of_type env sg typ with
| (Logic, TypeScheme) -> Stype (r, [], Some (Tdummy Ktype))
| (Logic, Default) -> Sval (r, Tdummy Kprop)
| (Info, TypeScheme) ->
- let s,vl = type_sign_vl env typ in
+ let s,vl = type_sign_vl env sg typ in
(match cb.const_body with
| Undef _ | OpaqueDef _ -> Stype (r, vl, None)
| Def body ->
let db = db_from_sign s in
- let body = Mod_subst.force_constr body in
- let t = extract_type_scheme env db body (List.length s)
- in Stype (r, vl, Some t))
+ let body = get_body body in
+ let t = extract_type_scheme env sg db body (List.length s)
+ in Stype (r, vl, Some t))
| (Info, Default) ->
- let t = snd (record_constant_type env kn (Some typ)) in
- Sval (r, type_expunge env t)
+ let t = snd (record_constant_type env sg kn (Some typ)) in
+ Sval (r, type_expunge env t)
with SingletonInductiveBecomesProp id ->
error_singleton_become_prop id (Some (ConstRef kn))
-let extract_with_type env c =
+let extract_with_type env sg c =
try
- let typ = type_of env c in
- match flag_of_type env typ with
+ let typ = type_of env sg c in
+ match flag_of_type env sg typ with
| (Info, TypeScheme) ->
- let s,vl = type_sign_vl env typ in
- let db = db_from_sign s in
- let t = extract_type_scheme env db c (List.length s) in
- Some (vl, t)
+ let s,vl = type_sign_vl env sg typ in
+ let db = db_from_sign s in
+ let t = extract_type_scheme env sg db c (List.length s) in
+ Some (vl, t)
| _ -> None
with SingletonInductiveBecomesProp id ->
error_singleton_become_prop id None
-let extract_constr env c =
+let extract_constr env sg c =
reset_meta_count ();
try
- let typ = type_of env c in
- match flag_of_type env typ with
+ let typ = type_of env sg c in
+ match flag_of_type env sg typ with
| (_,TypeScheme) -> MLdummy Ktype, Tdummy Ktype
| (Logic,_) -> MLdummy Kprop, Tdummy Kprop
| (Info,Default) ->
- let mlt = extract_type env [] 1 typ [] in
- extract_term env Mlenv.empty mlt c [], mlt
+ let mlt = extract_type env sg [] 1 typ [] in
+ extract_term env sg Mlenv.empty mlt c [], mlt
with SingletonInductiveBecomesProp id ->
error_singleton_become_prop id None
diff --git a/plugins/extraction/extraction.mli b/plugins/extraction/extraction.mli
index a0f2885a4..d27c79cb6 100644
--- a/plugins/extraction/extraction.mli
+++ b/plugins/extraction/extraction.mli
@@ -11,9 +11,9 @@
(*s Extraction from Coq terms to Miniml. *)
open Names
-open Constr
open Declarations
open Environ
+open Evd
open Miniml
val extract_constant : env -> Constant.t -> constant_body -> ml_decl
@@ -22,16 +22,18 @@ val extract_constant_spec : env -> Constant.t -> constant_body -> ml_spec
(** For extracting "module ... with ..." declaration *)
-val extract_with_type : env -> constr -> ( Id.t list * ml_type ) option
+val extract_with_type :
+ env -> evar_map -> EConstr.t -> ( Id.t list * ml_type ) option
val extract_fixpoint :
- env -> Constant.t array -> (constr, types) prec_declaration -> ml_decl
+ env -> evar_map -> Constant.t array ->
+ (EConstr.t, EConstr.types) Constr.prec_declaration -> ml_decl
val extract_inductive : env -> MutInd.t -> ml_ind
-(** For extraction compute *)
+(** For Extraction Compute and Show Extraction *)
-val extract_constr : env -> constr -> ml_ast * ml_type
+val extract_constr : env -> evar_map -> EConstr.t -> ml_ast * ml_type
(*s Is a [ml_decl] or a [ml_spec] logical ? *)
diff --git a/plugins/extraction/g_extraction.ml4 b/plugins/extraction/g_extraction.ml4
index 468f2fe8c..93909f3e6 100644
--- a/plugins/extraction/g_extraction.ml4
+++ b/plugins/extraction/g_extraction.ml4
@@ -160,3 +160,9 @@ VERNAC COMMAND EXTEND ExtractionInductive CLASSIFIED AS SIDEFF
mlname(id) "[" mlname_list(idl) "]" string_opt(o) ]
-> [ extract_inductive x id idl o ]
END
+(* Show the extraction of the current proof *)
+
+VERNAC COMMAND EXTEND ShowExtraction CLASSIFIED AS QUERY
+| [ "Show" "Extraction" ]
+ -> [ show_extraction () ]
+END
diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml
index 0bcda69d4..6c421491f 100644
--- a/plugins/extraction/table.ml
+++ b/plugins/extraction/table.ml
@@ -38,14 +38,13 @@ module Refset' = Refset_env
let occur_kn_in_ref kn = function
| IndRef (kn',_)
| ConstructRef ((kn',_),_) -> MutInd.equal kn kn'
- | ConstRef _ -> false
- | VarRef _ -> assert false
+ | ConstRef _ | VarRef _ -> false
let repr_of_r = function
| ConstRef kn -> Constant.repr3 kn
| IndRef (kn,_)
| ConstructRef ((kn,_),_) -> MutInd.repr3 kn
- | VarRef _ -> assert false
+ | VarRef v -> KerName.repr (Lib.make_kn v)
let modpath_of_r r =
let mp,_,_ = repr_of_r r in mp
@@ -279,7 +278,7 @@ let safe_basename_of_global r =
| ConstructRef ((kn,i),j) ->
(try (unsafe_lookup_ind kn).ind_packets.(i).ip_consnames.(j-1)
with Not_found -> last_chance r)
- | VarRef _ -> assert false
+ | VarRef v -> v
let string_of_global r =
try string_of_qualid (Nametab.shortest_qualid_of_global Id.Set.empty r)
diff --git a/plugins/ltac/g_eqdecide.ml4 b/plugins/ltac/g_eqdecide.ml4
index b3bcc9984..2251a6620 100644
--- a/plugins/ltac/g_eqdecide.ml4
+++ b/plugins/ltac/g_eqdecide.ml4
@@ -15,6 +15,7 @@
(************************************************************************)
open Eqdecide
+open Stdarg
DECLARE PLUGIN "ltac_plugin"
diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml
index 6e38b4641..e0368153e 100644
--- a/plugins/ltac/rewrite.ml
+++ b/plugins/ltac/rewrite.ml
@@ -1922,7 +1922,7 @@ let build_morphism_signature env sigma m =
in
let morph = e_app_poly env evd PropGlobal.proper_type [| t; sig_; m |] in
let evd = solve_constraints env !evd in
- let evd = Evd.nf_constraints evd in
+ let evd = Evd.minimize_universes evd in
let m = Evarutil.nf_evars_universes evd (EConstr.Unsafe.to_constr morph) in
Pretyping.check_evars env Evd.empty evd (EConstr.of_constr m);
Evd.evar_universe_context evd, m
diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml
index 4665ff9ed..2c7ebb745 100644
--- a/plugins/ltac/taccoerce.ml
+++ b/plugins/ltac/taccoerce.ml
@@ -16,6 +16,7 @@ open Misctypes
open Genarg
open Stdarg
open Geninterp
+open Pp
exception CannotCoerceTo of string
@@ -94,6 +95,38 @@ let to_option v = prj Val.typ_opt v
let to_pair v = prj Val.typ_pair v
+let cast_error wit v =
+ let pr_v = Pptactic.pr_value Pptactic.ltop v in
+ let Val.Dyn (tag, _) = v in
+ let tag = Val.pr tag in
+ CErrors.user_err (str "Type error: value " ++ pr_v ++ str " is a " ++ tag
+ ++ str " while type " ++ Val.pr wit ++ str " was expected.")
+
+let unbox wit v ans = match ans with
+| None -> cast_error wit v
+| Some x -> x
+
+let rec prj : type a. a Val.tag -> Val.t -> a = fun tag v -> match tag with
+| Val.List tag -> List.map (fun v -> prj tag v) (unbox Val.typ_list v (to_list v))
+| Val.Opt tag -> Option.map (fun v -> prj tag v) (unbox Val.typ_opt v (to_option v))
+| Val.Pair (tag1, tag2) ->
+ let (x, y) = unbox Val.typ_pair v (to_pair v) in
+ (prj tag1 x, prj tag2 y)
+| Val.Base t ->
+ let Val.Dyn (t', x) = v in
+ match Val.eq t t' with
+ | None -> cast_error t v
+ | Some Refl -> x
+let rec tag_of_arg : type a b c. (a, b, c) genarg_type -> c Val.tag = fun wit -> match wit with
+| ExtraArg _ -> Geninterp.val_tag (topwit wit)
+| ListArg t -> Val.List (tag_of_arg t)
+| OptArg t -> Val.Opt (tag_of_arg t)
+| PairArg (t1, t2) -> Val.Pair (tag_of_arg t1, tag_of_arg t2)
+
+let val_cast arg v = prj (tag_of_arg arg) v
+
+let cast (Topwit wit) v = val_cast wit v
+
end
let is_variable env id =
@@ -334,3 +367,46 @@ let coerce_to_int_or_var_list v =
| Some l ->
let map n = ArgArg (coerce_to_int n) in
List.map map l
+
+(** Abstract application, to print ltac functions *)
+type appl =
+ | UnnamedAppl (** For generic applications: nothing is printed *)
+ | GlbAppl of (Names.KerName.t * Val.t list) list
+ (** For calls to global constants, some may alias other. *)
+
+(* Values for interpretation *)
+type tacvalue =
+ | VFun of appl*Tacexpr.ltac_trace * Val.t Id.Map.t *
+ Name.t list * Tacexpr.glob_tactic_expr
+ | VRec of Val.t Id.Map.t ref * Tacexpr.glob_tactic_expr
+
+let (wit_tacvalue : (Empty.t, tacvalue, tacvalue) Genarg.genarg_type) =
+ let wit = Genarg.create_arg "tacvalue" in
+ let () = register_val0 wit None in
+ let () = Genprint.register_val_print0 (base_val_typ wit)
+ (fun _ -> Genprint.TopPrinterBasic (fun () -> str "<tactic closure>")) in
+ wit
+
+let pr_argument_type arg =
+ let Val.Dyn (tag, _) = arg in
+ Val.pr tag
+
+(** TODO: unify printing of generic Ltac values in case of coercion failure. *)
+
+(* Displays a value *)
+let pr_value env v =
+ let pr_with_env pr =
+ match env with
+ | Some (env,sigma) -> pr env sigma
+ | None -> str "a value of type" ++ spc () ++ pr_argument_type v in
+ let open Genprint in
+ match generic_val_print v with
+ | TopPrinterBasic pr -> pr ()
+ | TopPrinterNeedsContext pr -> pr_with_env pr
+ | TopPrinterNeedsContextAndLevel { default_already_surrounded; printer } ->
+ pr_with_env (fun env sigma -> printer env sigma default_already_surrounded)
+
+let error_ltac_variable ?loc id env v s =
+ CErrors.user_err ?loc (str "Ltac variable " ++ Id.print id ++
+ strbrk " is bound to" ++ spc () ++ pr_value env v ++ spc () ++
+ strbrk "which cannot be coerced to " ++ str s ++ str".")
diff --git a/plugins/ltac/taccoerce.mli b/plugins/ltac/taccoerce.mli
index ce05d70e8..1fa5e3c07 100644
--- a/plugins/ltac/taccoerce.mli
+++ b/plugins/ltac/taccoerce.mli
@@ -42,6 +42,7 @@ sig
val to_list : t -> t list option
val to_option : t -> t option option
val to_pair : t -> (t * t) option
+ val cast : 'a typed_abstract_argument_type -> Geninterp.Val.t -> 'a
end
(** {5 Coercion functions} *)
@@ -92,3 +93,21 @@ val coerce_to_int_or_var_list : Value.t -> int or_var list
val wit_constr_context : (Empty.t, Empty.t, EConstr.constr) genarg_type
val wit_constr_under_binders : (Empty.t, Empty.t, Ltac_pretype.constr_under_binders) genarg_type
+
+val error_ltac_variable : ?loc:Loc.t -> Id.t ->
+ (Environ.env * Evd.evar_map) option -> Value.t -> string -> 'a
+
+(** Abstract application, to print ltac functions *)
+type appl =
+ | UnnamedAppl (** For generic applications: nothing is printed *)
+ | GlbAppl of (Names.KerName.t * Val.t list) list
+ (** For calls to global constants, some may alias other. *)
+
+type tacvalue =
+ | VFun of appl*Tacexpr.ltac_trace * Val.t Id.Map.t *
+ Name.t list * Tacexpr.glob_tactic_expr
+ | VRec of Val.t Id.Map.t ref * Tacexpr.glob_tactic_expr
+
+val wit_tacvalue : (Empty.t, tacvalue, tacvalue) Genarg.genarg_type
+
+val pr_value : (Environ.env * Evd.evar_map) option -> Geninterp.Val.t -> Pp.t
diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml
index 42f2abd73..566fc2873 100644
--- a/plugins/ltac/tacentries.ml
+++ b/plugins/ltac/tacentries.ml
@@ -554,3 +554,138 @@ let () =
AnyEntry Pltac.tactic_arg;
] in
register_grammars_by_name "tactic" entries
+
+type _ ty_sig =
+| TyNil : (Geninterp.interp_sign -> unit Proofview.tactic) ty_sig
+| TyIdent : string * 'r ty_sig -> 'r ty_sig
+| TyArg :
+ (('a, 'b, 'c) Extend.ty_user_symbol * Id.t) Loc.located * 'r ty_sig -> ('c -> 'r) ty_sig
+| TyAnonArg :
+ ('a, 'b, 'c) Extend.ty_user_symbol Loc.located * 'r ty_sig -> 'r ty_sig
+
+type ty_ml = TyML : 'r ty_sig * 'r -> ty_ml
+
+let rec untype_user_symbol : type a b c. (a,b,c) ty_user_symbol -> Genarg.ArgT.any user_symbol = fun tu ->
+ match tu with
+ | TUlist1 l -> Ulist1(untype_user_symbol l)
+ | TUlist1sep(l,s) -> Ulist1sep(untype_user_symbol l, s)
+ | TUlist0 l -> Ulist0(untype_user_symbol l)
+ | TUlist0sep(l,s) -> Ulist0sep(untype_user_symbol l, s)
+ | TUopt(o) -> Uopt(untype_user_symbol o)
+ | TUentry a -> Uentry (Genarg.ArgT.Any a)
+ | TUentryl (a,i) -> Uentryl (Genarg.ArgT.Any a,i)
+
+let rec clause_of_sign : type a. a ty_sig -> Genarg.ArgT.any Extend.user_symbol grammar_tactic_prod_item_expr list =
+ fun sign -> match sign with
+ | TyNil -> []
+ | TyIdent (s, sig') -> TacTerm s :: clause_of_sign sig'
+ | TyArg ((loc,(a,id)),sig') ->
+ TacNonTerm (loc,(untype_user_symbol a,Some id)) :: clause_of_sign sig'
+ | TyAnonArg ((loc,a),sig') ->
+ TacNonTerm (loc,(untype_user_symbol a,None)) :: clause_of_sign sig'
+
+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
+ | TyNil ->
+ begin fun vals ist -> match vals with
+ | [] -> tac ist
+ | _ :: _ -> assert false
+ end
+ | TyIdent (s, sig') -> eval_sign sig' tac
+ | TyArg ((_loc,(a,id)), sig') ->
+ let f = eval_sign sig' in
+ begin fun tac vals ist -> match vals with
+ | [] -> assert false
+ | v :: vals ->
+ let v' = Taccoerce.Value.cast (topwit (prj a)) v in
+ f (tac v') vals ist
+ end tac
+ | TyAnonArg ((_loc,a), sig') -> eval_sign sig' tac
+
+let eval : ty_ml -> Geninterp.Val.t list -> Geninterp.interp_sign -> unit Proofview.tactic = function
+ | TyML (t,tac) -> eval_sign t tac
+
+let is_constr_entry = function
+| TUentry a -> Option.has_some @@ genarg_type_eq (ExtraArg a) Stdarg.wit_constr
+| _ -> false
+
+let rec only_constr : type a. a ty_sig -> bool = function
+| TyNil -> true
+| TyIdent(_,_) -> false
+| TyArg((_,(u,_)),s) -> if is_constr_entry u then only_constr s else false
+| TyAnonArg((_,u),s) -> if is_constr_entry u then only_constr s else false
+
+let rec mk_sign_vars : type a. a ty_sig -> Name.t list = function
+| TyNil -> []
+| TyIdent (_,s) -> mk_sign_vars s
+| TyArg((_,(_,name)),s) -> Name name :: mk_sign_vars s
+| TyAnonArg((_,_),s) -> Anonymous :: mk_sign_vars s
+
+let dummy_id = Id.of_string "_"
+
+let lift_constr_tac_to_ml_tac vars tac =
+ let tac _ ist = Proofview.Goal.enter begin fun gl ->
+ let env = Proofview.Goal.env gl in
+ let sigma = Tacmach.New.project gl in
+ let map = function
+ | Anonymous -> None
+ | Name id ->
+ let c = Id.Map.find id ist.Geninterp.lfun in
+ try Some (Taccoerce.Value.of_constr @@ Taccoerce.coerce_to_closed_constr env c)
+ with Taccoerce.CannotCoerceTo ty ->
+ Taccoerce.error_ltac_variable dummy_id (Some (env,sigma)) c ty
+ in
+ let args = List.map_filter map vars in
+ tac args ist
+ end in
+ tac
+
+let tactic_extend plugin_name tacname ~level sign =
+ let open Tacexpr in
+ let ml_tactic_name =
+ { mltac_tactic = tacname;
+ mltac_plugin = plugin_name }
+ in
+ match sign with
+ | [TyML (TyIdent (name, s),tac) as ml_tac] when only_constr s ->
+ (** The extension is only made of a name followed by constr entries: we do not
+ add any grammar nor printing rule and add it as a true Ltac definition. *)
+ (*
+ let patt = make_patt rem in
+ let vars = List.map make_var rem in
+ let vars = mlexpr_of_list (mlexpr_of_name mlexpr_of_ident) vars in
+ *)
+ let vars = mk_sign_vars s in
+ let ml = { Tacexpr.mltac_name = ml_tactic_name; Tacexpr.mltac_index = 0 } in
+ let tac = match s with
+ | TyNil -> eval ml_tac
+ (** Special handling of tactics without arguments: such tactics do not do
+ a Proofview.Goal.nf_enter to compute their arguments. It matters for some
+ whole-prof tactics like [shelve_unifiable]. *)
+ | _ -> lift_constr_tac_to_ml_tac vars (eval ml_tac)
+ in
+ (** Arguments are not passed directly to the ML tactic in the TacML node,
+ the ML tactic retrieves its arguments in the [ist] environment instead.
+ This is the rôle of the [lift_constr_tac_to_ml_tac] function. *)
+ let body = Tacexpr.TacFun (vars, Tacexpr.TacML (Loc.tag (ml, [])))in
+ let id = Names.Id.of_string name in
+ let obj () = Tacenv.register_ltac true false id body in
+ let () = Tacenv.register_ml_tactic ml_tactic_name [|tac|] in
+ Mltop.declare_cache_obj obj plugin_name
+ | _ ->
+ let obj () = add_ml_tactic_notation ml_tactic_name ~level (List.map clause_of_ty_ml sign) in
+ Tacenv.register_ml_tactic ml_tactic_name @@ Array.of_list (List.map eval sign);
+ Mltop.declare_cache_obj obj plugin_name
diff --git a/plugins/ltac/tacentries.mli b/plugins/ltac/tacentries.mli
index 02e2f0f60..3f804ee8d 100644
--- a/plugins/ltac/tacentries.mli
+++ b/plugins/ltac/tacentries.mli
@@ -67,3 +67,15 @@ val print_ltacs : unit -> unit
val print_located_tactic : Libnames.reference -> unit
(** Display the absolute name of a tactic. *)
+
+type _ ty_sig =
+| TyNil : (Geninterp.interp_sign -> unit Proofview.tactic) ty_sig
+| TyIdent : string * 'r ty_sig -> 'r ty_sig
+| TyArg :
+ (('a, 'b, 'c) Extend.ty_user_symbol * Names.Id.t) Loc.located * 'r ty_sig -> ('c -> 'r) ty_sig
+| TyAnonArg :
+ ('a, 'b, 'c) Extend.ty_user_symbol Loc.located * 'r ty_sig -> 'r ty_sig
+
+type ty_ml = TyML : 'r ty_sig * 'r -> ty_ml
+
+val tactic_extend : string -> string -> level:Int.t -> ty_ml list -> unit
diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml
index cd9d9bac2..991afe9c6 100644
--- a/plugins/ltac/tacinterp.ml
+++ b/plugins/ltac/tacinterp.ml
@@ -79,9 +79,6 @@ let out_gen wit v =
let val_tag wit = val_tag (topwit wit)
-let base_val_typ wit =
- match val_tag wit with Val.Base t -> t | _ -> anomaly (str "Not a base val.")
-
let pr_argument_type arg =
let Val.Dyn (tag, _) = arg in
Val.pr tag
@@ -93,11 +90,6 @@ let safe_msgnl s =
type value = Val.t
-(** Abstract application, to print ltac functions *)
-type appl =
- | UnnamedAppl (** For generic applications: nothing is printed *)
- | GlbAppl of (Names.KerName.t * Val.t list) list
- (** For calls to global constants, some may alias other. *)
let push_appl appl args =
match appl with
| UnnamedAppl -> UnnamedAppl
@@ -121,19 +113,6 @@ let combine_appl appl1 appl2 =
| UnnamedAppl,a | a,UnnamedAppl -> a
| GlbAppl l1 , GlbAppl l2 -> GlbAppl (l2@l1)
-(* Values for interpretation *)
-type tacvalue =
- | VFun of appl*ltac_trace * value Id.Map.t *
- Name.t list * glob_tactic_expr
- | VRec of value Id.Map.t ref * glob_tactic_expr
-
-let (wit_tacvalue : (Empty.t, tacvalue, tacvalue) Genarg.genarg_type) =
- let wit = Genarg.create_arg "tacvalue" in
- let () = register_val0 wit None in
- let () = Genprint.register_val_print0 (base_val_typ wit)
- (fun _ -> Genprint.TopPrinterBasic (fun () -> str "<tactic closure>")) in
- wit
-
let of_tacvalue v = in_gen (topwit wit_tacvalue) v
let to_tacvalue v = out_gen (topwit wit_tacvalue) v
@@ -169,39 +148,6 @@ module Value = struct
let closure = VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], tac) in
of_tacvalue closure
- let cast_error wit v =
- let pr_v = Pptactic.pr_value Pptactic.ltop v in
- let Val.Dyn (tag, _) = v in
- let tag = Val.pr tag in
- user_err (str "Type error: value " ++ pr_v ++ str " is a " ++ tag
- ++ str " while type " ++ Val.pr wit ++ str " was expected.")
-
- let unbox wit v ans = match ans with
- | None -> cast_error wit v
- | Some x -> x
-
- let rec prj : type a. a Val.tag -> Val.t -> a = fun tag v -> match tag with
- | Val.List tag -> List.map (fun v -> prj tag v) (unbox Val.typ_list v (to_list v))
- | Val.Opt tag -> Option.map (fun v -> prj tag v) (unbox Val.typ_opt v (to_option v))
- | Val.Pair (tag1, tag2) ->
- let (x, y) = unbox Val.typ_pair v (to_pair v) in
- (prj tag1 x, prj tag2 y)
- | Val.Base t ->
- let Val.Dyn (t', x) = v in
- match Val.eq t t' with
- | None -> cast_error t v
- | Some Refl -> x
-
- let rec tag_of_arg : type a b c. (a, b, c) genarg_type -> c Val.tag = fun wit -> match wit with
- | ExtraArg _ -> val_tag wit
- | ListArg t -> Val.List (tag_of_arg t)
- | OptArg t -> Val.Opt (tag_of_arg t)
- | PairArg (t1, t2) -> Val.Pair (tag_of_arg t1, tag_of_arg t2)
-
- let val_cast arg v = prj (tag_of_arg arg) v
-
- let cast (Topwit wit) v = val_cast wit v
-
end
let print_top_val env v = Pptactic.pr_value Pptactic.ltop v
@@ -233,21 +179,6 @@ let curr_debug ist = match TacStore.get ist.extra f_debug with
| None -> DebugOff
| Some level -> level
-(** TODO: unify printing of generic Ltac values in case of coercion failure. *)
-
-(* Displays a value *)
-let pr_value env v =
- let pr_with_env pr =
- match env with
- | Some (env,sigma) -> pr env sigma
- | None -> str "a value of type" ++ spc () ++ pr_argument_type v in
- let open Genprint in
- match generic_val_print v with
- | TopPrinterBasic pr -> pr ()
- | TopPrinterNeedsContext pr -> pr_with_env pr
- | TopPrinterNeedsContextAndLevel { default_already_surrounded; printer } ->
- pr_with_env (fun env sigma -> printer env sigma default_already_surrounded)
-
let pr_closure env ist body =
let pp_body = Pptactic.pr_glob_tactic env body in
let pr_sep () = fnl () in
@@ -360,15 +291,11 @@ let debugging_exception_step ist signal_anomaly e pp =
debugging_step ist (fun () ->
pp() ++ spc() ++ str "raised the exception" ++ fnl() ++ explain_exc e)
-let error_ltac_variable ?loc id env v s =
- user_err ?loc (str "Ltac variable " ++ Id.print id ++
- strbrk " is bound to" ++ spc () ++ pr_value env v ++ spc () ++
- strbrk "which cannot be coerced to " ++ str s ++ str".")
-
(* Raise Not_found if not in interpretation sign *)
let try_interp_ltac_var coerce ist env {loc;v=id} =
let v = Id.Map.find id ist.lfun in
- try coerce v with CannotCoerceTo s -> error_ltac_variable ?loc id env v s
+ try coerce v with CannotCoerceTo s ->
+ Taccoerce.error_ltac_variable ?loc id env v s
let interp_ltac_var coerce ist env locid =
try try_interp_ltac_var coerce ist env locid
@@ -2090,27 +2017,6 @@ let _ =
in
Pretyping.register_constr_interp0 wit_tactic eval
-(** Used in tactic extension **)
-
-let dummy_id = Id.of_string "_"
-
-let lift_constr_tac_to_ml_tac vars tac =
- let tac _ ist = Proofview.Goal.enter begin fun gl ->
- let env = Proofview.Goal.env gl in
- let sigma = project gl in
- let map = function
- | Anonymous -> None
- | Name id ->
- let c = Id.Map.find id ist.lfun in
- try Some (coerce_to_closed_constr env c)
- with CannotCoerceTo ty ->
- error_ltac_variable dummy_id (Some (env,sigma)) c ty
- in
- let args = List.map_filter map vars in
- tac args ist
- end in
- tac
-
let vernac_debug b =
set_debug (if b then Tactic_debug.DebugOn 0 else Tactic_debug.DebugOff)
diff --git a/plugins/ltac/tacinterp.mli b/plugins/ltac/tacinterp.mli
index 3f3b8e555..bd44bdbea 100644
--- a/plugins/ltac/tacinterp.mli
+++ b/plugins/ltac/tacinterp.mli
@@ -133,13 +133,5 @@ val interp_int : interp_sign -> lident -> int
val interp_int_or_var : interp_sign -> int or_var -> int
-val error_ltac_variable : ?loc:Loc.t -> Id.t ->
- (Environ.env * Evd.evar_map) option -> value -> string -> 'a
-
-(** Transforms a constr-expecting tactic into a tactic finding its arguments in
- the Ltac environment according to the given names. *)
-val lift_constr_tac_to_ml_tac : Name.t list ->
- (constr list -> Geninterp.interp_sign -> unit Proofview.tactic) -> Tacenv.ml_tactic
-
val default_ist : unit -> Geninterp.interp_sign
(** Empty ist with debug set on the current value. *)
diff --git a/plugins/ltac/tauto.ml b/plugins/ltac/tauto.ml
index d0f31cd42..a51c09ca4 100644
--- a/plugins/ltac/tauto.ml
+++ b/plugins/ltac/tauto.ml
@@ -65,11 +65,6 @@ let assoc_flags ist : tauto_flags =
(* Whether inner not are unfolded *)
let negation_unfolding = ref true
-(* Whether inner iff are unfolded *)
-let iff_unfolding = ref false
-
-let unfold_iff () = !iff_unfolding
-
open Goptions
let _ =
declare_bool_option
@@ -79,14 +74,6 @@ let _ =
optread = (fun () -> !negation_unfolding);
optwrite = (:=) negation_unfolding }
-let _ =
- declare_bool_option
- { optdepr = true; (* remove in 8.8 *)
- optname = "unfolding of iff in intuition";
- optkey = ["Intuition";"Iff";"Unfolding"];
- optread = (fun () -> !iff_unfolding);
- optwrite = (:=) iff_unfolding }
-
(** Base tactics *)
let idtac = Proofview.tclUNIT ()
@@ -202,16 +189,13 @@ let make_unfold name =
let const = Constant.make2 (ModPath.MPfile dir) (Label.make name) in
(Locus.AllOccurrences, ArgArg (EvalConstRef const, None))
-let u_iff = make_unfold "iff"
let u_not = make_unfold "not"
let reduction_not_iff _ ist =
let make_reduce c = TacAtom (Loc.tag @@ TacReduce (Genredexpr.Unfold c, Locusops.allHypsAndConcl)) in
- let tac = match !negation_unfolding, unfold_iff () with
- | true, true -> make_reduce [u_not; u_iff]
- | true, false -> make_reduce [u_not]
- | false, true -> make_reduce [u_iff]
- | false, false -> TacId []
+ let tac = match !negation_unfolding with
+ | true -> make_reduce [u_not]
+ | false -> TacId []
in
eval_tactic_ist ist tac
diff --git a/plugins/micromega/RingMicromega.v b/plugins/micromega/RingMicromega.v
index 543a37ff8..f066ea462 100644
--- a/plugins/micromega/RingMicromega.v
+++ b/plugins/micromega/RingMicromega.v
@@ -21,6 +21,7 @@ Require Import List.
Require Import Bool.
Require Import OrderedRing.
Require Import Refl.
+Require Coq.micromega.Tauto.
Set Implicit Arguments.
@@ -796,7 +797,7 @@ Definition xnormalise (t:Formula C) : list (NFormula) :=
| OpLe => (psub lhs rhs ,Strict) :: nil
end.
-Require Import Coq.micromega.Tauto.
+Import Coq.micromega.Tauto.
Definition cnf_normalise (t:Formula C) : cnf (NFormula) :=
List.map (fun x => x::nil) (xnormalise t).
diff --git a/plugins/nsatz/Nsatz.v b/plugins/nsatz/Nsatz.v
index 85e2a5b23..c5a09d677 100644
--- a/plugins/nsatz/Nsatz.v
+++ b/plugins/nsatz/Nsatz.v
@@ -30,6 +30,7 @@ Require Export Ncring_initial.
Require Export Ncring_tac.
Require Export Integral_domain.
Require Import DiscrR.
+Require Import ZArith.
Declare ML Module "nsatz_plugin".
@@ -56,9 +57,8 @@ simpl. simpl; cring.
Qed.
(* adpatation du code de Benjamin aux setoides *)
-Require Import ZArith.
-Require Export Ring_polynom.
-Require Export InitialRing.
+Export Ring_polynom.
+Export InitialRing.
Definition PolZ := Pol Z.
Definition PEZ := PExpr Z.
diff --git a/plugins/nsatz/g_nsatz.ml4 b/plugins/nsatz/g_nsatz.ml4
index c8112eaa9..4ac49adb9 100644
--- a/plugins/nsatz/g_nsatz.ml4
+++ b/plugins/nsatz/g_nsatz.ml4
@@ -9,6 +9,7 @@
(************************************************************************)
open Ltac_plugin
+open Stdarg
DECLARE PLUGIN "nsatz_plugin"
diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml
index 0f5417e7d..ad3afafd8 100644
--- a/plugins/romega/const_omega.ml
+++ b/plugins/romega/const_omega.ml
@@ -7,15 +7,14 @@
*************************************************************************)
open Names
-open Constr
let module_refl_name = "ReflOmegaCore"
let module_refl_path = ["Coq"; "romega"; module_refl_name]
type result =
| Kvar of string
- | Kapp of string * constr list
- | Kimp of constr * constr
+ | Kapp of string * EConstr.t list
+ | Kimp of EConstr.t * EConstr.t
| Kufo
let meaningful_submodule = [ "Z"; "N"; "Pos" ]
@@ -30,9 +29,10 @@ let string_of_global r =
in
prefix^(Names.Id.to_string (Nametab.basename_of_global r))
-let destructurate t =
- let c, args = decompose_app t in
- match Constr.kind c, args with
+let destructurate sigma t =
+ let c, args = EConstr.decompose_app sigma t in
+ let open Constr in
+ match EConstr.kind sigma c, args with
| Const (sp,_), args ->
Kapp (string_of_global (Globnames.ConstRef sp), args)
| Construct (csp,_) , args ->
@@ -45,10 +45,11 @@ let destructurate t =
exception DestConstApp
-let dest_const_apply t =
- let f,args = decompose_app t in
+let dest_const_apply sigma t =
+ let open Constr in
+ let f,args = EConstr.decompose_app sigma t in
let ref =
- match Constr.kind f with
+ match EConstr.kind sigma f with
| Const (sp,_) -> Globnames.ConstRef sp
| Construct (csp,_) -> Globnames.ConstructRef csp
| Ind (isp,_) -> Globnames.IndRef isp
@@ -66,10 +67,22 @@ let coq_modules =
let bin_module = [["Coq";"Numbers";"BinNums"]]
let z_module = [["Coq";"ZArith";"BinInt"]]
-let init_constant x = Universes.constr_of_global @@ Coqlib.gen_reference_in_modules "Omega" Coqlib.init_modules x
-let constant x = Universes.constr_of_global @@ Coqlib.gen_reference_in_modules "Omega" coq_modules x
-let z_constant x = Universes.constr_of_global @@ Coqlib.gen_reference_in_modules "Omega" z_module x
-let bin_constant x = Universes.constr_of_global @@ Coqlib.gen_reference_in_modules "Omega" bin_module x
+let init_constant x =
+ EConstr.of_constr @@
+ Universes.constr_of_global @@
+ Coqlib.gen_reference_in_modules "Omega" Coqlib.init_modules x
+let constant x =
+ EConstr.of_constr @@
+ Universes.constr_of_global @@
+ Coqlib.gen_reference_in_modules "Omega" coq_modules x
+let z_constant x =
+ EConstr.of_constr @@
+ Universes.constr_of_global @@
+ Coqlib.gen_reference_in_modules "Omega" z_module x
+let bin_constant x =
+ EConstr.of_constr @@
+ Universes.constr_of_global @@
+ Coqlib.gen_reference_in_modules "Omega" bin_module x
(* Logic *)
let coq_refl_equal = lazy(init_constant "eq_refl")
@@ -130,62 +143,64 @@ let coq_O = lazy(init_constant "O")
let rec mk_nat = function
| 0 -> Lazy.force coq_O
- | n -> mkApp (Lazy.force coq_S, [| mk_nat (n-1) |])
+ | n -> EConstr.mkApp (Lazy.force coq_S, [| mk_nat (n-1) |])
(* Lists *)
-let mkListConst c =
- let r =
+let mkListConst c =
+ let r =
Coqlib.coq_reference "" ["Init";"Datatypes"] c
- in
- let inst =
- if Global.is_polymorphic r then fun u -> Univ.Instance.of_array [|u|]
- else fun _ -> Univ.Instance.empty
in
- fun u -> mkConstructU (Globnames.destConstructRef r, inst u)
+ let inst =
+ if Global.is_polymorphic r then
+ fun u -> EConstr.EInstance.make (Univ.Instance.of_array [|u|])
+ else
+ fun _ -> EConstr.EInstance.empty
+ in
+ fun u -> EConstr.mkConstructU (Globnames.destConstructRef r, inst u)
-let coq_cons univ typ = mkApp (mkListConst "cons" univ, [|typ|])
-let coq_nil univ typ = mkApp (mkListConst "nil" univ, [|typ|])
+let coq_cons univ typ = EConstr.mkApp (mkListConst "cons" univ, [|typ|])
+let coq_nil univ typ = EConstr.mkApp (mkListConst "nil" univ, [|typ|])
let mk_list univ typ l =
let rec loop = function
| [] -> coq_nil univ typ
| (step :: l) ->
- mkApp (coq_cons univ typ, [| step; loop l |]) in
+ EConstr.mkApp (coq_cons univ typ, [| step; loop l |]) in
loop l
-let mk_plist =
+let mk_plist =
let type1lev = Universes.new_univ_level () in
- fun l -> mk_list type1lev mkProp l
+ fun l -> mk_list type1lev EConstr.mkProp l
let mk_list = mk_list Univ.Level.set
type parse_term =
- | Tplus of constr * constr
- | Tmult of constr * constr
- | Tminus of constr * constr
- | Topp of constr
- | Tsucc of constr
+ | Tplus of EConstr.t * EConstr.t
+ | Tmult of EConstr.t * EConstr.t
+ | Tminus of EConstr.t * EConstr.t
+ | Topp of EConstr.t
+ | Tsucc of EConstr.t
| Tnum of Bigint.bigint
| Tother
type parse_rel =
- | Req of constr * constr
- | Rne of constr * constr
- | Rlt of constr * constr
- | Rle of constr * constr
- | Rgt of constr * constr
- | Rge of constr * constr
+ | Req of EConstr.t * EConstr.t
+ | Rne of EConstr.t * EConstr.t
+ | Rlt of EConstr.t * EConstr.t
+ | Rle of EConstr.t * EConstr.t
+ | Rgt of EConstr.t * EConstr.t
+ | Rge of EConstr.t * EConstr.t
| Rtrue
| Rfalse
- | Rnot of constr
- | Ror of constr * constr
- | Rand of constr * constr
- | Rimp of constr * constr
- | Riff of constr * constr
+ | Rnot of EConstr.t
+ | Ror of EConstr.t * EConstr.t
+ | Rand of EConstr.t * EConstr.t
+ | Rimp of EConstr.t * EConstr.t
+ | Riff of EConstr.t * EConstr.t
| Rother
-let parse_logic_rel c = match destructurate c with
+let parse_logic_rel sigma c = match destructurate sigma c with
| Kapp("True",[]) -> Rtrue
| Kapp("False",[]) -> Rfalse
| Kapp("not",[t]) -> Rnot t
@@ -211,29 +226,29 @@ let rec mk_positive n =
if Bigint.equal n Bigint.one then Lazy.force coq_xH
else
let (q,r) = Bigint.euclid n Bigint.two in
- mkApp
+ EConstr.mkApp
((if Bigint.equal r Bigint.zero
then Lazy.force coq_xO else Lazy.force coq_xI),
[| mk_positive q |])
let mk_N = function
| 0 -> Lazy.force coq_N0
- | n -> mkApp (Lazy.force coq_Npos,
+ | n -> EConstr.mkApp (Lazy.force coq_Npos,
[| mk_positive (Bigint.of_int n) |])
module type Int = sig
- val typ : constr Lazy.t
- val is_int_typ : Proofview.Goal.t -> constr -> bool
- val plus : constr Lazy.t
- val mult : constr Lazy.t
- val opp : constr Lazy.t
- val minus : constr Lazy.t
-
- val mk : Bigint.bigint -> constr
- val parse_term : constr -> parse_term
- val parse_rel : Proofview.Goal.t -> constr -> parse_rel
+ val typ : EConstr.t Lazy.t
+ val is_int_typ : Proofview.Goal.t -> EConstr.t -> bool
+ val plus : EConstr.t Lazy.t
+ val mult : EConstr.t Lazy.t
+ val opp : EConstr.t Lazy.t
+ val minus : EConstr.t Lazy.t
+
+ val mk : Bigint.bigint -> EConstr.t
+ val parse_term : Evd.evar_map -> EConstr.t -> parse_term
+ val parse_rel : Proofview.Goal.t -> EConstr.t -> parse_rel
(* check whether t is built only with numbers and + * - *)
- val get_scalar : constr -> Bigint.bigint option
+ val get_scalar : Evd.evar_map -> EConstr.t -> Bigint.bigint option
end
module Z : Int = struct
@@ -244,9 +259,9 @@ let mult = lazy (z_constant "Z.mul")
let opp = lazy (z_constant "Z.opp")
let minus = lazy (z_constant "Z.sub")
-let recognize_pos t =
+let recognize_pos sigma t =
let rec loop t =
- let f,l = dest_const_apply t in
+ let f,l = dest_const_apply sigma t in
match Id.to_string f,l with
| "xI",[t] -> Bigint.add Bigint.one (Bigint.mult Bigint.two (loop t))
| "xO",[t] -> Bigint.mult Bigint.two (loop t)
@@ -255,12 +270,12 @@ let recognize_pos t =
in
try Some (loop t) with DestConstApp -> None
-let recognize_Z t =
+let recognize_Z sigma t =
try
- let f,l = dest_const_apply t in
+ let f,l = dest_const_apply sigma t in
match Id.to_string f,l with
- | "Zpos",[t] -> recognize_pos t
- | "Zneg",[t] -> Option.map Bigint.neg (recognize_pos t)
+ | "Zpos",[t] -> recognize_pos sigma t
+ | "Zneg",[t] -> Option.map Bigint.neg (recognize_pos sigma t)
| "Z0",[] -> Some Bigint.zero
| _ -> None
with DestConstApp -> None
@@ -268,14 +283,14 @@ let recognize_Z t =
let mk_Z n =
if Bigint.equal n Bigint.zero then Lazy.force coq_Z0
else if Bigint.is_strictly_pos n then
- mkApp (Lazy.force coq_Zpos, [| mk_positive n |])
+ EConstr.mkApp (Lazy.force coq_Zpos, [| mk_positive n |])
else
- mkApp (Lazy.force coq_Zneg, [| mk_positive (Bigint.neg n) |])
+ EConstr.mkApp (Lazy.force coq_Zneg, [| mk_positive (Bigint.neg n) |])
let mk = mk_Z
-let parse_term t =
- match destructurate t with
+let parse_term sigma t =
+ match destructurate sigma t with
| Kapp("Z.add",[t1;t2]) -> Tplus (t1,t2)
| Kapp("Z.sub",[t1;t2]) -> Tminus (t1,t2)
| Kapp("Z.mul",[t1;t2]) -> Tmult (t1,t2)
@@ -283,35 +298,35 @@ let parse_term t =
| Kapp("Z.succ",[t]) -> Tsucc t
| Kapp("Z.pred",[t]) -> Tplus(t, mk_Z (Bigint.neg Bigint.one))
| Kapp(("Zpos"|"Zneg"|"Z0"),_) ->
- (match recognize_Z t with Some t -> Tnum t | None -> Tother)
+ (match recognize_Z sigma t with Some t -> Tnum t | None -> Tother)
| _ -> Tother
let is_int_typ gl t =
- Tacmach.New.pf_apply Reductionops.is_conv gl
- (EConstr.of_constr t) (EConstr.of_constr (Lazy.force coq_Z))
+ Tacmach.New.pf_apply Reductionops.is_conv gl t (Lazy.force coq_Z)
let parse_rel gl t =
- match destructurate t with
+ let sigma = Proofview.Goal.sigma gl in
+ match destructurate sigma t with
| Kapp("eq",[typ;t1;t2]) when is_int_typ gl typ -> Req (t1,t2)
| Kapp("Zne",[t1;t2]) -> Rne (t1,t2)
| Kapp("Z.le",[t1;t2]) -> Rle (t1,t2)
| Kapp("Z.lt",[t1;t2]) -> Rlt (t1,t2)
| Kapp("Z.ge",[t1;t2]) -> Rge (t1,t2)
| Kapp("Z.gt",[t1;t2]) -> Rgt (t1,t2)
- | _ -> parse_logic_rel t
+ | _ -> parse_logic_rel sigma t
-let rec get_scalar t =
- match destructurate t with
+let rec get_scalar sigma t =
+ match destructurate sigma t with
| Kapp("Z.add", [t1;t2]) ->
- Option.lift2 Bigint.add (get_scalar t1) (get_scalar t2)
+ Option.lift2 Bigint.add (get_scalar sigma t1) (get_scalar sigma t2)
| Kapp ("Z.sub",[t1;t2]) ->
- Option.lift2 Bigint.sub (get_scalar t1) (get_scalar t2)
+ Option.lift2 Bigint.sub (get_scalar sigma t1) (get_scalar sigma t2)
| Kapp ("Z.mul",[t1;t2]) ->
- Option.lift2 Bigint.mult (get_scalar t1) (get_scalar t2)
- | Kapp("Z.opp", [t]) -> Option.map Bigint.neg (get_scalar t)
- | Kapp("Z.succ", [t]) -> Option.map Bigint.add_1 (get_scalar t)
- | Kapp("Z.pred", [t]) -> Option.map Bigint.sub_1 (get_scalar t)
- | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> recognize_Z t
+ Option.lift2 Bigint.mult (get_scalar sigma t1) (get_scalar sigma t2)
+ | Kapp("Z.opp", [t]) -> Option.map Bigint.neg (get_scalar sigma t)
+ | Kapp("Z.succ", [t]) -> Option.map Bigint.add_1 (get_scalar sigma t)
+ | Kapp("Z.pred", [t]) -> Option.map Bigint.sub_1 (get_scalar sigma t)
+ | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> recognize_Z sigma t
| _ -> None
end
diff --git a/plugins/romega/const_omega.mli b/plugins/romega/const_omega.mli
index ecddc55de..64668df00 100644
--- a/plugins/romega/const_omega.mli
+++ b/plugins/romega/const_omega.mli
@@ -8,117 +8,116 @@
(** Coq objects used in romega *)
-open Constr
(* from Logic *)
-val coq_refl_equal : constr lazy_t
-val coq_and : constr lazy_t
-val coq_not : constr lazy_t
-val coq_or : constr lazy_t
-val coq_True : constr lazy_t
-val coq_False : constr lazy_t
-val coq_I : constr lazy_t
+val coq_refl_equal : EConstr.t lazy_t
+val coq_and : EConstr.t lazy_t
+val coq_not : EConstr.t lazy_t
+val coq_or : EConstr.t lazy_t
+val coq_True : EConstr.t lazy_t
+val coq_False : EConstr.t lazy_t
+val coq_I : EConstr.t lazy_t
(* from ReflOmegaCore/ZOmega *)
-val coq_t_int : constr lazy_t
-val coq_t_plus : constr lazy_t
-val coq_t_mult : constr lazy_t
-val coq_t_opp : constr lazy_t
-val coq_t_minus : constr lazy_t
-val coq_t_var : constr lazy_t
-
-val coq_proposition : constr lazy_t
-val coq_p_eq : constr lazy_t
-val coq_p_leq : constr lazy_t
-val coq_p_geq : constr lazy_t
-val coq_p_lt : constr lazy_t
-val coq_p_gt : constr lazy_t
-val coq_p_neq : constr lazy_t
-val coq_p_true : constr lazy_t
-val coq_p_false : constr lazy_t
-val coq_p_not : constr lazy_t
-val coq_p_or : constr lazy_t
-val coq_p_and : constr lazy_t
-val coq_p_imp : constr lazy_t
-val coq_p_prop : constr lazy_t
-
-val coq_s_bad_constant : constr lazy_t
-val coq_s_divide : constr lazy_t
-val coq_s_not_exact_divide : constr lazy_t
-val coq_s_sum : constr lazy_t
-val coq_s_merge_eq : constr lazy_t
-val coq_s_split_ineq : constr lazy_t
-
-val coq_direction : constr lazy_t
-val coq_d_left : constr lazy_t
-val coq_d_right : constr lazy_t
-
-val coq_e_split : constr lazy_t
-val coq_e_extract : constr lazy_t
-val coq_e_solve : constr lazy_t
-
-val coq_interp_sequent : constr lazy_t
-val coq_do_omega : constr lazy_t
-
-val mk_nat : int -> constr
-val mk_N : int -> constr
+val coq_t_int : EConstr.t lazy_t
+val coq_t_plus : EConstr.t lazy_t
+val coq_t_mult : EConstr.t lazy_t
+val coq_t_opp : EConstr.t lazy_t
+val coq_t_minus : EConstr.t lazy_t
+val coq_t_var : EConstr.t lazy_t
+
+val coq_proposition : EConstr.t lazy_t
+val coq_p_eq : EConstr.t lazy_t
+val coq_p_leq : EConstr.t lazy_t
+val coq_p_geq : EConstr.t lazy_t
+val coq_p_lt : EConstr.t lazy_t
+val coq_p_gt : EConstr.t lazy_t
+val coq_p_neq : EConstr.t lazy_t
+val coq_p_true : EConstr.t lazy_t
+val coq_p_false : EConstr.t lazy_t
+val coq_p_not : EConstr.t lazy_t
+val coq_p_or : EConstr.t lazy_t
+val coq_p_and : EConstr.t lazy_t
+val coq_p_imp : EConstr.t lazy_t
+val coq_p_prop : EConstr.t lazy_t
+
+val coq_s_bad_constant : EConstr.t lazy_t
+val coq_s_divide : EConstr.t lazy_t
+val coq_s_not_exact_divide : EConstr.t lazy_t
+val coq_s_sum : EConstr.t lazy_t
+val coq_s_merge_eq : EConstr.t lazy_t
+val coq_s_split_ineq : EConstr.t lazy_t
+
+val coq_direction : EConstr.t lazy_t
+val coq_d_left : EConstr.t lazy_t
+val coq_d_right : EConstr.t lazy_t
+
+val coq_e_split : EConstr.t lazy_t
+val coq_e_extract : EConstr.t lazy_t
+val coq_e_solve : EConstr.t lazy_t
+
+val coq_interp_sequent : EConstr.t lazy_t
+val coq_do_omega : EConstr.t lazy_t
+
+val mk_nat : int -> EConstr.t
+val mk_N : int -> EConstr.t
(** Precondition: the type of the list is in Set *)
-val mk_list : constr -> constr list -> constr
-val mk_plist : types list -> types
+val mk_list : EConstr.t -> EConstr.t list -> EConstr.t
+val mk_plist : EConstr.types list -> EConstr.types
(** Analyzing a coq term *)
(* The generic result shape of the analysis of a term.
One-level depth, except when a number is found *)
type parse_term =
- Tplus of constr * constr
- | Tmult of constr * constr
- | Tminus of constr * constr
- | Topp of constr
- | Tsucc of constr
+ Tplus of EConstr.t * EConstr.t
+ | Tmult of EConstr.t * EConstr.t
+ | Tminus of EConstr.t * EConstr.t
+ | Topp of EConstr.t
+ | Tsucc of EConstr.t
| Tnum of Bigint.bigint
| Tother
(* The generic result shape of the analysis of a relation.
One-level depth. *)
type parse_rel =
- Req of constr * constr
- | Rne of constr * constr
- | Rlt of constr * constr
- | Rle of constr * constr
- | Rgt of constr * constr
- | Rge of constr * constr
+ Req of EConstr.t * EConstr.t
+ | Rne of EConstr.t * EConstr.t
+ | Rlt of EConstr.t * EConstr.t
+ | Rle of EConstr.t * EConstr.t
+ | Rgt of EConstr.t * EConstr.t
+ | Rge of EConstr.t * EConstr.t
| Rtrue
| Rfalse
- | Rnot of constr
- | Ror of constr * constr
- | Rand of constr * constr
- | Rimp of constr * constr
- | Riff of constr * constr
+ | Rnot of EConstr.t
+ | Ror of EConstr.t * EConstr.t
+ | Rand of EConstr.t * EConstr.t
+ | Rimp of EConstr.t * EConstr.t
+ | Riff of EConstr.t * EConstr.t
| Rother
(* A module factorizing what we should now about the number representation *)
module type Int =
sig
(* the coq type of the numbers *)
- val typ : constr Lazy.t
+ val typ : EConstr.t Lazy.t
(* Is a constr expands to the type of these numbers *)
- val is_int_typ : Proofview.Goal.t -> constr -> bool
+ val is_int_typ : Proofview.Goal.t -> EConstr.t -> bool
(* the operations on the numbers *)
- val plus : constr Lazy.t
- val mult : constr Lazy.t
- val opp : constr Lazy.t
- val minus : constr Lazy.t
+ val plus : EConstr.t Lazy.t
+ val mult : EConstr.t Lazy.t
+ val opp : EConstr.t Lazy.t
+ val minus : EConstr.t Lazy.t
(* building a coq number *)
- val mk : Bigint.bigint -> constr
+ val mk : Bigint.bigint -> EConstr.t
(* parsing a term (one level, except if a number is found) *)
- val parse_term : constr -> parse_term
+ val parse_term : Evd.evar_map -> EConstr.t -> parse_term
(* parsing a relation expression, including = < <= >= > *)
- val parse_rel : Proofview.Goal.t -> constr -> parse_rel
+ val parse_rel : Proofview.Goal.t -> EConstr.t -> parse_rel
(* Is a particular term only made of numbers and + * - ? *)
- val get_scalar : constr -> Bigint.bigint option
+ val get_scalar : Evd.evar_map -> EConstr.t -> Bigint.bigint option
end
(* Currently, we only use Z numbers *)
diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml
index 54ff44fbd..d18249784 100644
--- a/plugins/romega/refl_omega.ml
+++ b/plugins/romega/refl_omega.ml
@@ -8,7 +8,6 @@
open Pp
open Util
-open Constr
open Const_omega
module OmegaSolver = Omega_plugin.Omega.MakeOmegaSolver (Bigint)
open OmegaSolver
@@ -67,14 +66,14 @@ type comparaison = Eq | Leq | Geq | Gt | Lt | Neq
(it could contains some [Term.Var] but no [Term.Rel]). So no need to
lift when breaking or creating arrows. *)
type oproposition =
- Pequa of constr * oequation (* constr = copy of the Coq formula *)
+ Pequa of EConstr.t * oequation (* constr = copy of the Coq formula *)
| Ptrue
| Pfalse
| Pnot of oproposition
| Por of int * oproposition * oproposition
| Pand of int * oproposition * oproposition
| Pimp of int * oproposition * oproposition
- | Pprop of constr
+ | Pprop of EConstr.t
(* The equations *)
and oequation = {
@@ -101,9 +100,9 @@ and oequation = {
type environment = {
(* La liste des termes non reifies constituant l'environnement global *)
- mutable terms : constr list;
+ mutable terms : EConstr.t list;
(* La meme chose pour les propositions *)
- mutable props : constr list;
+ mutable props : EConstr.t list;
(* Traduction des indices utilisés ici en les indices finaux utilisés par
* la tactique Omega après dénombrement des variables utiles *)
real_indices : int IntHtbl.t;
@@ -185,7 +184,7 @@ let print_env_reification env =
| t :: l ->
let sigma, env = Pfedit.get_current_context () in
let s = Printf.sprintf "(%c%02d)" c i in
- spc () ++ str s ++ str " := " ++ Printer.pr_lconstr_env env sigma t ++ fnl () ++
+ spc () ++ str s ++ str " := " ++ Printer.pr_econstr_env env sigma t ++ fnl () ++
loop c (succ i) l
in
let prop_info = str "ENVIRONMENT OF PROPOSITIONS :" ++ fnl () ++ loop 'P' 0 env.props in
@@ -218,8 +217,8 @@ let display_omega_var i = Printf.sprintf "OV%d" i
l'environnement initial contenant tout. Il faudra le réduire après
calcul des variables utiles. *)
-let add_reified_atom t env =
- try List.index0 Constr.equal t env.terms
+let add_reified_atom sigma t env =
+ try List.index0 (EConstr.eq_constr sigma) t env.terms
with Not_found ->
let i = List.length env.terms in
env.terms <- env.terms @ [t]; i
@@ -236,8 +235,8 @@ let set_reified_atom v t env =
(* \subsection{Gestion de l'environnement de proposition pour Omega} *)
(* ajout d'une proposition *)
-let add_prop env t =
- try List.index0 Constr.equal t env.props
+let add_prop sigma env t =
+ try List.index0 (EConstr.eq_constr sigma) t env.props
with Not_found ->
let i = List.length env.props in env.props <- env.props @ [t]; i
@@ -290,7 +289,7 @@ let oformula_of_omega af =
in
loop af.body
-let app f v = mkApp(Lazy.force f,v)
+let app f v = EConstr.mkApp(Lazy.force f,v)
(* \subsection{Oformula vers COQ reel} *)
@@ -347,18 +346,19 @@ let reified_conn = function
| Pimp _ -> app coq_p_imp
| _ -> assert false
-let rec reified_of_oprop env t = match t with
+let rec reified_of_oprop sigma env t = match t with
| Pequa (_,{ e_comp=cmp; e_left=t1; e_right=t2 }) ->
reified_cmp cmp [| reified_of_formula env t1; reified_of_formula env t2 |]
| Ptrue -> Lazy.force coq_p_true
| Pfalse -> Lazy.force coq_p_false
- | Pnot t -> app coq_p_not [| reified_of_oprop env t |]
+ | Pnot t -> app coq_p_not [| reified_of_oprop sigma env t |]
| Por (_,t1,t2) | Pand (_,t1,t2) | Pimp (_,t1,t2) ->
- reified_conn t [| reified_of_oprop env t1; reified_of_oprop env t2 |]
- | Pprop t -> app coq_p_prop [| mk_nat (add_prop env t) |]
+ reified_conn t
+ [| reified_of_oprop sigma env t1; reified_of_oprop sigma env t2 |]
+ | Pprop t -> app coq_p_prop [| mk_nat (add_prop sigma env t) |]
-let reified_of_proposition env f =
- try reified_of_oprop env f
+let reified_of_proposition sigma env f =
+ try reified_of_oprop sigma env f
with reraise -> pprint stderr f; raise reraise
let reified_of_eq env (l,r) =
@@ -475,28 +475,28 @@ let mkPor i x y = Por (i,x,y)
let mkPand i x y = Pand (i,x,y)
let mkPimp i x y = Pimp (i,x,y)
-let rec oformula_of_constr env t =
- match Z.parse_term t with
- | Tplus (t1,t2) -> binop env (fun x y -> Oplus(x,y)) t1 t2
- | Tminus (t1,t2) -> binop env (fun x y -> Ominus(x,y)) t1 t2
+let rec oformula_of_constr sigma env t =
+ match Z.parse_term sigma t with
+ | Tplus (t1,t2) -> binop sigma env (fun x y -> Oplus(x,y)) t1 t2
+ | Tminus (t1,t2) -> binop sigma env (fun x y -> Ominus(x,y)) t1 t2
| Tmult (t1,t2) ->
- (match Z.get_scalar t1 with
- | Some n -> Omult (Oint n,oformula_of_constr env t2)
+ (match Z.get_scalar sigma t1 with
+ | Some n -> Omult (Oint n,oformula_of_constr sigma env t2)
| None ->
- match Z.get_scalar t2 with
- | Some n -> Omult (oformula_of_constr env t1, Oint n)
- | None -> Oatom (add_reified_atom t env))
- | Topp t -> Oopp(oformula_of_constr env t)
- | Tsucc t -> Oplus(oformula_of_constr env t, Oint one)
+ match Z.get_scalar sigma t2 with
+ | Some n -> Omult (oformula_of_constr sigma env t1, Oint n)
+ | None -> Oatom (add_reified_atom sigma t env))
+ | Topp t -> Oopp(oformula_of_constr sigma env t)
+ | Tsucc t -> Oplus(oformula_of_constr sigma env t, Oint one)
| Tnum n -> Oint n
- | Tother -> Oatom (add_reified_atom t env)
+ | Tother -> Oatom (add_reified_atom sigma t env)
-and binop env c t1 t2 =
- let t1' = oformula_of_constr env t1 in
- let t2' = oformula_of_constr env t2 in
+and binop sigma env c t1 t2 =
+ let t1' = oformula_of_constr sigma env t1 in
+ let t2' = oformula_of_constr sigma env t2 in
c t1' t2'
-and binprop env (neg2,depends,origin,path)
+and binprop sigma env (neg2,depends,origin,path)
add_to_depends neg1 gl c t1 t2 =
let i = new_connector_id env in
let depends1 = if add_to_depends then Left i::depends else depends in
@@ -504,41 +504,41 @@ and binprop env (neg2,depends,origin,path)
if add_to_depends then
IntHtbl.add env.constructors i {o_hyp = origin; o_path = List.rev path};
let t1' =
- oproposition_of_constr env (neg1,depends1,origin,O_left::path) gl t1 in
+ oproposition_of_constr sigma env (neg1,depends1,origin,O_left::path) gl t1 in
let t2' =
- oproposition_of_constr env (neg2,depends2,origin,O_right::path) gl t2 in
+ oproposition_of_constr sigma env (neg2,depends2,origin,O_right::path) gl t2 in
(* On numérote le connecteur dans l'environnement. *)
c i t1' t2'
-and mk_equation env ctxt c connector t1 t2 =
- let t1' = oformula_of_constr env t1 in
- let t2' = oformula_of_constr env t2 in
+and mk_equation sigma env ctxt c connector t1 t2 =
+ let t1' = oformula_of_constr sigma env t1 in
+ let t2' = oformula_of_constr sigma env t2 in
(* On ajoute l'equation dans l'environnement. *)
let omega = normalize_equation env ctxt connector t1' t2' in
add_equation env omega;
Pequa (c,omega)
-and oproposition_of_constr env ((negated,depends,origin,path) as ctxt) gl c =
+and oproposition_of_constr sigma env ((negated,depends,origin,path) as ctxt) gl c =
match Z.parse_rel gl c with
- | Req (t1,t2) -> mk_equation env ctxt c Eq t1 t2
- | Rne (t1,t2) -> mk_equation env ctxt c Neq t1 t2
- | Rle (t1,t2) -> mk_equation env ctxt c Leq t1 t2
- | Rlt (t1,t2) -> mk_equation env ctxt c Lt t1 t2
- | Rge (t1,t2) -> mk_equation env ctxt c Geq t1 t2
- | Rgt (t1,t2) -> mk_equation env ctxt c Gt t1 t2
+ | Req (t1,t2) -> mk_equation sigma env ctxt c Eq t1 t2
+ | Rne (t1,t2) -> mk_equation sigma env ctxt c Neq t1 t2
+ | Rle (t1,t2) -> mk_equation sigma env ctxt c Leq t1 t2
+ | Rlt (t1,t2) -> mk_equation sigma env ctxt c Lt t1 t2
+ | Rge (t1,t2) -> mk_equation sigma env ctxt c Geq t1 t2
+ | Rgt (t1,t2) -> mk_equation sigma env ctxt c Gt t1 t2
| Rtrue -> Ptrue
| Rfalse -> Pfalse
| Rnot t ->
let ctxt' = (not negated, depends, origin,(O_mono::path)) in
- Pnot (oproposition_of_constr env ctxt' gl t)
- | Ror (t1,t2) -> binprop env ctxt (not negated) negated gl mkPor t1 t2
- | Rand (t1,t2) -> binprop env ctxt negated negated gl mkPand t1 t2
+ Pnot (oproposition_of_constr sigma env ctxt' gl t)
+ | Ror (t1,t2) -> binprop sigma env ctxt (not negated) negated gl mkPor t1 t2
+ | Rand (t1,t2) -> binprop sigma env ctxt negated negated gl mkPand t1 t2
| Rimp (t1,t2) ->
- binprop env ctxt (not negated) (not negated) gl mkPimp t1 t2
+ binprop sigma env ctxt (not negated) (not negated) gl mkPimp t1 t2
| Riff (t1,t2) ->
(* No lifting here, since Omega only works on closed propositions. *)
- binprop env ctxt negated negated gl mkPand
- (Term.mkArrow t1 t2) (Term.mkArrow t2 t1)
+ binprop sigma env ctxt negated negated gl mkPand
+ (EConstr.mkArrow t1 t2) (EConstr.mkArrow t2 t1)
| _ -> Pprop c
(* Destructuration des hypothèses et de la conclusion *)
@@ -553,27 +553,25 @@ let display_gl env t_concl t_lhyps =
type defined = Defined | Assumed
-let reify_hyp env gl i =
+let reify_hyp sigma env gl i =
let open Context.Named.Declaration in
let ctxt = (false,[],i,[]) in
match Tacmach.New.pf_get_hyp i gl with
- | LocalDef (_,d,t) when Z.is_int_typ gl (EConstr.Unsafe.to_constr t) ->
- let d = EConstr.Unsafe.to_constr d in
+ | LocalDef (_,d,t) when Z.is_int_typ gl t ->
let dummy = Lazy.force coq_True in
- let p = mk_equation env ctxt dummy Eq (mkVar i) d in
+ let p = mk_equation sigma env ctxt dummy Eq (EConstr.mkVar i) d in
i,Defined,p
| LocalDef (_,_,t) | LocalAssum (_,t) ->
- let t = EConstr.Unsafe.to_constr t in
- let p = oproposition_of_constr env ctxt gl t in
+ let p = oproposition_of_constr sigma env ctxt gl t in
i,Assumed,p
let reify_gl env gl =
+ let sigma = Proofview.Goal.sigma gl in
let concl = Tacmach.New.pf_concl gl in
- let concl = EConstr.Unsafe.to_constr concl in
let hyps = Tacmach.New.pf_ids_of_hyps gl in
let ctxt_concl = (true,[],id_concl,[O_mono]) in
- let t_concl = oproposition_of_constr env ctxt_concl gl concl in
- let t_lhyps = List.map (reify_hyp env gl) hyps in
+ let t_concl = oproposition_of_constr sigma env ctxt_concl gl concl in
+ let t_lhyps = List.map (reify_hyp sigma env gl) hyps in
let () = if !debug then display_gl env t_concl t_lhyps in
t_concl, t_lhyps
@@ -684,8 +682,7 @@ let rec stated_in_tree = function
| Tree(_,t1,t2) -> StateSet.union (stated_in_tree t1) (stated_in_tree t2)
| Leaf s -> stated_in_trace s.s_trace
-let mk_refl t =
- EConstr.of_constr (app coq_refl_equal [|Lazy.force Z.typ; t|])
+let mk_refl t = app coq_refl_equal [|Lazy.force Z.typ; t|]
let digest_stated_equations env tree =
let do_equation st (vars,gens,eqns,ids) =
@@ -775,7 +772,7 @@ let maximize_prop equas c =
| t1', t2' -> Pand(i,t1',t2'))
| Pimp(i,t1,t2) ->
(match loop t1, loop t2 with
- | Pprop p1, Pprop p2 -> Pprop (Term.mkArrow p1 p2) (* no lift (closed) *)
+ | Pprop p1, Pprop p2 -> Pprop (EConstr.mkArrow p1 p2) (* no lift (closed) *)
| t1', t2' -> Pimp(i,t1',t2'))
| Ptrue -> Pprop (app coq_True [||])
| Pfalse -> Pprop (app coq_False [||])
@@ -852,12 +849,15 @@ let hyp_idx env_hyp i =
a O_SUM followed by a O_BAD_CONSTANT *)
let sum_bad inv i1 i2 =
+ let open EConstr in
mkApp (Lazy.force coq_s_sum,
[| Z.mk Bigint.one; i1;
Z.mk (if inv then negone else Bigint.one); i2;
mkApp (Lazy.force coq_s_bad_constant, [| mk_nat 0 |])|])
-let rec reify_trace env env_hyp = function
+let rec reify_trace env env_hyp =
+ let open EConstr in
+ function
| CONSTANT_NOT_NUL(e,_) :: []
| CONSTANT_NEG(e,_) :: []
| CONSTANT_NUL e :: [] ->
@@ -958,7 +958,7 @@ l'extraction d'un ensemble minimal de solutions permettant la
résolution globale du système et enfin construit la trace qui permet
de faire rejouer cette solution par la tactique réflexive. *)
-let resolution unsafe env (reified_concl,reified_hyps) systems_list =
+let resolution unsafe sigma env (reified_concl,reified_hyps) systems_list =
if !debug then Printf.printf "\n====================================\n";
let all_solutions = List.mapi (solve_system env) systems_list in
let solution_tree = solve_with_constraints all_solutions [] in
@@ -1006,15 +1006,15 @@ let resolution unsafe env (reified_concl,reified_hyps) systems_list =
(** The environment [env] (and especially [env.real_indices]) is now
ready for the coming reifications: *)
let l_reified_stated = List.map (reified_of_eq env) to_reify_stated in
- let reified_concl = reified_of_proposition env reified_concl in
+ let reified_concl = reified_of_proposition sigma env reified_concl in
let l_reified_terms =
List.map
(fun id ->
match Id.Map.find id reified_hyps with
| Defined,p ->
- reified_of_proposition env p, mk_refl (mkVar id)
+ reified_of_proposition sigma env p, mk_refl (EConstr.mkVar id)
| Assumed,p ->
- reified_of_proposition env (maximize_prop useful_equa_ids p),
+ reified_of_proposition sigma env (maximize_prop useful_equa_ids p),
EConstr.mkVar id
| exception Not_found -> assert false)
useful_hypnames
@@ -1036,17 +1036,16 @@ let resolution unsafe env (reified_concl,reified_hyps) systems_list =
let decompose_tactic = decompose_tree env context solution_tree in
Tactics.generalize (l_generalize_arg @ l_reified_hypnames) >>
- Tactics.convert_concl_no_check (EConstr.of_constr reified) Term.DEFAULTcast >>
- Tactics.apply (EConstr.of_constr (app coq_do_omega [|decompose_tactic|])) >>
+ Tactics.convert_concl_no_check reified Term.DEFAULTcast >>
+ Tactics.apply (app coq_do_omega [|decompose_tactic|]) >>
show_goal >>
(if unsafe then
(* Trust the produced term. Faster, but might fail later at Qed.
Also handy when debugging, e.g. via a Show Proof after romega. *)
- Tactics.convert_concl_no_check
- (EConstr.of_constr (Lazy.force coq_True)) Term.VMcast
+ Tactics.convert_concl_no_check (Lazy.force coq_True) Term.VMcast
else
Tactics.normalise_vm_in_concl) >>
- Tactics.apply (EConstr.of_constr (Lazy.force coq_I))
+ Tactics.apply (Lazy.force coq_I)
let total_reflexive_omega_tactic unsafe =
Proofview.Goal.nf_enter begin fun gl ->
@@ -1064,7 +1063,8 @@ let total_reflexive_omega_tactic unsafe =
List.fold_left (fun s (id,d,p) -> Id.Map.add id (d,p) s) Id.Map.empty hyps
in
if !debug then display_systems systems_list;
- resolution unsafe env (concl,hyps) systems_list
+ let sigma = Proofview.Goal.sigma gl in
+ resolution unsafe sigma env (concl,hyps) systems_list
with NO_CONTRADICTION -> CErrors.user_err Pp.(str "ROmega can't solve this system")
end
diff --git a/plugins/rtauto/Rtauto.v b/plugins/rtauto/Rtauto.v
index db17c0d65..06cdf76b4 100644
--- a/plugins/rtauto/Rtauto.v
+++ b/plugins/rtauto/Rtauto.v
@@ -11,7 +11,7 @@
Require Export List.
Require Export Bintree.
-Require Import Bool.
+Require Import Bool BinPos.
Declare ML Module "rtauto_plugin".
@@ -98,8 +98,6 @@ match F with
| F_push H hyps0 F0 => interp_ctx hyps0 F0 ([[H]] -> G)
end.
-Require Export BinPos.
-
Ltac wipe := intros;simpl;constructor.
Lemma compose0 :
@@ -257,122 +255,115 @@ Theorem interp_proof:
forall p hyps F gl,
check_proof hyps gl p = true -> interp_ctx hyps F [[gl]].
-induction p;intros hyps F gl.
-
-(* cas Axiom *)
-Focus 1.
-simpl;case_eq (get p hyps);clean.
-intros f nth_f e;rewrite <- (form_eq_refl e).
-apply project with p;trivial.
-
-(* Cas Arrow_Intro *)
-Focus 1.
-destruct gl;clean.
-simpl;intros.
-change (interp_ctx (hyps\gl1) (F_push gl1 hyps F) [[gl2]]).
-apply IHp;try constructor;trivial.
-
-(* Cas Arrow_Elim *)
-Focus 1.
-simpl check_proof;case_eq (get p hyps);clean.
-intros f ef;case_eq (get p0 hyps);clean.
-intros f0 ef0;destruct f0;clean.
-case_eq (form_eq f f0_1);clean.
-simpl;intros e check_p1.
-generalize (project F ef) (project F ef0)
-(IHp (hyps \ f0_2) (F_push f0_2 hyps F) gl check_p1);
-clear check_p1 IHp p p0 p1 ef ef0.
-simpl.
-apply compose3.
-rewrite (form_eq_refl e).
-auto.
-
-(* cas Arrow_Destruct *)
-Focus 1.
-simpl;case_eq (get p1 hyps);clean.
-intros f ef;destruct f;clean.
-destruct f1;clean.
-case_eq (check_proof (hyps \ f1_2 =>> f2 \ f1_1) f1_2 p2);clean.
-intros check_p1 check_p2.
-generalize (project F ef)
-(IHp1 (hyps \ f1_2 =>> f2 \ f1_1)
-(F_push f1_1 (hyps \ f1_2 =>> f2)
- (F_push (f1_2 =>> f2) hyps F)) f1_2 check_p1)
-(IHp2 (hyps \ f2) (F_push f2 hyps F) gl check_p2).
-simpl;apply compose3;auto.
-
-(* Cas False_Elim *)
-Focus 1.
-simpl;case_eq (get p hyps);clean.
-intros f ef;destruct f;clean.
-intros _; generalize (project F ef).
-apply compose1;apply False_ind.
-
-(* Cas And_Intro *)
-Focus 1.
-simpl;destruct gl;clean.
-case_eq (check_proof hyps gl1 p1);clean.
-intros Hp1 Hp2;generalize (IHp1 hyps F gl1 Hp1) (IHp2 hyps F gl2 Hp2).
-apply compose2 ;simpl;auto.
-
-(* cas And_Elim *)
-Focus 1.
-simpl;case_eq (get p hyps);clean.
-intros f ef;destruct f;clean.
-intro check_p;generalize (project F ef)
-(IHp (hyps \ f1 \ f2) (F_push f2 (hyps \ f1) (F_push f1 hyps F)) gl check_p).
-simpl;apply compose2;intros [h1 h2];auto.
-
-(* cas And_Destruct *)
-Focus 1.
-simpl;case_eq (get p hyps);clean.
-intros f ef;destruct f;clean.
-destruct f1;clean.
-intro H;generalize (project F ef)
-(IHp (hyps \ f1_1 =>> f1_2 =>> f2)
-(F_push (f1_1 =>> f1_2 =>> f2) hyps F) gl H);clear H;simpl.
-apply compose2;auto.
-
-(* cas Or_Intro_left *)
-Focus 1.
-destruct gl;clean.
-intro Hp;generalize (IHp hyps F gl1 Hp).
-apply compose1;simpl;auto.
-
-(* cas Or_Intro_right *)
-Focus 1.
-destruct gl;clean.
-intro Hp;generalize (IHp hyps F gl2 Hp).
-apply compose1;simpl;auto.
-
-(* cas Or_elim *)
-Focus 1.
-simpl;case_eq (get p1 hyps);clean.
-intros f ef;destruct f;clean.
-case_eq (check_proof (hyps \ f1) gl p2);clean.
-intros check_p1 check_p2;generalize (project F ef)
-(IHp1 (hyps \ f1) (F_push f1 hyps F) gl check_p1)
-(IHp2 (hyps \ f2) (F_push f2 hyps F) gl check_p2);
-simpl;apply compose3;simpl;intro h;destruct h;auto.
-
-(* cas Or_Destruct *)
-Focus 1.
-simpl;case_eq (get p hyps);clean.
-intros f ef;destruct f;clean.
-destruct f1;clean.
-intro check_p0;generalize (project F ef)
-(IHp (hyps \ f1_1 =>> f2 \ f1_2 =>> f2)
-(F_push (f1_2 =>> f2) (hyps \ f1_1 =>> f2)
- (F_push (f1_1 =>> f2) hyps F)) gl check_p0);simpl.
-apply compose2;auto.
-
-(* cas Cut *)
-Focus 1.
-simpl;case_eq (check_proof hyps f p1);clean.
-intros check_p1 check_p2;
-generalize (IHp1 hyps F f check_p1)
-(IHp2 (hyps\f) (F_push f hyps F) gl check_p2);
-simpl; apply compose2;auto.
+induction p; intros hyps F gl.
+
+- (* Axiom *)
+ simpl;case_eq (get p hyps);clean.
+ intros f nth_f e;rewrite <- (form_eq_refl e).
+ apply project with p;trivial.
+
+- (* Arrow_Intro *)
+ destruct gl; clean.
+ simpl; intros.
+ change (interp_ctx (hyps\gl1) (F_push gl1 hyps F) [[gl2]]).
+ apply IHp; try constructor; trivial.
+
+- (* Arrow_Elim *)
+ simpl check_proof; case_eq (get p hyps); clean.
+ intros f ef; case_eq (get p0 hyps); clean.
+ intros f0 ef0; destruct f0; clean.
+ case_eq (form_eq f f0_1); clean.
+ simpl; intros e check_p1.
+ generalize (project F ef) (project F ef0)
+ (IHp (hyps \ f0_2) (F_push f0_2 hyps F) gl check_p1);
+ clear check_p1 IHp p p0 p1 ef ef0.
+ simpl.
+ apply compose3.
+ rewrite (form_eq_refl e).
+ auto.
+
+- (* Arrow_Destruct *)
+ simpl; case_eq (get p1 hyps); clean.
+ intros f ef; destruct f; clean.
+ destruct f1; clean.
+ case_eq (check_proof (hyps \ f1_2 =>> f2 \ f1_1) f1_2 p2); clean.
+ intros check_p1 check_p2.
+ generalize (project F ef)
+ (IHp1 (hyps \ f1_2 =>> f2 \ f1_1)
+ (F_push f1_1 (hyps \ f1_2 =>> f2)
+ (F_push (f1_2 =>> f2) hyps F)) f1_2 check_p1)
+ (IHp2 (hyps \ f2) (F_push f2 hyps F) gl check_p2).
+ simpl; apply compose3; auto.
+
+- (* False_Elim *)
+ simpl; case_eq (get p hyps); clean.
+ intros f ef; destruct f; clean.
+ intros _; generalize (project F ef).
+ apply compose1; apply False_ind.
+
+- (* And_Intro *)
+ simpl; destruct gl; clean.
+ case_eq (check_proof hyps gl1 p1); clean.
+ intros Hp1 Hp2;generalize (IHp1 hyps F gl1 Hp1) (IHp2 hyps F gl2 Hp2).
+ apply compose2 ; simpl; auto.
+
+- (* And_Elim *)
+ simpl; case_eq (get p hyps); clean.
+ intros f ef; destruct f; clean.
+ intro check_p;
+ generalize (project F ef)
+ (IHp (hyps \ f1 \ f2) (F_push f2 (hyps \ f1) (F_push f1 hyps F)) gl check_p).
+ simpl; apply compose2; intros [h1 h2]; auto.
+
+- (* And_Destruct*)
+ simpl; case_eq (get p hyps); clean.
+ intros f ef; destruct f; clean.
+ destruct f1; clean.
+ intro H;
+ generalize (project F ef)
+ (IHp (hyps \ f1_1 =>> f1_2 =>> f2)
+ (F_push (f1_1 =>> f1_2 =>> f2) hyps F) gl H);
+ clear H; simpl.
+ apply compose2; auto.
+
+- (* Or_Intro_left *)
+ destruct gl; clean.
+ intro Hp; generalize (IHp hyps F gl1 Hp).
+ apply compose1; simpl; auto.
+
+- (* Or_Intro_right *)
+ destruct gl; clean.
+ intro Hp; generalize (IHp hyps F gl2 Hp).
+ apply compose1; simpl; auto.
+
+- (* Or_elim *)
+ simpl; case_eq (get p1 hyps); clean.
+ intros f ef; destruct f; clean.
+ case_eq (check_proof (hyps \ f1) gl p2); clean.
+ intros check_p1 check_p2;
+ generalize (project F ef)
+ (IHp1 (hyps \ f1) (F_push f1 hyps F) gl check_p1)
+ (IHp2 (hyps \ f2) (F_push f2 hyps F) gl check_p2);
+ simpl; apply compose3; simpl; intro h; destruct h; auto.
+
+- (* Or_Destruct *)
+ simpl; case_eq (get p hyps); clean.
+ intros f ef; destruct f; clean.
+ destruct f1; clean.
+ intro check_p0;
+ generalize (project F ef)
+ (IHp (hyps \ f1_1 =>> f2 \ f1_2 =>> f2)
+ (F_push (f1_2 =>> f2) (hyps \ f1_1 =>> f2)
+ (F_push (f1_1 =>> f2) hyps F)) gl check_p0);
+ simpl.
+ apply compose2; auto.
+
+- (* Cut *)
+ simpl; case_eq (check_proof hyps f p1); clean.
+ intros check_p1 check_p2;
+ generalize (IHp1 hyps F f check_p1)
+ (IHp2 (hyps\f) (F_push f hyps F) gl check_p2);
+ simpl; apply compose2; auto.
Qed.
Theorem Reflect: forall gl prf, if check_proof empty gl prf then [[gl]] else True.
diff --git a/plugins/ssr/ssrast.mli b/plugins/ssr/ssrast.mli
index 9783bc61d..7f5f2f63d 100644
--- a/plugins/ssr/ssrast.mli
+++ b/plugins/ssr/ssrast.mli
@@ -138,7 +138,7 @@ type ssrclseq = InGoal | InHyps
type 'tac ssrhint = bool * 'tac option list
type 'tac fwdbinders =
- bool * (ssrhpats * ((ssrfwdfmt * ssrterm) * 'tac ssrhint))
+ bool * (ssrhpats * ((ssrfwdfmt * ast_closure_term) * 'tac ssrhint))
type clause =
(ssrclear * ((ssrhyp_or_id * string) *
@@ -157,13 +157,15 @@ type 'a ssrseqarg = ssrindex * ('a ssrhint * 'a option)
open Ssrmatching_plugin
open Ssrmatching
+
+type 'a ssrcasearg = ssripat option * ('a * ssripats)
+type 'a ssrmovearg = ssrview * 'a ssrcasearg
+
type ssrdgens = { dgens : (ssrdocc * cpattern) list;
gens : (ssrdocc * cpattern) list;
clr : ssrclear }
-type ssrcasearg = ssripat option * (ssrdgens * ssripats)
-type ssrmovearg = ssrview * ssrcasearg
-type ssragens = ((ssrhyps option * occ) * ssrterm) list list * ssrclear
-type ssrapplyarg = ssrterm list * (ssragens * ssripats)
+type 'a ssragens = (ssrdocc * 'a) list list * ssrclear
+type ssrapplyarg = ssrterm list * (ssrterm ssragens * ssripats)
(* OOP : these are general shortcuts *)
type gist = Tacintern.glob_sign
diff --git a/plugins/ssr/ssrbwd.mli b/plugins/ssr/ssrbwd.mli
index 6243e5e68..694ecfa37 100644
--- a/plugins/ssr/ssrbwd.mli
+++ b/plugins/ssr/ssrbwd.mli
@@ -13,4 +13,4 @@ open Proofview
val apply_top_tac : unit tactic
-val inner_ssrapplytac : ssrterm list -> ssragens -> ist -> unit tactic
+val inner_ssrapplytac : ssrterm list -> ssrterm ssragens -> ist -> unit tactic
diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml
index 5163ec7b3..f049963f1 100644
--- a/plugins/ssr/ssrcommon.ml
+++ b/plugins/ssr/ssrcommon.ml
@@ -460,7 +460,7 @@ let red_product_skip_id env sigma c = match EConstr.kind sigma c with
let ssrevaltac ist gtac = Tacinterp.tactic_of_value ist gtac
-(** Open term to lambda-term coercion {{{ ************************************)
+(** Open term to lambda-term coercion *)(* {{{ ************************************)
(* This operation takes a goal gl and an open term (sigma, t), and *)
(* returns a term t' where all the new evars in sigma are abstracted *)
@@ -768,7 +768,7 @@ let discharge_hyp (id', (id, mode)) gl =
let cl' = Vars.subst_var id (pf_concl gl) in
match pf_get_hyp gl id, mode with
| NamedDecl.LocalAssum (_, t), _ | NamedDecl.LocalDef (_, _, t), "(" ->
- Proofview.V82.of_tactic (Tactics.apply_type ~typecheck:false (EConstr.of_constr (mkProd (Name id', t, cl')))
+ Proofview.V82.of_tactic (Tactics.apply_type ~typecheck:true (EConstr.of_constr (mkProd (Name id', t, cl')))
[EConstr.of_constr (mkVar id)]) gl
| NamedDecl.LocalDef (_, v, t), _ ->
Proofview.V82.of_tactic
@@ -1000,7 +1000,7 @@ let refine_with ?(first_goes_last=false) ?beta ?(with_evars=true) oc gl =
try applyn ~with_evars ~with_shelve:true ?beta n (EConstr.of_constr oc) gl
with e when CErrors.noncritical e -> raise dependent_apply_error
-(** Profiling {{{ *************************************************************)
+(** Profiling *)(* {{{ *************************************************************)
type profiler = {
profile : 'a 'b. ('a -> 'b) -> 'a -> 'b;
reset : unit -> unit;
@@ -1128,7 +1128,7 @@ let interp_clr sigma = function
(** Basic tacticals *)
-(** Multipliers {{{ ***********************************************************)
+(** Multipliers *)(* {{{ ***********************************************************)
(* tactical *)
@@ -1168,7 +1168,7 @@ let tclMULT = function
let old_cleartac clr = check_hyps_uniq [] clr; Proofview.V82.of_tactic (Tactics.clear (hyps_ids clr))
let cleartac clr = check_hyps_uniq [] clr; Tactics.clear (hyps_ids clr)
-(** }}} *)
+(* }}} *)
(** Generalize tactic *)
@@ -1193,13 +1193,13 @@ let pf_interp_gen_aux gl to_ind ((oclr, occ), t) =
else let gl, ccl = pf_mkprod gl c cl in false, pat, ccl, c, clr,ucst,gl
else if to_ind && occ = None then
let nv, p, _, ucst' = pf_abs_evars gl (fst pat, c) in
- let ucst = Evd.union_evar_universe_context ucst ucst' in
+ let ucst = UState.union ucst ucst' in
if nv = 0 then anomaly "occur_existential but no evars" else
let gl, pty = pfe_type_of gl p in
false, pat, EConstr.mkProd (constr_name (project gl) c, pty, Tacmach.pf_concl gl), p, clr,ucst,gl
else CErrors.user_err ?loc:(loc_of_cpattern t) (str "generalized term didn't match")
-let apply_type x xs = Proofview.V82.of_tactic (Tactics.apply_type ~typecheck:false x xs)
+let apply_type x xs = Proofview.V82.of_tactic (Tactics.apply_type ~typecheck:true x xs)
let genclrtac cl cs clr =
let tclmyORELSE tac1 tac2 gl =
diff --git a/plugins/ssr/ssrcommon.mli b/plugins/ssr/ssrcommon.mli
index 7c16e1ba9..2b8f1d540 100644
--- a/plugins/ssr/ssrcommon.mli
+++ b/plugins/ssr/ssrcommon.mli
@@ -414,6 +414,8 @@ val clr_of_wgen :
val unfold : EConstr.t list -> unit Proofview.tactic
+val apply_type : EConstr.types -> EConstr.t list -> Proofview.V82.tac
+
(* New code ****************************************************************)
(* To call old code *)
diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml
index 33ebe26b6..717657a24 100644
--- a/plugins/ssr/ssrelim.ml
+++ b/plugins/ssr/ssrelim.ml
@@ -30,8 +30,6 @@ module RelDecl = Context.Rel.Declaration
(** The "case" and "elim" tactic *)
-let apply_type x xs = Proofview.V82.of_tactic (Tactics.apply_type ~typecheck:false x xs)
-
(* TASSI: given the type of an elimination principle, it finds the higher order
* argument (index), it computes it's arity and the arity of the eliminator and
* checks if the eliminator is recursive or not *)
diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml
index 71cde0ca1..57635edac 100644
--- a/plugins/ssr/ssrequality.ml
+++ b/plugins/ssr/ssrequality.ml
@@ -143,18 +143,6 @@ let newssrcongrtac arg ist gl =
(** 7. Rewriting tactics (rewrite, unlock) *)
-(** Coq rewrite compatibility flag *)
-
-
-let _ =
- let ssr_strict_match = ref false in
- Goptions.declare_bool_option
- { Goptions.optname = "strict redex matching";
- Goptions.optkey = ["Match"; "Strict"];
- Goptions.optread = (fun () -> !ssr_strict_match);
- Goptions.optdepr = true; (* noop *)
- Goptions.optwrite = (fun b -> ssr_strict_match := b) }
-
(** Rewrite rules *)
type ssrwkind = RWred of ssrsimpl | RWdef | RWeq
@@ -228,7 +216,7 @@ let same_proj sigma t1 t2 =
let all_ok _ _ = true
let fake_pmatcher_end () =
- mkProp, L2R, (Evd.empty, Evd.empty_evar_universe_context, mkProp)
+ mkProp, L2R, (Evd.empty, UState.empty, mkProp)
let unfoldintac occ rdx t (kt,_) gl =
let fs sigma x = Reductionops.nf_evar sigma x in
@@ -384,8 +372,6 @@ let is_construct_ref sigma c r =
EConstr.isConstruct sigma c && eq_gr (ConstructRef (fst(EConstr.destConstruct sigma c))) r
let is_ind_ref sigma c r = EConstr.isInd sigma c && eq_gr (IndRef (fst(EConstr.destInd sigma c))) r
-let apply_type x xs = Proofview.V82.of_tactic (Tactics.apply_type ~typecheck:false x xs)
-
let rwcltac cl rdx dir sr gl =
let n, r_n,_, ucst = pf_abs_evars gl sr in
let r_n' = pf_abs_cterm gl n r_n in
diff --git a/plugins/ssr/ssrfun.v b/plugins/ssr/ssrfun.v
index 96b6ed295..ac2c78249 100644
--- a/plugins/ssr/ssrfun.v
+++ b/plugins/ssr/ssrfun.v
@@ -165,7 +165,7 @@ Require Import ssreflect.
(* rev_right_loop inv op <-> op, inv obey the inverse loop reverse right *)
(* axiom: (x op y) op (inv y) = x for all x, y. *)
(* Note that familiar "cancellation" identities like x + y - y = x or *)
-(* x - y + x = x are respectively instances of right_loop and rev_right_loop *)
+(* x - y + y = x are respectively instances of right_loop and rev_right_loop *)
(* The corresponding lemmas will use the K and NK/VK suffixes, respectively. *)
(* *)
(* - Morphisms for functions and relations: *)
@@ -639,6 +639,9 @@ End Injections.
Lemma Some_inj {T} : injective (@Some T). Proof. by move=> x y []. Qed.
+(* Force implicits to use as a view. *)
+Prenex Implicits Some_inj.
+
(* cancellation lemmas for dependent type casts. *)
Lemma esymK T x y : cancel (@esym T x y) (@esym T y x).
Proof. by case: y /. Qed.
diff --git a/plugins/ssr/ssripats.mli b/plugins/ssr/ssripats.mli
index b8716c0c4..89cba4be7 100644
--- a/plugins/ssr/ssripats.mli
+++ b/plugins/ssr/ssripats.mli
@@ -29,11 +29,11 @@ val tclIPATssr : ssripats -> unit Proofview.tactic
[tac E: gens => ipats]
where [E] is injected into [ipats] (at the right place) and [gens] are
generalized before calling [tac] *)
-val ssrmovetac : ssrmovearg -> unit Proofview.tactic
+val ssrmovetac : ssrdgens ssrmovearg -> unit Proofview.tactic
val ssrsmovetac : unit Proofview.tactic
-val ssrelimtac : ssrmovearg -> unit Proofview.tactic
+val ssrelimtac : ssrdgens ssrmovearg -> unit Proofview.tactic
val ssrselimtoptac : unit Proofview.tactic
-val ssrcasetac : ssrmovearg -> unit Proofview.tactic
+val ssrcasetac : ssrdgens ssrmovearg -> unit Proofview.tactic
val ssrscasetoptac : unit Proofview.tactic
(* The implementation of abstract: is half here, for the [[: var ]]
diff --git a/plugins/ssr/ssrparser.ml4 b/plugins/ssr/ssrparser.ml4
index 70f73c1fe..2bed8b624 100644
--- a/plugins/ssr/ssrparser.ml4
+++ b/plugins/ssr/ssrparser.ml4
@@ -952,7 +952,7 @@ let pr_ssrhint _ _ = pr_hint
ARGUMENT EXTEND ssrhint TYPED AS ssrhintarg PRINTED BY pr_ssrhint
| [ ] -> [ nohint ]
END
-(** The "in" pseudo-tactical {{{ **********************************************)
+(** The "in" pseudo-tactical *)(* {{{ **********************************************)
(* We can't make "in" into a general tactical because this would create a *)
(* crippling conflict with the ltac let .. in construct. Hence, we add *)
@@ -1438,7 +1438,7 @@ let tactic_expr = Pltac.tactic_expr
let old_tac = V82.tactic
-(** Name generation {{{ *******************************************************)
+(** Name generation *)(* {{{ *******************************************************)
(* Since Coq now does repeated internal checks of its external lexical *)
(* rules, we now need to carve ssreflect reserved identifiers out of *)
@@ -1490,7 +1490,7 @@ let _ = add_internal_name (is_tagged perm_tag)
(* We must not anonymize context names discharged by the "in" tactical. *)
-(** Tactical extensions. {{{ **************************************************)
+(** Tactical extensions. *)(* {{{ **************************************************)
(* The TACTIC EXTEND facility can't be used for defining new user *)
(* tacticals, because: *)
diff --git a/plugins/ssr/ssrparser.mli b/plugins/ssr/ssrparser.mli
index a52248614..130550388 100644
--- a/plugins/ssr/ssrparser.mli
+++ b/plugins/ssr/ssrparser.mli
@@ -20,3 +20,16 @@ val pr_ssrtclarg : 'a -> 'b -> (Notation_term.tolerability -> 'c -> 'd) -> 'c ->
val add_genarg : string -> ('a -> Pp.t) -> 'a Genarg.uniform_genarg_type
+(* Parsing witnesses, needed to serialize ssreflect syntax *)
+open Ssrmatching_plugin
+open Ssrmatching
+open Ssrast
+open Ssrequality
+
+val wit_ssrrwargs : ssrrwarg list Genarg.uniform_genarg_type
+val wit_ssrclauses : clauses Genarg.uniform_genarg_type
+val wit_ssrcasearg : (cpattern ssragens) ssrmovearg Genarg.uniform_genarg_type
+val wit_ssrmovearg : (cpattern ssragens) ssrmovearg Genarg.uniform_genarg_type
+val wit_ssrapplyarg : ssrapplyarg Genarg.uniform_genarg_type
+val wit_ssrhavefwdwbinders :
+ (Tacexpr.raw_tactic_expr fwdbinders, Tacexpr.glob_tactic_expr fwdbinders, Tacinterp.Value.t fwdbinders) Genarg.genarg_type
diff --git a/plugins/ssr/ssrtacticals.ml b/plugins/ssr/ssrtacticals.ml
index 21ad6e6ce..9cc4f5cec 100644
--- a/plugins/ssr/ssrtacticals.ml
+++ b/plugins/ssr/ssrtacticals.ml
@@ -59,7 +59,7 @@ let tclSEQAT ist atac1 dir (ivar, ((_, atacs2), atac3)) =
| L2R, pad, tacs2 -> Tacticals.tclTHENSFIRSTn tac1 (Array.of_list (pad @ tacs2)) tac3
| R2L, pad, tacs2 -> Tacticals.tclTHENSLASTn tac1 tac3 (Array.of_list (tacs2 @ pad))
-(** The "in" pseudo-tactical {{{ **********************************************)
+(** The "in" pseudo-tactical *)(* {{{ **********************************************)
let hidden_goal_tag = "the_hidden_goal"
@@ -127,8 +127,6 @@ let endclausestac id_map clseq gl_id cl0 gl =
if List.for_all not_hyp' all_ids && not c_hidden then mktac [] gl else
errorstrm Pp.(str "tampering with discharged assumptions of \"in\" tactical")
-let apply_type x xs = Proofview.V82.of_tactic (Tactics.apply_type ~typecheck:false x xs)
-
let tclCLAUSES tac (gens, clseq) gl =
if clseq = InGoal || clseq = InSeqGoal then tac gl else
let clr_gens = pf_clauseids gl gens clseq in
diff --git a/plugins/ssr/ssrvernac.ml4 b/plugins/ssr/ssrvernac.ml4
index f37452613..e3941c1c5 100644
--- a/plugins/ssr/ssrvernac.ml4
+++ b/plugins/ssr/ssrvernac.ml4
@@ -49,7 +49,7 @@ let frozen_lexer = CLexer.get_keyword_state () ;;
(* global syntactic changes and vernacular commands *)
-(** Alternative notations for "match" and anonymous arguments. {{{ ************)
+(** Alternative notations for "match" and anonymous arguments. *)(* {{{ ************)
(* Syntax: *)
(* if <term> is <pattern> then ... else ... *)
@@ -127,7 +127,7 @@ GEXTEND Gram
END
(* }}} *)
-(** Vernacular commands: Prenex Implicits and Search {{{ **********************)
+(** Vernacular commands: Prenex Implicits and Search *)(* {{{ **********************)
(* This should really be implemented as an extension to the implicit *)
(* arguments feature, but unfortuately that API is sealed. The current *)
@@ -461,7 +461,7 @@ END
(* }}} *)
-(** View hint database and View application. {{{ ******************************)
+(** View hint database and View application. *)(* {{{ ******************************)
(* There are three databases of lemmas used to mediate the application *)
(* of reflection lemmas: one for forward chaining, one for backward *)
diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4
index 1f1a63dac..33b18001c 100644
--- a/plugins/ssrmatching/ssrmatching.ml4
+++ b/plugins/ssrmatching/ssrmatching.ml4
@@ -70,7 +70,7 @@ let _ =
Goptions.optwrite = debug }
let pp s = !pp_ref s
-(** Utils {{{ *****************************************************************)
+(** Utils *)(* {{{ *****************************************************************)
let env_size env = List.length (Environ.named_context env)
let safeDestApp c =
match kind c with App (f, a) -> f, a | _ -> c, [| |]
@@ -179,7 +179,7 @@ let nf_evar sigma c =
(* }}} *)
-(** Profiling {{{ *************************************************************)
+(** Profiling *)(* {{{ *************************************************************)
type profiler = {
profile : 'a 'b. ('a -> 'b) -> 'a -> 'b;
reset : unit -> unit;
@@ -361,7 +361,7 @@ let unif_end env sigma0 ise0 pt ok =
if ise2 == ise1 then (s, uc, t)
else
let s, uc', t = nf_open_term sigma0 ise2 t in
- s, Evd.union_evar_universe_context uc uc', t
+ s, UState.union uc uc', t
let unify_HO env sigma0 t1 t2 =
let sigma = unif_HO env sigma0 t1 t2 in
@@ -1268,7 +1268,7 @@ let eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst =
let sigma,pat= mk_tpattern ?hack env sigma0 (sigma,p) ok L2R (fs sigma t) in
sigma, [pat] in
match pattern with
- | None -> do_subst env0 concl0 concl0 1, Evd.empty_evar_universe_context
+ | None -> do_subst env0 concl0 concl0 1, UState.empty
| Some (sigma, (T rp | In_T rp)) ->
let rp = fs sigma rp in
let ise = create_evar_defs sigma in
diff --git a/plugins/ssrmatching/ssrmatching.mli b/plugins/ssrmatching/ssrmatching.mli
index cd5676f28..07d0f9757 100644
--- a/plugins/ssrmatching/ssrmatching.mli
+++ b/plugins/ssrmatching/ssrmatching.mli
@@ -74,7 +74,7 @@ val interp_cpattern :
pattern
(** The set of occurrences to be matched. The boolean is set to true
- * to signal the complement of this set (i.e. {-1 3}) *)
+ * to signal the complement of this set (i.e. \{-1 3\}) *)
type occ = (bool * int list) option
(** [subst e p t i]. [i] is the number of binders
diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml
index 0a63985bf..fe2e86a48 100644
--- a/pretyping/evarconv.ml
+++ b/pretyping/evarconv.ml
@@ -530,8 +530,15 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
UnifFailure (evd, NotSameHead)
else
begin
- let evd' = check_leq_inductives evd cumi u u' in
- Success (check_leq_inductives evd' cumi u' u)
+ (** Both constructors should be liftable to the same supertype
+ at which we compare them, but we don't have access to that type in
+ untyped unification. We hence try to enforce that one is lower
+ than the other, also unifying more universes in the process.
+ If this fails we just leave the universes as is, as in conversion. *)
+ try Success (check_leq_inductives evd cumi u u')
+ with Univ.UniverseInconsistency _ ->
+ try Success (check_leq_inductives evd cumi u' u)
+ with Univ.UniverseInconsistency e -> Success evd
end
end
in
diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli
index 16d75685d..3b56513f5 100644
--- a/pretyping/reductionops.mli
+++ b/pretyping/reductionops.mli
@@ -278,7 +278,7 @@ val check_conv : ?pb:conv_pb -> ?ts:transparent_state -> env -> evar_map -> con
(** [infer_conv] Adds necessary universe constraints to the evar map.
pb defaults to CUMUL and ts to a full transparent state.
- @raises UniverseInconsistency iff catch_incon is set to false,
+ @raise UniverseInconsistency iff catch_incon is set to false,
otherwise returns false in that case.
*)
val infer_conv : ?catch_incon:bool -> ?pb:conv_pb -> ?ts:transparent_state ->
diff --git a/pretyping/unification.ml b/pretyping/unification.ml
index 5bc93f1fa..f4269a2c5 100644
--- a/pretyping/unification.ml
+++ b/pretyping/unification.ml
@@ -250,20 +250,6 @@ let unify_r2l x = x
let sort_eqns = unify_r2l
*)
-let global_pattern_unification_flag = ref true
-
-open Goptions
-
-(* Compatibility option introduced and activated in Coq 8.4 *)
-
-let _ =
- declare_bool_option
- { optdepr = true; (* remove in 8.8 *)
- optname = "pattern-unification for existential variables in tactics";
- optkey = ["Tactic";"Pattern";"Unification"];
- optread = (fun () -> !global_pattern_unification_flag);
- optwrite = (:=) global_pattern_unification_flag }
-
type core_unify_flags = {
modulo_conv_on_closed_terms : Names.transparent_state option;
(* What this flag controls was activated with all constants transparent, *)
@@ -287,12 +273,10 @@ type core_unify_flags = {
use_pattern_unification : bool;
(* This solves pattern "?n x1 ... xn = t" when the xi are distinct rels *)
- (* This says if pattern unification is tried; can be overwritten with *)
- (* option "Set Tactic Pattern Unification" *)
+ (* This says if pattern unification is tried *)
use_meta_bound_pattern_unification : bool;
- (* This is implied by use_pattern_unification (though deactivated *)
- (* by unsetting Tactic Pattern Unification); has no particular *)
+ (* This is implied by use_pattern_unification; has no particular *)
(* reasons to be set differently than use_pattern_unification *)
(* except for compatibility of "auto". *)
(* This was on for all tactics, including auto, since Sep 2006 for 8.1 *)
@@ -473,10 +457,10 @@ let set_flags_for_type flags = { flags with
}
let use_evars_pattern_unification flags =
- !global_pattern_unification_flag && flags.use_pattern_unification
+ flags.use_pattern_unification
let use_metas_pattern_unification sigma flags nb l =
- !global_pattern_unification_flag && flags.use_pattern_unification
+ flags.use_pattern_unification
|| flags.use_meta_bound_pattern_unification &&
Array.for_all (fun c -> isRel sigma c && destRel sigma c <= nb) l
diff --git a/pretyping/univdecls.ml b/pretyping/univdecls.ml
index d16f046fa..8864be576 100644
--- a/pretyping/univdecls.ml
+++ b/pretyping/univdecls.ml
@@ -38,7 +38,7 @@ let interp_univ_constraints env evd cstrs =
let interp_univ_decl env decl =
let open Misctypes in
let pl : lident list = decl.univdecl_instance in
- let evd = Evd.from_ctx (Evd.make_evar_universe_context env (Some pl)) in
+ let evd = Evd.from_ctx (UState.make_with_initial_binders (Environ.universes env) pl) in
let evd, cstrs = interp_univ_constraints env evd decl.univdecl_constraints in
let decl = { univdecl_instance = pl;
univdecl_extensible_instance = decl.univdecl_extensible_instance;
diff --git a/pretyping/univdecls.mli b/pretyping/univdecls.mli
index 242eb802f..305d045b1 100644
--- a/pretyping/univdecls.mli
+++ b/pretyping/univdecls.mli
@@ -14,8 +14,8 @@ type universe_decl =
val default_univ_decl : universe_decl
-val interp_univ_decl : Environ.env -> Vernacexpr.universe_decl_expr ->
+val interp_univ_decl : Environ.env -> Constrexpr.universe_decl_expr ->
Evd.evar_map * universe_decl
-val interp_univ_decl_opt : Environ.env -> Vernacexpr.universe_decl_expr option ->
+val interp_univ_decl_opt : Environ.env -> Constrexpr.universe_decl_expr option ->
Evd.evar_map * universe_decl
diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml
index 8551d040d..2b7d643d6 100644
--- a/printing/ppvernac.ml
+++ b/printing/ppvernac.ml
@@ -233,9 +233,9 @@ open Decl_kinds
hov 2 (keyword "Hint "++ pph ++ opth)
let pr_with_declaration pr_c = function
- | CWith_Definition (id,c) ->
+ | CWith_Definition (id,udecl,c) ->
let p = pr_c c in
- keyword "Definition" ++ spc() ++ pr_lfqid id ++ str" := " ++ p
+ keyword "Definition" ++ spc() ++ pr_lfqid id ++ pr_universe_decl udecl ++ str" := " ++ p
| CWith_Module (id,qid) ->
keyword "Module" ++ spc() ++ pr_lfqid id ++ str" := " ++
pr_located pr_qualid qid
diff --git a/printing/prettyp.ml b/printing/prettyp.ml
index 3682b7c25..9da94e42a 100644
--- a/printing/prettyp.ml
+++ b/printing/prettyp.ml
@@ -94,7 +94,7 @@ let print_ref reduce ref udecl =
let env = Global.env () in
let bl = Universes.universe_binders_with_opt_names ref
(Array.to_list (Univ.Instance.to_array inst)) udecl in
- let sigma = Evd.from_ctx (Evd.evar_universe_context_of_binders bl) 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
else mt ()
@@ -593,7 +593,7 @@ let print_constant with_values sep sp udecl =
Array.to_list (Instance.to_array inst)
in
let ctx =
- Evd.evar_universe_context_of_binders
+ UState.of_binders
(Universes.universe_binders_with_opt_names (ConstRef sp) ulist udecl)
in
let env = Global.env () and sigma = Evd.from_ctx ctx in
diff --git a/printing/printer.ml b/printing/printer.ml
index 917ee2021..e50d302b3 100644
--- a/printing/printer.ml
+++ b/printing/printer.ml
@@ -539,7 +539,7 @@ let pr_evgl_sign sigma evi =
let ids = List.rev_map NamedDecl.get_id l in
let warn =
if List.is_empty ids then mt () else
- (str "(" ++ prlist_with_sep pr_comma pr_id ids ++ str " cannot be used)")
+ (str " (" ++ prlist_with_sep pr_comma pr_id ids ++ str " cannot be used)")
in
let pc = pr_lconstr_env env sigma evi.evar_concl in
let candidates =
@@ -551,7 +551,7 @@ let pr_evgl_sign sigma evi =
mt ()
in
hov 0 (str"[" ++ ps ++ spc () ++ str"|- " ++ pc ++ str"]" ++
- candidates ++ spc () ++ warn)
+ candidates ++ warn)
(* Print an existential variable *)
@@ -560,15 +560,25 @@ let pr_evar sigma (evk, evi) =
hov 0 (pr_existential_key sigma evk ++ str " : " ++ pegl)
(* Print an enumerated list of existential variables *)
-let rec pr_evars_int_hd head sigma i = function
+let rec pr_evars_int_hd pr sigma i = function
| [] -> mt ()
| (evk,evi)::rest ->
- (hov 0 (head i ++ pr_evar sigma (evk,evi))) ++
- (match rest with [] -> mt () | _ -> fnl () ++ pr_evars_int_hd head sigma (i+1) rest)
-
-let pr_evars_int sigma i evs = pr_evars_int_hd (fun i -> str "Existential " ++ int i ++ str " =" ++ spc ()) sigma i (Evar.Map.bindings evs)
-
-let pr_evars sigma evs = pr_evars_int_hd (fun i -> mt ()) sigma 1 (Evar.Map.bindings evs)
+ (hov 0 (pr i evk evi)) ++
+ (match rest with [] -> mt () | _ -> fnl () ++ pr_evars_int_hd pr sigma (i+1) rest)
+
+let pr_evars_int sigma ~shelf ~givenup i evs =
+ let pr_status i =
+ if List.mem i shelf then str " (shelved)"
+ else if List.mem i givenup then str " (given up)"
+ else mt () in
+ pr_evars_int_hd
+ (fun i evk evi ->
+ str "Existential " ++ int i ++ str " =" ++
+ spc () ++ pr_evar sigma (evk,evi) ++ pr_status evk)
+ sigma i (Evar.Map.bindings evs)
+
+let pr_evars sigma evs =
+ pr_evars_int_hd (fun i evk evi -> pr_evar sigma (evk,evi)) sigma 1 (Evar.Map.bindings evs)
(* Display a list of evars given by their name, with a prefix *)
let pr_ne_evar_set hd tl sigma l =
@@ -686,7 +696,7 @@ let print_dependent_evars gl sigma seeds =
(* spiwack: [pr_first] is true when the first goal must be singled out
and printed in its entirety. *)
let default_pr_subgoals ?(pr_first=true)
- close_cmd sigma seeds shelf stack unfocused goals =
+ close_cmd sigma ~seeds ~shelf ~stack ~unfocused ~goals =
(** Printing functions for the extra informations. *)
let rec print_stack a = function
| [] -> Pp.int a
@@ -748,7 +758,7 @@ let default_pr_subgoals ?(pr_first=true)
if Evar.Map.is_empty exl then
(str"No more subgoals." ++ print_dependent_evars None sigma seeds)
else
- let pei = pr_evars_int sigma 1 exl in
+ let pei = pr_evars_int sigma ~shelf ~givenup:[] 1 exl in
v 0 ((str "No more subgoals,"
++ str " but there are non-instantiated existential variables:"
++ cut () ++ (hov 0 pei)
@@ -775,7 +785,7 @@ let default_pr_subgoals ?(pr_first=true)
type printer_pr = {
- pr_subgoals : ?pr_first:bool -> Pp.t option -> evar_map -> Evar.t list -> Goal.goal list -> int list -> goal list -> goal list -> Pp.t;
+ 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;
pr_subgoal : int -> evar_map -> goal list -> Pp.t;
pr_goal : goal sigma -> Pp.t;
}
@@ -809,16 +819,16 @@ let pr_open_subgoals ~proof =
begin match goals with
| [] -> let { Evd.it = bgoals ; sigma = bsigma } = Proof.V82.background_subgoals p in
begin match bgoals,shelf,given_up with
- | [] , [] , [] -> pr_subgoals None sigma seeds shelf stack [] goals
+ | [] , [] , [] -> pr_subgoals None sigma ~seeds ~shelf ~stack ~unfocused:[] ~goals
| [] , [] , _ ->
Feedback.msg_info (str "No more subgoals, but there are some goals you gave up:");
fnl ()
- ++ pr_subgoals ~pr_first:false None bsigma seeds [] [] [] given_up
+ ++ pr_subgoals ~pr_first:false None bsigma ~seeds ~shelf:[] ~stack:[] ~unfocused:[] ~goals:given_up
++ fnl () ++ str "You need to go back and solve them."
| [] , _ , _ ->
Feedback.msg_info (str "All the remaining goals are on the shelf.");
fnl ()
- ++ pr_subgoals ~pr_first:false None bsigma seeds [] [] [] shelf
+ ++ 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." ++
@@ -826,13 +836,13 @@ let pr_open_subgoals ~proof =
if Pp.ismt s then s else fnl () ++ s) ++
fnl ()
in
- pr_subgoals ~pr_first:false (Some end_cmd) bsigma seeds shelf [] [] bgoals
+ pr_subgoals ~pr_first:false (Some end_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 [] unfocused_if_needed bgoals_focused
+ pr_subgoals ~pr_first:true None bsigma ~seeds ~shelf ~stack:[] ~unfocused:unfocused_if_needed ~goals:bgoals_focused
end
let pr_nth_open_subgoal ~proof n =
diff --git a/printing/printer.mli b/printing/printer.mli
index e32cb0921..41843680b 100644
--- a/printing/printer.mli
+++ b/printing/printer.mli
@@ -183,8 +183,7 @@ val pr_goal : goal sigma -> Pp.t
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 -> Evar.t list -> Goal.goal list -> int list
- -> goal list -> goal list -> Pp.t
+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_subgoal : int -> evar_map -> goal list -> Pp.t
val pr_concl : int -> evar_map -> goal -> Pp.t
@@ -192,7 +191,7 @@ val pr_concl : int -> evar_map -> goal -> 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
-val pr_evars_int : evar_map -> int -> evar_info Evar.Map.t -> Pp.t
+val pr_evars_int : evar_map -> shelf:goal list -> givenup:goal list -> int -> evar_info Evar.Map.t -> Pp.t
val pr_evars : evar_map -> evar_info Evar.Map.t -> Pp.t
val pr_ne_evar_set : Pp.t -> Pp.t -> evar_map ->
Evar.Set.t -> Pp.t
@@ -225,7 +224,8 @@ val pr_assumptionset : env -> evar_map -> types ContextObjectMap.t -> Pp.t
val pr_goal_by_id : proof:Proof.t -> Id.t -> Pp.t
type printer_pr = {
- pr_subgoals : ?pr_first:bool -> Pp.t option -> evar_map -> Evar.t list -> Goal.goal list -> int list -> goal list -> goal list -> Pp.t;
+ 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;
+
pr_subgoal : int -> evar_map -> goal list -> Pp.t;
pr_goal : goal sigma -> Pp.t;
}
diff --git a/printing/printmod.ml b/printing/printmod.ml
index 43796ec61..e076c10f3 100644
--- a/printing/printmod.ml
+++ b/printing/printmod.ml
@@ -141,7 +141,7 @@ let print_mutual_inductive env mind mib udecl =
else []
in
let bl = Universes.universe_binders_with_opt_names (IndRef (mind, 0)) univs udecl in
- let sigma = Evd.from_ctx (Evd.evar_universe_context_of_binders bl) in
+ let sigma = Evd.from_ctx (UState.of_binders bl) in
hov 0 (Printer.pr_polymorphic (Declareops.inductive_is_polymorphic mib) ++
Printer.pr_cumulative
(Declareops.inductive_is_polymorphic mib)
@@ -185,7 +185,7 @@ let print_record env mind mib udecl =
let envpar = push_rel_context params env in
let bl = Universes.universe_binders_with_opt_names (IndRef (mind,0))
(Array.to_list (Univ.Instance.to_array u)) udecl in
- let sigma = Evd.from_ctx (Evd.evar_universe_context_of_binders bl) in
+ let sigma = Evd.from_ctx (UState.of_binders bl) in
let keyword =
let open Declarations in
match mib.mind_finite with
diff --git a/proofs/goal.ml b/proofs/goal.ml
index ed0d76f93..ba7e458f3 100644
--- a/proofs/goal.ml
+++ b/proofs/goal.ml
@@ -62,8 +62,7 @@ module V82 = struct
goals are restored to their initial value after the evar is
created. *)
let concl = EConstr.Unsafe.to_constr concl in
- let prev_future_goals = Evd.future_goals evars in
- let prev_principal_goal = Evd.principal_future_goal evars in
+ let prev_future_goals = Evd.save_future_goals evars in
let evi = { Evd.evar_hyps = hyps;
Evd.evar_concl = concl;
Evd.evar_filter = Evd.Filter.identity;
@@ -74,7 +73,7 @@ module V82 = struct
in
let evi = Typeclasses.mark_unresolvable evi in
let (evars, evk) = Evarutil.new_pure_evar_full evars evi in
- let evars = Evd.restore_future_goals evars prev_future_goals prev_principal_goal in
+ let evars = Evd.restore_future_goals evars prev_future_goals in
let ctxt = Environ.named_context_of_val hyps in
let inst = Array.map_of_list (NamedDecl.get_id %> EConstr.mkVar) ctxt in
let ev = EConstr.mkEvar (evk,inst) in
diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml
index 03babfede..8725f51cd 100644
--- a/proofs/pfedit.ml
+++ b/proofs/pfedit.ml
@@ -170,6 +170,8 @@ let refine_by_tactic env sigma ty tac =
ones created during the tactic invocation easily. *)
let eff = Evd.eval_side_effects sigma in
let sigma = Evd.drop_side_effects sigma in
+ (** Save the existing goals *)
+ let prev_future_goals = save_future_goals sigma in
(** Start a proof *)
let prf = Proof.start sigma [env, ty] in
let (prf, _) =
@@ -180,7 +182,8 @@ let refine_by_tactic env sigma ty tac =
iraise (e, info)
in
(** Plug back the retrieved sigma *)
- let sigma = Proof.in_proof prf (fun sigma -> sigma) in
+ let (goals,stack,shelf,given_up,sigma) = Proof.proof prf in
+ assert (stack = []);
let ans = match Proof.initial_goals prf with
| [c, _] -> c
| _ -> assert false
@@ -192,6 +195,17 @@ let refine_by_tactic env sigma ty tac =
(** Reset the old side-effects *)
let sigma = Evd.drop_side_effects sigma in
let sigma = Evd.emit_side_effects eff sigma in
+ (** Restore former goals *)
+ let sigma = restore_future_goals sigma prev_future_goals in
+ (** Push remaining goals as future_goals which is the only way we
+ have to inform the caller that there are goals to collect while
+ not being encapsulated in the monad *)
+ (** Goals produced by tactic "shelve" *)
+ let sigma = List.fold_right (Evd.declare_future_goal ~tag:Evd.ToShelve) shelf sigma in
+ (** Goals produced by tactic "give_up" *)
+ let sigma = List.fold_right (Evd.declare_future_goal ~tag:Evd.ToGiveUp) given_up sigma in
+ (** Other goals *)
+ let sigma = List.fold_right Evd.declare_future_goal goals sigma in
(** Get rid of the fresh side-effects by internalizing them in the term
itself. Note that this is unsound, because the tactic may have solved
other goals that were already present during its invocation, so that
diff --git a/proofs/proof.ml b/proofs/proof.ml
index 24f570f01..51e0a1d61 100644
--- a/proofs/proof.ml
+++ b/proofs/proof.ml
@@ -347,7 +347,11 @@ let run_tactic env tac pr =
Proofview.tclEVARMAP >>= fun sigma ->
(* Already solved goals are not to be counted as shelved. Nor are
they to be marked as unresolvable. *)
- let retrieved = undef sigma (List.rev (Evd.future_goals sigma)) in
+ let retrieved = Evd.filter_future_goals (Evd.is_undefined sigma) (Evd.save_future_goals sigma) in
+ let retrieved,retrieved_given_up = Evd.extract_given_up_future_goals retrieved in
+ (* Check that retrieved given up is empty *)
+ if not (List.is_empty retrieved_given_up) then
+ CErrors.anomaly Pp.(str "Evars generated outside of proof engine (e.g. V82, clear, ...) are not supposed to be explicitly given up.");
let sigma = List.fold_left Proofview.Unsafe.mark_as_goal sigma retrieved in
Proofview.Unsafe.tclEVARS sigma >>= fun () ->
Proofview.tclUNIT retrieved
diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml
index d713b0999..15f34ccc6 100644
--- a/proofs/proof_global.ml
+++ b/proofs/proof_global.ml
@@ -169,6 +169,7 @@ let with_current_proof f =
let p = { p with proof = newpr } in
pstates := p :: rest;
ret
+
let simple_with_current_proof f = with_current_proof (fun t p -> f t p , ())
let compact_the_proof () = simple_with_current_proof (fun _ -> Proof.compact)
@@ -341,7 +342,7 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now
let subst_evar k =
Proof.in_proof proof (fun m -> Evd.existential_opt_value m k) in
let nf = Universes.nf_evars_and_universes_opt_subst subst_evar
- (Evd.evar_universe_context_subst universes) in
+ (UState.subst universes) in
let make_body =
if poly || now then
let make_body t (c, eff) =
@@ -436,7 +437,7 @@ let return_proof ?(allow_partial=false) () =
| Proof.HasUnresolvedEvar->
error(strbrk"Attempt to save a proof with existential variables still non-instantiated") in
let eff = Evd.eval_side_effects evd in
- let evd = Evd.nf_constraints evd in
+ let evd = Evd.minimize_universes evd in
(** ppedrot: FIXME, this is surely wrong. There is no reason to duplicate
side-effects... This may explain why one need to uniquize side-effects
thereafter... *)
diff --git a/proofs/refine.ml b/proofs/refine.ml
index 50fd1c472..909556b1e 100644
--- a/proofs/refine.ml
+++ b/proofs/refine.ml
@@ -78,22 +78,20 @@ let generic_refine ~typecheck f gl =
let state = Proofview.Goal.state gl in
(** Save the [future_goals] state to restore them after the
refinement. *)
- let prev_future_goals = Evd.future_goals sigma in
- let prev_principal_goal = Evd.principal_future_goal sigma in
+ let prev_future_goals = Evd.save_future_goals sigma in
(** Create the refinement term *)
Proofview.Unsafe.tclEVARS (Evd.reset_future_goals sigma) >>= fun () ->
f >>= fun (v, c) ->
Proofview.tclEVARMAP >>= fun sigma ->
Proofview.V82.wrap_exceptions begin fun () ->
- let evs = Evd.future_goals sigma in
- let evkmain = Evd.principal_future_goal sigma in
+ let evs = Evd.save_future_goals sigma in
(** Redo the effects in sigma in the monad's env *)
let privates_csts = Evd.eval_side_effects sigma in
let sideff = Safe_typing.side_effects_of_private_constants privates_csts in
let env = add_side_effects env sideff in
(** Check that the introduced evars are well-typed *)
let fold accu ev = typecheck_evar ev env accu in
- let sigma = if typecheck then CList.fold_left fold sigma evs else sigma in
+ let sigma = if typecheck then Evd.fold_future_goals fold sigma evs else sigma in
(** Check that the refined term is typesafe *)
let sigma = if typecheck then typecheck_proof c concl env sigma else sigma in
(** Check that the goal itself does not appear in the refined term *)
@@ -102,6 +100,11 @@ let generic_refine ~typecheck f gl =
if not (Evarutil.occur_evar_upto sigma self c) then ()
else Pretype_errors.error_occur_check env sigma self c
in
+ (** Restore the [future goals] state. *)
+ let sigma = Evd.restore_future_goals sigma prev_future_goals in
+ (** Select the goals *)
+ let evs = Evd.map_filter_future_goals (Proofview.Unsafe.advance sigma) evs in
+ let comb,shelf,given_up,evkmain = Evd.dispatch_future_goals evs in
(** Proceed to the refinement *)
let c = EConstr.Unsafe.to_constr c in
let sigma = match Proofview.Unsafe.advance sigma self with
@@ -118,10 +121,7 @@ let generic_refine ~typecheck f gl =
| None -> sigma
| Some id -> Evd.rename evk id sigma
in
- (** Restore the [future goals] state. *)
- let sigma = Evd.restore_future_goals sigma prev_future_goals prev_principal_goal in
- (** Select the goals *)
- let comb = CList.map_filter (Proofview.Unsafe.advance sigma) (CList.rev evs) in
+ (** Mark goals *)
let sigma = CList.fold_left Proofview.Unsafe.mark_as_goal sigma comb in
let comb = CList.map (fun x -> Proofview.goal_with_state x state) comb in
let trace () = Pp.(hov 2 (str"simple refine"++spc()++ Hook.get pr_constrv env sigma c)) in
@@ -129,6 +129,8 @@ let generic_refine ~typecheck f gl =
Proofview.Unsafe.tclSETENV (Environ.reset_context env) <*>
Proofview.Unsafe.tclEVARS sigma <*>
Proofview.Unsafe.tclSETGOALS comb <*>
+ Proofview.Unsafe.tclPUTSHELF shelf <*>
+ Proofview.Unsafe.tclPUTGIVENUP given_up <*>
Proofview.tclUNIT v
end
diff --git a/stm/stm.ml b/stm/stm.ml
index d878bbb30..b3da97c6e 100644
--- a/stm/stm.ml
+++ b/stm/stm.ml
@@ -2482,7 +2482,7 @@ let known_state ?(redefine_qed=false) ~cache id =
match keep with
| VtDrop -> None
| VtKeepAsAxiom ->
- let ctx = Evd.empty_evar_universe_context in
+ let ctx = UState.empty in
let fp = Future.from_val ([],ctx) in
qed.fproof <- Some (fp, ref false); None
| VtKeep ->
diff --git a/tactics/auto.ml b/tactics/auto.ml
index 3eea1a74f..0c0d9bcfc 100644
--- a/tactics/auto.ml
+++ b/tactics/auto.ml
@@ -42,9 +42,9 @@ let compute_secvars gl =
open Unification
-let auto_core_unif_flags_of st1 st2 useeager = {
+let auto_core_unif_flags_of st1 st2 = {
modulo_conv_on_closed_terms = Some st1;
- use_metas_eagerly_in_conv_on_closed_terms = useeager;
+ use_metas_eagerly_in_conv_on_closed_terms = false;
use_evars_eagerly_in_conv_on_closed_terms = false;
modulo_delta = st2;
modulo_delta_types = full_transparent_state;
@@ -57,8 +57,8 @@ let auto_core_unif_flags_of st1 st2 useeager = {
modulo_eta = true;
}
-let auto_unif_flags_of st1 st2 useeager =
- let flags = auto_core_unif_flags_of st1 st2 useeager in {
+let auto_unif_flags_of st1 st2 =
+ let flags = auto_core_unif_flags_of st1 st2 in {
core_unify_flags = flags;
merge_unify_flags = flags;
subterm_unify_flags = { flags with modulo_delta = empty_transparent_state };
@@ -67,7 +67,7 @@ let auto_unif_flags_of st1 st2 useeager =
}
let auto_unif_flags =
- auto_unif_flags_of full_transparent_state empty_transparent_state false
+ auto_unif_flags_of full_transparent_state empty_transparent_state
(* Try unification with the precompiled clause, then use registered Apply *)
@@ -291,10 +291,10 @@ let tclTRY_dbg d tac =
de Hint impérative a été remplacée par plusieurs bases fonctionnelles *)
let flags_of_state st =
- auto_unif_flags_of st st false
+ auto_unif_flags_of st st
let auto_flags_of_state st =
- auto_unif_flags_of full_transparent_state st false
+ auto_unif_flags_of full_transparent_state st
let hintmap_of sigma secvars hdc concl =
match hdc with
diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml
index 4c91f3f61..0260460e6 100644
--- a/tactics/class_tactics.ml
+++ b/tactics/class_tactics.ml
@@ -20,7 +20,6 @@ open Names
open Term
open Termops
open EConstr
-open Proof_type
open Tacmach
open Tactics
open Clenv
@@ -28,7 +27,6 @@ open Typeclasses
open Globnames
open Evd
open Locus
-open Misctypes
open Proofview.Notations
open Hints
@@ -41,10 +39,6 @@ module NamedDecl = Context.Named.Declaration
let typeclasses_debug = ref 0
let typeclasses_depth = ref None
-let typeclasses_modulo_eta = ref false
-let set_typeclasses_modulo_eta d = (:=) typeclasses_modulo_eta d
-let get_typeclasses_modulo_eta () = !typeclasses_modulo_eta
-
(** When this flag is enabled, the resolution of type classes tries to avoid
useless introductions. This is no longer useful since we have eta, but is
here for compatibility purposes. Another compatibility issues is that the
@@ -71,13 +65,6 @@ let set_typeclasses_filtered_unification d =
let get_typeclasses_filtered_unification () =
!typeclasses_filtered_unification
-(** [typeclasses_legacy_resolution] falls back to the 8.5 resolution algorithm,
- instead of the 8.6 one which uses the native backtracking facilities of the
- proof engine. *)
-let typeclasses_legacy_resolution = ref false
-let set_typeclasses_legacy_resolution d = (:=) typeclasses_legacy_resolution d
-let get_typeclasses_legacy_resolution () = !typeclasses_legacy_resolution
-
let set_typeclasses_debug d = (:=) typeclasses_debug (if d then 1 else 0)
let get_typeclasses_debug () = if !typeclasses_debug > 0 then true else false
@@ -94,14 +81,6 @@ open Goptions
let _ =
declare_bool_option
- { optdepr = true; (* remove in 8.8 *)
- optname = "do typeclass search modulo eta conversion";
- optkey = ["Typeclasses";"Modulo";"Eta"];
- optread = get_typeclasses_modulo_eta;
- optwrite = set_typeclasses_modulo_eta; }
-
-let _ =
- declare_bool_option
{ optdepr = false;
optname = "do typeclass search avoiding eta-expansions " ^
" in proof terms (expensive)";
@@ -127,14 +106,6 @@ let _ =
let _ =
declare_bool_option
- { optdepr = true; (* remove in 8.8 *)
- optname = "compat";
- optkey = ["Typeclasses";"Legacy";"Resolution"];
- optread = get_typeclasses_legacy_resolution;
- optwrite = set_typeclasses_legacy_resolution; }
-
-let _ =
- declare_bool_option
{ optdepr = false;
optname = "compat";
optkey = ["Typeclasses";"Filtered";"Unification"];
@@ -199,7 +170,7 @@ let auto_core_unif_flags st freeze = {
frozen_evars = freeze;
restrict_conv_on_strict_subterms = false; (* ? *)
modulo_betaiota = true;
- modulo_eta = !typeclasses_modulo_eta;
+ modulo_eta = false;
}
let auto_unif_flags freeze st =
@@ -426,9 +397,6 @@ and e_my_find_search db_list local_db secvars hdc complete only_classes env sigm
else
let tac =
with_prods nprods poly (term,cl) (unify_resolve poly flags) in
- if get_typeclasses_legacy_resolution () then
- Tacticals.New.tclTHEN tac Proofview.shelve_unifiable
- else
Proofview.tclBIND (Proofview.with_shelf tac)
(fun (gls, ()) -> shelve_dependencies gls)
| ERes_pf (term,cl) ->
@@ -441,9 +409,6 @@ and e_my_find_search db_list local_db secvars hdc complete only_classes env sigm
else
let tac =
with_prods nprods poly (term,cl) (unify_e_resolve poly flags) in
- if get_typeclasses_legacy_resolution () then
- Tacticals.New.tclTHEN tac Proofview.shelve_unifiable
- else
Proofview.tclBIND (Proofview.with_shelf tac)
(fun (gls, ()) -> shelve_dependencies gls)
| Give_exact (c,clenv) ->
@@ -618,359 +583,6 @@ let make_hints g st only_classes sign =
([]) sign
in Hint_db.add_list (pf_env g) (project g) hintlist (Hint_db.empty st true)
-(** <= 8.5 resolution *)
-module V85 = struct
-
- type autoinfo = { hints : hint_db; is_evar: existential_key option;
- only_classes: bool; unique : bool;
- auto_depth: int list; auto_last_tac: Pp.t Lazy.t;
- auto_path : global_reference option list;
- auto_cut : hints_path }
- type autogoal = goal * autoinfo
- type failure = NotApplicable | ReachedLimit
- type 'ans fk = failure -> 'ans
- type ('a,'ans) sk = 'a -> 'ans fk -> 'ans
- type 'a tac = { skft : 'ans. ('a,'ans) sk -> 'ans fk -> autogoal sigma -> 'ans }
-
- type auto_result = autogoal list sigma
-
- type atac = auto_result tac
-
- (* Some utility types to avoid the need of -rectypes *)
-
- type 'a optionk =
- | Nonek
- | Somek of 'a * 'a optionk fk
-
- type ('a,'b) optionk2 =
- | Nonek2 of failure
- | Somek2 of 'a * 'b * ('a,'b) optionk2 fk
-
- let pf_filtered_hyps gls =
- Goal.V82.hyps gls.Evd.sigma (sig_it gls)
-
- let make_autogoal_hints =
- let cache = Summary.ref ~name:"make_autogoal_hints_cache"
- (true, Environ.empty_named_context_val,
- Hint_db.empty full_transparent_state true)
- in
- fun only_classes ?(st=full_transparent_state) g ->
- let sign = pf_filtered_hyps g in
- let (onlyc, sign', cached_hints) = !cache in
- if onlyc == only_classes &&
- (sign == sign' || Environ.eq_named_context_val sign sign')
- && Hint_db.transparent_state cached_hints == st
- then
- cached_hints
- else
- let hints = make_hints g st only_classes (EConstr.named_context_of_val sign)
- in
- cache := (only_classes, sign, hints); hints
-
- let lift_tactic tac (f : goal list sigma -> autoinfo -> autogoal list sigma) : 'a tac =
- { skft = fun sk fk {it = gl,hints; sigma=s;} ->
- let res = try Some (tac {it=gl; sigma=s;})
- with e when catchable e -> None in
- match res with
- | Some gls -> sk (f gls hints) fk
- | None -> fk NotApplicable }
-
- let intro_tac : atac =
- let tac {it = gls; sigma = s} info =
- let gls' =
- List.map (fun g' ->
- let env = Goal.V82.env s g' in
- let context = EConstr.named_context_of_val (Goal.V82.hyps s g') in
- let hint = make_resolve_hyp env s (Hint_db.transparent_state info.hints)
- (true,false,false) info.only_classes empty_hint_info (List.hd context) in
- let ldb = Hint_db.add_list env s hint info.hints in
- (g', { info with is_evar = None; hints = ldb;
- auto_last_tac = lazy (str"intro") })) gls
- in {it = gls'; sigma = s;}
- in
- lift_tactic (Proofview.V82.of_tactic Tactics.intro) tac
-
- let normevars_tac : atac =
- { skft = fun sk fk {it = (gl, info); sigma = s;} ->
- let gl', sigma' = Goal.V82.nf_evar s gl in
- let info' = { info with auto_last_tac = lazy (str"normevars") } in
- sk {it = [gl', info']; sigma = sigma';} fk }
-
- let merge_failures x y =
- match x, y with
- | _, ReachedLimit
- | ReachedLimit, _ -> ReachedLimit
- | NotApplicable, NotApplicable -> NotApplicable
-
- let or_tac (x : 'a tac) (y : 'a tac) : 'a tac =
- { skft = fun sk fk gls -> x.skft sk
- (fun f -> y.skft sk (fun f' -> fk (merge_failures f f')) gls) gls }
-
- let or_else_tac (x : 'a tac) (y : failure -> 'a tac) : 'a tac =
- { skft = fun sk fk gls -> x.skft sk
- (fun f -> (y f).skft sk fk gls) gls }
-
- let needs_backtrack env evd oev concl =
- if Option.is_empty oev || is_Prop env evd concl then
- occur_existential evd concl
- else true
-
- let hints_tac hints sk fk {it = gl,info; sigma = s} =
- let env = Goal.V82.env s gl in
- let concl = Goal.V82.concl s gl in
- let tacgl = {it = gl; sigma = s;} in
- let secvars = secvars_of_hyps (Environ.named_context_of_val (Goal.V82.hyps s gl)) in
- let poss = e_possible_resolve hints info.hints secvars info.only_classes env s concl in
- let unique = is_unique env s concl in
- let rec aux i foundone = function
- | (tac, _, extern, name, pp) :: tl ->
- let derivs = path_derivate info.auto_cut name in
- let res =
- try
- if path_matches derivs [] then None
- else Some (Proofview.V82.of_tactic tac tacgl)
- with e when catchable e -> None
- in
- (match res with
- | None -> aux i foundone tl
- | Some {it = gls; sigma = s';} ->
- if !typeclasses_debug > 0 then
- Feedback.msg_debug
- (pr_depth (i :: info.auto_depth) ++ str": " ++ Lazy.force pp
- ++ str" on" ++ spc () ++ pr_ev s gl);
- let sgls =
- evars_to_goals
- (fun evm ev evi ->
- if Typeclasses.is_resolvable evi && not (Evd.is_undefined s ev) &&
- (not info.only_classes || Typeclasses.is_class_evar evm evi)
- then Typeclasses.mark_unresolvable evi, true
- else evi, false) s'
- in
- let newgls, s' =
- let gls' = List.map (fun g -> (None, g)) gls in
- match sgls with
- | None -> gls', s'
- | Some (evgls, s') ->
- if not !typeclasses_dependency_order then
- (gls' @ List.map (fun (ev,_) -> (Some ev, ev)) (Evar.Map.bindings evgls), s')
- else
- (* Reorder with dependent subgoals. *)
- let evm = List.fold_left
- (fun acc g -> Evar.Map.add g (Evd.find_undefined s' g) acc) evgls gls in
- let gls = top_sort s' evm in
- (List.map (fun ev -> Some ev, ev) gls, s')
- in
- let reindex g =
- let open Goal.V82 in
- extern && not (Environ.eq_named_context_val
- (hyps s' g) (hyps s' gl))
- in
- let gl' j (evar, g) =
- let hints' =
- if reindex g then
- make_autogoal_hints
- info.only_classes
- ~st:(Hint_db.transparent_state info.hints)
- {it = g; sigma = s';}
- else info.hints
- in
- { info with
- auto_depth = j :: i :: info.auto_depth;
- auto_last_tac = pp;
- is_evar = evar;
- hints = hints';
- auto_cut = derivs }
- in
- let gls' = List.map_i (fun i g -> snd g, gl' i g) 1 newgls in
- let glsv = {it = gls'; sigma = s';} in
- let fk' =
- (fun e ->
- let do_backtrack =
- if unique then occur_existential tacgl.sigma concl
- else if info.unique then true
- else if List.is_empty gls' then
- needs_backtrack env tacgl.sigma info.is_evar concl
- else true
- in
- let e' = match foundone with None -> e
- | Some e' -> merge_failures e e' in
- if !typeclasses_debug > 0 then
- Feedback.msg_debug
- ((if do_backtrack then str"Backtracking after "
- else str "Not backtracking after ")
- ++ Lazy.force pp);
- if do_backtrack then aux (succ i) (Some e') tl
- else fk e')
- in
- sk glsv fk')
- | [] ->
- if foundone == None && !typeclasses_debug > 0 then
- Feedback.msg_debug
- (pr_depth info.auto_depth ++ str": no match for " ++
- Printer.pr_econstr_env (Goal.V82.env s gl) s concl ++
- spc () ++ str ", " ++ int (List.length poss) ++
- str" possibilities");
- match foundone with
- | Some e -> fk e
- | None -> fk NotApplicable
- in aux 1 None poss
-
- let hints_tac hints =
- { skft = fun sk fk gls -> hints_tac hints sk fk gls }
-
- let then_list (second : atac) (sk : (auto_result, 'a) sk) : (auto_result, 'a) sk =
- let rec aux s (acc : autogoal list list) fk = function
- | (gl,info) :: gls ->
- Control.check_for_interrupt ();
- (match info.is_evar with
- | Some ev when Evd.is_defined s ev -> aux s acc fk gls
- | _ ->
- second.skft
- (fun {it=gls';sigma=s'} fk' ->
- let fk'' =
- if not info.unique && List.is_empty gls' &&
- not (needs_backtrack (Goal.V82.env s gl) s
- info.is_evar (Goal.V82.concl s gl))
- then fk
- else fk'
- in
- aux s' (gls'::acc) fk'' gls)
- fk {it = (gl,info); sigma = s; })
- | [] -> Somek2 (List.rev acc, s, fk)
- in fun {it = gls; sigma = s; } fk ->
- let rec aux' = function
- | Nonek2 e -> fk e
- | Somek2 (res, s', fk') ->
- let goals' = List.concat res in
- sk {it = goals'; sigma = s'; } (fun e -> aux' (fk' e))
- in aux' (aux s [] (fun e -> Nonek2 e) gls)
-
- let then_tac (first : atac) (second : atac) : atac =
- { skft = fun sk fk -> first.skft (then_list second sk) fk }
-
- let run_tac (t : 'a tac) (gl : autogoal sigma) : auto_result option =
- t.skft (fun x _ -> Some x) (fun _ -> None) gl
-
- type run_list_res = auto_result optionk
-
- let run_list_tac (t : 'a tac) p goals (gl : autogoal list sigma) : run_list_res =
- (then_list t (fun x fk -> Somek (x, fk)))
- gl
- (fun _ -> Nonek)
-
- let fail_tac reason : atac =
- { skft = fun sk fk _ -> fk reason }
-
- let rec fix (t : 'a tac) : 'a tac =
- then_tac t { skft = fun sk fk -> (fix t).skft sk fk }
-
- let rec fix_limit limit (t : 'a tac) : 'a tac =
- if Int.equal limit 0 then fail_tac ReachedLimit
- else then_tac t { skft = fun sk fk -> (fix_limit (pred limit) t).skft sk fk }
-
- let fix_iterative t =
- let rec aux depth =
- or_else_tac (fix_limit depth t)
- (function
- | NotApplicable as e -> fail_tac e
- | ReachedLimit -> aux (succ depth))
- in aux 1
-
- let fix_iterative_limit limit (t : 'a tac) : 'a tac =
- let rec aux depth =
- if Int.equal limit depth then fail_tac ReachedLimit
- else or_tac (fix_limit depth t)
- { skft = fun sk fk -> (aux (succ depth)).skft sk fk }
- in aux 1
-
- let make_autogoal ?(only_classes=true) ?(unique=false) ?(st=full_transparent_state)
- cut ev g =
- let hints = make_autogoal_hints only_classes ~st g in
- (g.it, { hints = hints ; is_evar = ev; unique = unique;
- only_classes = only_classes; auto_depth = [];
- auto_last_tac = lazy (str"none");
- auto_path = []; auto_cut = cut })
-
-
- let make_autogoals ?(only_classes=true) ?(unique=false)
- ?(st=full_transparent_state) hints gs evm' =
- let cut = cut_of_hints hints in
- let gl i g =
- let (gl, auto) = make_autogoal ~only_classes ~unique
- ~st cut (Some g) {it = g; sigma = evm'; } in
- (gl, { auto with auto_depth = [i]})
- in { it = List.map_i gl 1 gs; sigma = evm' }
-
- let get_result r =
- match r with
- | Nonek -> None
- | Somek (gls, fk) -> Some (gls.sigma,fk)
-
- let run_on_evars ?(only_classes=true) ?(unique=false) ?(st=full_transparent_state)
- p evm hints tac =
- match evars_to_goals p evm with
- | None -> None (* This happens only because there's no evar having p *)
- | Some (goals, evm') ->
- let goals =
- if !typeclasses_dependency_order then
- top_sort evm' goals
- else List.map (fun (ev, _) -> ev) (Evar.Map.bindings goals)
- in
- let res = run_list_tac tac p goals
- (make_autogoals ~only_classes ~unique ~st hints goals evm') in
- match get_result res with
- | None -> raise Not_found
- | Some (evm', fk) ->
- Some (evars_reset_evd ~with_conv_pbs:true ~with_univs:false evm' evm, fk)
-
- let eauto_tac hints =
- then_tac normevars_tac (or_tac (hints_tac hints) intro_tac)
-
- let eauto_tac strategy depth hints =
- match strategy with
- | Bfs ->
- begin match depth with
- | None -> fix_iterative (eauto_tac hints)
- | Some depth -> fix_iterative_limit depth (eauto_tac hints) end
- | Dfs ->
- match depth with
- | None -> fix (eauto_tac hints)
- | Some depth -> fix_limit depth (eauto_tac hints)
-
- let real_eauto ?depth strategy unique st hints p evd =
- let res =
- run_on_evars ~st ~unique p evd hints (eauto_tac strategy depth hints)
- in
- match res with
- | None -> evd
- | Some (evd', fk) ->
- if unique then
- (match get_result (fk NotApplicable) with
- | Some (evd'', fk') -> user_err Pp.(str "Typeclass resolution gives multiple solutions")
- | None -> evd')
- else evd'
-
- let resolve_all_evars_once debug depth unique p evd =
- let db = searchtable_map typeclasses_db in
- let strategy = if get_typeclasses_iterative_deepening () then Bfs else Dfs in
- real_eauto ?depth strategy unique (Hint_db.transparent_state db) [db] p evd
-
- let eauto85 ?(only_classes=true) ?st ?strategy depth hints g =
- let strategy =
- match strategy with
- | None -> if get_typeclasses_iterative_deepening () then Bfs else Dfs
- | Some s -> s
- in
- let gl = { it = make_autogoal ~only_classes ?st
- (cut_of_hints hints) None g; sigma = project g; } in
- match run_tac (eauto_tac strategy depth hints) gl with
- | None -> raise Not_found
- | Some {it = goals; sigma = s; } ->
- {it = List.map fst goals; sigma = s;}
-
-end
-
-(** 8.6 resolution *)
module Search = struct
type autoinfo =
{ search_depth : int list;
@@ -1354,14 +966,15 @@ module Search = struct
top_sort evm' goals
else List.map (fun (ev, _) -> ev) (Evar.Map.bindings goals)
in
- let fgoals = Evd.future_goals evm in
- let pgoal = Evd.principal_future_goal evm in
+ let fgoals = Evd.save_future_goals evm in
let _, pv = Proofview.init evm' [] in
let pv = Proofview.unshelve goals pv in
try
let (), pv', (unsafe, shelved, gaveup), _ =
Proofview.apply env tac pv
in
+ if not (List.is_empty gaveup) then
+ CErrors.anomaly (Pp.str "run_on_evars not assumed to apply tactics generating given up goals.");
if Proofview.finished pv' then
let evm' = Proofview.return pv' in
assert(Evd.fold_undefined (fun ev _ acc ->
@@ -1371,7 +984,8 @@ module Search = struct
(str "leaking evar " ++ int (Evar.repr ev) ++
spc () ++ pr_ev evm' ev);
acc && okev) evm' true);
- let evm' = Evd.restore_future_goals evm' (shelved @ fgoals) pgoal in
+ let fgoals = Evd.shelve_on_future_goals shelved fgoals in
+ let evm' = Evd.restore_future_goals evm' fgoals in
let evm' = evars_reset_evd ~with_conv_pbs:true ~with_univs:false evm' evm in
Some evm'
else raise Not_found
@@ -1406,13 +1020,7 @@ let typeclasses_eauto ?(only_classes=false) ?(st=full_transparent_state)
in
let st = match dbs with x :: _ -> Hint_db.transparent_state x | _ -> st in
let depth = match depth with None -> get_typeclasses_depth () | Some l -> Some l in
- if get_typeclasses_legacy_resolution () then
- Proofview.V82.tactic
- (fun gl ->
- try V85.eauto85 depth ~only_classes ~st ?strategy dbs gl
- with Not_found ->
- Refiner.tclFAIL 0 (str"Proof search failed") gl)
- else Search.eauto_tac ~st ~only_classes ?strategy ~depth ~dep:true dbs
+ Search.eauto_tac ~st ~only_classes ?strategy ~depth ~dep:true dbs
(** We compute dependencies via a union-find algorithm.
Beware of the imperative effects on the partition structure,
@@ -1531,12 +1139,7 @@ let resolve_all_evars debug depth unique env p oevd do_split fail =
| comp :: comps ->
let p = select_and_update_evars p oevd (in_comp comp) in
try
- let evd' =
- if get_typeclasses_legacy_resolution () then
- V85.resolve_all_evars_once debug depth unique p evd
- else
- Search.typeclasses_resolve env evd debug depth unique p
- in
+ let evd' = Search.typeclasses_resolve env evd debug depth unique p in
if has_undefined p oevd evd' then raise Unresolved;
docomp evd' comps
with Unresolved | Not_found ->
@@ -1581,9 +1184,6 @@ let resolve_one_typeclass env ?(sigma=Evd.empty) gl unique =
let st = Hint_db.transparent_state hints in
let depth = get_typeclasses_depth () in
let gls' =
- if get_typeclasses_legacy_resolution () then
- V85.eauto85 depth ~st [hints] gls
- else
try
Proofview.V82.of_tactic
(Search.eauto_tac ~st ~only_classes:true ~depth [hints] ~dep:true) gls
diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml
index 45926551b..477de6452 100644
--- a/tactics/eqschemes.ml
+++ b/tactics/eqschemes.ml
@@ -214,7 +214,7 @@ let build_sym_scheme env ind =
rel_vect (2*nrealargs+2) nrealargs])),
mkRel 1 (* varH *),
[|cstr (nrealargs+1)|]))))
- in c, Evd.evar_universe_context_of ctx
+ in c, UState.of_context_set ctx
let sym_scheme_kind =
declare_individual_scheme_object "_sym_internal"
@@ -285,7 +285,7 @@ let build_sym_involutive_scheme env ind =
mkRel 1|])),
mkRel 1 (* varH *),
[|mkApp(eqrefl,[|applied_ind_C;cstr (nrealargs+1)|])|]))))
- in (c, Evd.evar_universe_context_of ctx), eff
+ in (c, UState.of_context_set ctx), eff
let sym_involutive_scheme_kind =
declare_individual_scheme_object "_sym_involutive"
@@ -439,7 +439,7 @@ let build_l2r_rew_scheme dep env ind kind =
[|main_body|])
else
main_body))))))
- in (c, Evd.evar_universe_context_of ctx),
+ in (c, UState.of_context_set ctx),
Safe_typing.concat_private eff' eff
(**********************************************************************)
@@ -528,7 +528,7 @@ let build_l2r_forward_rew_scheme dep env ind kind =
(if dep then realsign_ind_P 1 applied_ind_P' else realsign_P 2) s)
(mkNamedLambda varHC applied_PC'
(mkVar varHC))|])))))
- in c, Evd.evar_universe_context_of ctx
+ in c, UState.of_context_set ctx
(**********************************************************************)
(* Build the right-to-left rewriting lemma for hypotheses associated *)
@@ -601,7 +601,7 @@ let build_r2l_forward_rew_scheme dep env ind kind =
lift (nrealargs+3) applied_PC,
mkRel 1)|]),
[|mkVar varHC|]))))))
- in c, Evd.evar_universe_context_of ctx
+ in c, UState.of_context_set ctx
(**********************************************************************)
(* This function "repairs" the non-dependent r2l forward rewriting *)
@@ -808,7 +808,7 @@ let build_congr env (eq,refl,ctx) ind =
[|mkApp (refl,
[|mkVar varB;
mkApp (mkVar varf, [|lift (mip.mind_nrealargs+3) b|])|])|]))))))
- in c, Evd.evar_universe_context_of ctx
+ in c, UState.of_context_set ctx
let congr_scheme_kind = declare_individual_scheme_object "_congr"
(fun _ ind ->
diff --git a/tactics/equality.ml b/tactics/equality.ml
index f15a64fc8..98f627f21 100644
--- a/tactics/equality.ml
+++ b/tactics/equality.ml
@@ -56,33 +56,12 @@ type inj_flags = {
injection_pattern_l2r_order : bool;
}
-let discriminate_introduction = ref true
-
-let discr_do_intro () = !discriminate_introduction
-
open Goptions
-let _ =
- declare_bool_option
- { optdepr = true; (* remove in 8.8 *)
- optname = "automatic introduction of hypotheses by discriminate";
- optkey = ["Discriminate";"Introduction"];
- optread = (fun () -> !discriminate_introduction);
- optwrite = (:=) discriminate_introduction }
-
-let injection_pattern_l2r_order = ref true
let use_injection_pattern_l2r_order = function
- | None -> !injection_pattern_l2r_order
+ | None -> true
| Some flags -> flags.injection_pattern_l2r_order
-let _ =
- declare_bool_option
- { optdepr = true; (* remove in 8.8 *)
- optname = "injection left-to-right pattern order and clear by default when with introduction pattern";
- optkey = ["Injection";"L2R";"Pattern";"Order"];
- optread = (fun () -> !injection_pattern_l2r_order) ;
- optwrite = (fun b -> injection_pattern_l2r_order := b) }
-
let injection_in_context = ref false
let use_injection_in_context = function
@@ -1090,13 +1069,10 @@ let discrClause with_evars = onClause (discrSimpleClause with_evars)
let discrEverywhere with_evars =
tclTHEN (Proofview.tclUNIT ())
(* Delay the interpretation of side-effect *)
- (if discr_do_intro () then
- (tclTHEN
- (tclREPEAT introf)
- (tryAllHyps
+ (tclTHEN
+ (tclREPEAT introf)
+ (tryAllHyps
(fun id -> tclCOMPLETE (discr with_evars (mkVar id,NoBindings)))))
- else (* <= 8.2 compat *)
- tryAllHypsAndConcl (discrSimpleClause with_evars))
let discr_tac with_evars = function
| None -> discrEverywhere with_evars
diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml
index a59046a67..b012a7ecd 100644
--- a/tactics/hipattern.ml
+++ b/tactics/hipattern.ml
@@ -511,10 +511,10 @@ let coq_eqdec ~sum ~rev =
mkPattern (mkGAppRef sum args)
)
-(** { ?X2 = ?X3 :> ?X1 } + { ~ ?X2 = ?X3 :> ?X1 } *)
+(** [{ ?X2 = ?X3 :> ?X1 } + { ~ ?X2 = ?X3 :> ?X1 }] *)
let coq_eqdec_inf_pattern = coq_eqdec ~sum:coq_sumbool_ref ~rev:false
-(** { ~ ?X2 = ?X3 :> ?X1 } + { ?X2 = ?X3 :> ?X1 } *)
+(** [{ ~ ?X2 = ?X3 :> ?X1 } + { ?X2 = ?X3 :> ?X1 }] *)
let coq_eqdec_inf_rev_pattern = coq_eqdec ~sum:coq_sumbool_ref ~rev:true
(** %coq_or_ref (?X2 = ?X3 :> ?X1) (~ ?X2 = ?X3 :> ?X1) *)
diff --git a/tactics/ind_tables.ml b/tactics/ind_tables.ml
index b960a845c..62ead57f3 100644
--- a/tactics/ind_tables.ml
+++ b/tactics/ind_tables.ml
@@ -122,8 +122,8 @@ let compute_name internal id =
let define internal id c p univs =
let fd = declare_constant ~internal in
let id = compute_name internal id in
- let ctx = Evd.normalize_evar_universe_context univs in
- let c = Universes.subst_opt_univs_constr (Evd.evar_universe_context_subst ctx) c in
+ let ctx = UState.minimize univs in
+ let c = Universes.subst_opt_univs_constr (UState.subst ctx) c in
let univs =
if p then Polymorphic_const_entry (UState.context ctx)
else Monomorphic_const_entry (UState.context_set ctx)
diff --git a/tactics/leminv.ml b/tactics/leminv.ml
index 655283c20..a4cdc1592 100644
--- a/tactics/leminv.ml
+++ b/tactics/leminv.ml
@@ -218,7 +218,7 @@ let inversion_scheme env sigma t sort dep_option inv_op =
end in
let avoid = ref Id.Set.empty in
let _,_,_,_,sigma = Proof.proof pf in
- let sigma = Evd.nf_constraints sigma in
+ let sigma = Evd.minimize_universes sigma in
let rec fill_holes c =
match EConstr.kind sigma c with
| Evar (e,args) ->
diff --git a/tactics/tactics.ml b/tactics/tactics.ml
index 20519dd98..12aef852d 100644
--- a/tactics/tactics.ml
+++ b/tactics/tactics.ml
@@ -15,7 +15,6 @@ open CErrors
open Util
open Names
open Nameops
-open Term
open Constr
open Termops
open Environ
@@ -61,16 +60,6 @@ let typ_of env sigma c =
open Goptions
-let apply_solve_class_goals = ref false
-
-let _ =
- declare_bool_option
- { optdepr = true; (* remove in 8.8 *)
- optname = "Perform typeclass resolution on apply-generated subgoals.";
- optkey = ["Typeclass";"Resolution";"After";"Apply"];
- optread = (fun () -> !apply_solve_class_goals);
- optwrite = (fun a -> apply_solve_class_goals := a); }
-
let clear_hyp_by_default = ref false
let use_clear_hyp_by_default () = !clear_hyp_by_default
@@ -99,18 +88,6 @@ let _ =
optread = (fun () -> !universal_lemma_under_conjunctions) ;
optwrite = (fun b -> universal_lemma_under_conjunctions := b) }
-(* Shrinking of abstract proofs. *)
-
-let shrink_abstract = ref true
-
-let _ =
- declare_bool_option
- { optdepr = true; (* remove in 8.8 *)
- optname = "shrinking of abstracted proofs";
- optkey = ["Shrink"; "Abstract"];
- optread = (fun () -> !shrink_abstract) ;
- optwrite = (fun b -> shrink_abstract := b) }
-
(* The following boolean governs what "intros []" do on examples such
as "forall x:nat*nat, x=x"; if true, it behaves as "intros [? ?]";
if false, it behaves as "intro H; case H; clear H" for fresh H.
@@ -410,12 +387,11 @@ let find_name mayrepl decl naming gl = match naming with
new_fresh_id idl (default_id env sigma decl) gl
| NamingBasedOn (id,idl) -> new_fresh_id idl id gl
| NamingMustBe (loc,id) ->
- (* When name is given, we allow to hide a global name *)
- let ids_of_hyps = Tacmach.New.pf_ids_set_of_hyps gl in
- let id' = next_ident_away id ids_of_hyps in
- if not mayrepl && not (Id.equal id' id) then
- user_err ?loc (Id.print id ++ str" is already used.");
- id
+ (* When name is given, we allow to hide a global name *)
+ let ids_of_hyps = Tacmach.New.pf_ids_set_of_hyps gl in
+ if not mayrepl && Id.Set.mem id ids_of_hyps then
+ user_err ?loc (Id.print id ++ str" is already used.");
+ id
(**************************************************************)
(* Computing position of hypotheses for replacing *)
@@ -1349,46 +1325,6 @@ let index_of_ind_arg sigma t =
| None -> error "Could not find inductive argument of elimination scheme."
in aux None 0 t
-let enforce_prop_bound_names rename tac =
- let open Context.Rel.Declaration in
- match rename with
- | Some (isrec,nn) when Namegen.use_h_based_elimination_names () ->
- (* Rename dependent arguments in Prop with name "H" *)
- (* so as to avoid having hypothesis such as "t:True", "n:~A" when calling *)
- (* elim or induction with schemes built by Indrec.build_induction_scheme *)
- let rec aux env sigma i t =
- if i = 0 then t else match EConstr.kind sigma t with
- | Prod (Name _ as na,t,t') ->
- let very_standard = true in
- let na =
- if Retyping.get_sort_family_of env sigma t = InProp then
- (* "very_standard" says that we should have "H" names only, but
- this would break compatibility even more... *)
- let s = match Namegen.head_name sigma t with
- | Some id when not very_standard -> Id.to_string id
- | _ -> "" in
- Name (add_suffix Namegen.default_prop_ident s)
- else
- na in
- mkProd (na,t,aux (push_rel (LocalAssum (na,t)) env) sigma (i-1) t')
- | Prod (Anonymous,t,t') ->
- mkProd (Anonymous,t,aux (push_rel (LocalAssum (Anonymous,t)) env) sigma (i-1) t')
- | LetIn (na,c,t,t') ->
- mkLetIn (na,c,t,aux (push_rel (LocalDef (na,c,t)) env) sigma (i-1) t')
- | _ -> assert false in
- let rename_branch i =
- Proofview.Goal.enter begin fun gl ->
- let env = Proofview.Goal.env gl in
- let sigma = Tacmach.New.project gl in
- let t = Proofview.Goal.concl gl in
- change_concl (aux env sigma i t)
- end in
- (if isrec then Tacticals.New.tclTHENFIRSTn else Tacticals.New.tclTHENLASTn)
- tac
- (Array.map rename_branch nn)
- | _ ->
- tac
-
let rec contract_letin_in_lam_header sigma c =
match EConstr.kind sigma c with
| Lambda (x,t,c) -> mkLambda (x,t,contract_letin_in_lam_header sigma c)
@@ -1409,7 +1345,7 @@ let elimination_clause_scheme with_evars ?(with_classes=true) ?(flags=elim_flags
(str "The type of elimination clause is not well-formed."))
in
let elimclause' = clenv_fchain ~flags indmv elimclause indclause in
- enforce_prop_bound_names rename (Clenvtac.res_pf elimclause' ~with_evars ~with_classes ~flags)
+ Clenvtac.res_pf elimclause' ~with_evars ~with_classes ~flags
end
(*
@@ -1689,22 +1625,6 @@ let descend_in_conjunctions avoid tac (err, info) c =
(* Resolution tactics *)
(****************************************************)
-let solve_remaining_apply_goals =
- Proofview.Goal.enter begin fun gl ->
- let evd = Proofview.Goal.sigma gl in
- if !apply_solve_class_goals then
- try
- let env = Proofview.Goal.env gl in
- let concl = Proofview.Goal.concl gl in
- if Typeclasses.is_class_type evd concl then
- let evd', c' = Typeclasses.resolve_one_typeclass env evd concl in
- Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evd')
- (Refine.refine ~typecheck:false (fun h -> (h,c')))
- else Proofview.tclUNIT ()
- with Not_found -> Proofview.tclUNIT ()
- else Proofview.tclUNIT ()
- end
-
let tclORELSEOPT t k =
Proofview.tclORELSE t
(fun e -> match k e with
@@ -1780,11 +1700,9 @@ let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind :
| _ -> None)
end
in
- Tacticals.New.tclTHENLIST [
- try_main_apply with_destruct c;
- solve_remaining_apply_goals;
- apply_clear_request clear_flag (use_clear_hyp_by_default ()) c
- ]
+ Tacticals.New.tclTHEN
+ (try_main_apply with_destruct c)
+ (apply_clear_request clear_flag (use_clear_hyp_by_default ()) c)
end
let rec apply_with_bindings_gen b e = function
@@ -4249,7 +4167,7 @@ let induction_tac with_evars params indvars elim =
let elimclause' = recolle_clenv i params indvars elimclause gl in
(* one last resolution (useless?) *)
let resolved = clenv_unique_resolver ~flags:(elim_flags ()) elimclause' gl in
- enforce_prop_bound_names rename (Clenvtac.clenv_refine with_evars resolved)
+ Clenvtac.clenv_refine with_evars resolved
end
(* Apply induction "in place" taking into account dependent
@@ -5014,10 +4932,7 @@ let cache_term_by_tactic_then ~opaque ?(goal_type=None) id gk tac tacK =
let (_, info) = CErrors.push src in
iraise (e, info)
in
- let const, args =
- if !shrink_abstract then shrink_entry sign const
- else (const, List.rev (Context.Named.to_instance Constr.mkVar sign))
- in
+ let const, args = shrink_entry sign const in
let args = List.map EConstr.of_constr args in
let cd = Entries.DefinitionEntry { const with Entries.const_entry_opaque = opaque } in
let decl = (cd, if opaque then IsProof Lemma else IsDefinition Definition) in
diff --git a/test-suite/bugs/closed/2245.v b/test-suite/bugs/closed/2245.v
new file mode 100644
index 000000000..f0162f3b2
--- /dev/null
+++ b/test-suite/bugs/closed/2245.v
@@ -0,0 +1,11 @@
+Module Type Test.
+
+Section Sec.
+Variables (A:Type).
+Context (B:Type).
+End Sec.
+
+Fail Check B. (* used to be found !!! *)
+Fail Check A.
+
+End Test.
diff --git a/test-suite/bugs/closed/2378.v b/test-suite/bugs/closed/2378.v
index 85ad41d1c..23a58501f 100644
--- a/test-suite/bugs/closed/2378.v
+++ b/test-suite/bugs/closed/2378.v
@@ -505,8 +505,6 @@ Qed.
Require Export Coq.Logic.FunctionalExtensionality.
Print PLanguage.
-Unset Standard Proposition Elimination Names.
-
Program Definition PTransfo l1 l2 (tr: Transformation l1 l2) (h: isSharedTransfo l1 l2 tr):
Transformation (PLanguage l1) (PLanguage l2) :=
mkTransformation (PLanguage l1) (PLanguage l2)
diff --git a/test-suite/bugs/closed/3481.v b/test-suite/bugs/closed/3481.v
index 89d476dcb..38f03b166 100644
--- a/test-suite/bugs/closed/3481.v
+++ b/test-suite/bugs/closed/3481.v
@@ -3,7 +3,7 @@ Set Implicit Arguments.
Require Import Logic.
Module NonPrim.
-Local Set Record Elimination Schemes.
+Local Set Nonrecursive Elimination Schemes.
Record prodwithlet (A B : Type) : Type :=
pair' { fst : A; fst' := fst; snd : B }.
@@ -21,7 +21,7 @@ End NonPrim.
Global Set Universe Polymorphism.
Global Set Asymmetric Patterns.
-Local Set Record Elimination Schemes.
+Local Set Nonrecursive Elimination Schemes.
Local Set Primitive Projections.
Record prod (A B : Type) : Type :=
diff --git a/test-suite/bugs/closed/3513.v b/test-suite/bugs/closed/3513.v
index 5adc48215..1f0f3b0da 100644
--- a/test-suite/bugs/closed/3513.v
+++ b/test-suite/bugs/closed/3513.v
@@ -69,26 +69,6 @@ Goal forall (T : Type) (O0 : T -> OPred) (O1 : T -> PointedOPred)
refine (P _ _)
end; unfold Basics.flip.
Focus 2.
- Set Typeclasses Debug.
- Set Typeclasses Legacy Resolution.
- apply reflexivity.
- (* Debug: 1.1: apply @IsPointed_catOP on
-(IsPointed (exists x0 : Actions, (catOP ?Goal O2 : OPred) x0))
-Debug: 1.1.1.1: apply OPred_inhabited on (IsPointed (exists x0 : Actions, ?Goal x0))
-Debug: 1.1.2.1: apply OPred_inhabited on (IsPointed (exists x : Actions, O2 x))
-Debug: 2.1: apply @Equivalence_Reflexive on (Reflexive lentails)
-Debug: 2.1.1: no match for (Equivalence lentails) , 5 possibilities
-Debug: Backtracking after apply @Equivalence_Reflexive
-Debug: 2.2: apply @PreOrder_Reflexive on (Reflexive lentails)
-Debug: 2.2.1.1: apply @lentailsPre on (PreOrder lentails)
-Debug: 2.2.1.1.1.1: apply ILFun_ILogic on (ILogic OPred)
-*)
- Undo. Unset Typeclasses Legacy Resolution.
- Test Typeclasses Unique Solutions.
- Test Typeclasses Unique Instances.
- Show Existentials.
- Set Typeclasses Debug Verbosity 2.
- Set Printing All.
(* As in 8.5, allow a shelved subgoal to remain *)
apply reflexivity.
diff --git a/test-suite/bugs/closed/3520.v b/test-suite/bugs/closed/3520.v
index c981207e6..ea122e521 100644
--- a/test-suite/bugs/closed/3520.v
+++ b/test-suite/bugs/closed/3520.v
@@ -3,7 +3,7 @@ Set Primitive Projections.
Record foo (A : Type) :=
{ bar : Type ; baz := Set; bad : baz = bar }.
-Set Record Elimination Schemes.
+Set Nonrecursive Elimination Schemes.
Record notprim : Prop :=
{ irrel : True; relevant : nat }.
diff --git a/test-suite/bugs/closed/3662.v b/test-suite/bugs/closed/3662.v
index bd53389b4..b8754bce9 100644
--- a/test-suite/bugs/closed/3662.v
+++ b/test-suite/bugs/closed/3662.v
@@ -1,6 +1,6 @@
Set Primitive Projections.
Set Implicit Arguments.
-Set Record Elimination Schemes.
+Set Nonrecursive Elimination Schemes.
Record prod A B := pair { fst : A ; snd : B }.
Definition f : Set -> Type := fun x => x.
diff --git a/test-suite/bugs/closed/6313.v b/test-suite/bugs/closed/6313.v
new file mode 100644
index 000000000..4d263c5a8
--- /dev/null
+++ b/test-suite/bugs/closed/6313.v
@@ -0,0 +1,64 @@
+(* Former open goals in nested proofs were lost *)
+
+(* This used to fail with "Incorrect number of goals (expected 1 tactic)." *)
+
+Inductive foo := a | b | c.
+Goal foo -> foo.
+ intro x.
+ simple refine (match x with
+ | a => _
+ | b => ltac:(exact b)
+ | c => _
+ end); [exact a|exact c].
+Abort.
+
+(* This used to leave the goal on the shelf and fails at reflexivity *)
+
+Goal (True/\0=0 -> True) -> True.
+ intro f.
+ refine
+ (f ltac:(split; only 1:exact I)).
+ reflexivity.
+Qed.
+
+(* The "Unshelve" used to not see the explicitly "shelved" goal *)
+
+Lemma f (b:comparison) : b=b.
+refine (match b with
+ Eq => ltac:(shelve)
+ | Lt => ltac:(give_up)
+ | Gt => _
+ end).
+exact (eq_refl Gt).
+Unshelve.
+exact (eq_refl Eq).
+Fail auto. (* Check that there are no more regular subgoals *)
+Admitted.
+
+(* The "Unshelve" used to not see the explicitly "shelved" goal *)
+
+Lemma f2 (b:comparison) : b=b.
+refine (match b with
+ Eq => ltac:(shelve)
+ | Lt => ltac:(give_up)
+ | Gt => _
+ end).
+Unshelve. (* Note: Unshelve puts goals at the end *)
+exact (eq_refl Gt).
+exact (eq_refl Eq).
+Fail auto. (* Check that there are no more regular subgoals *)
+Admitted.
+
+(* The "unshelve" used to not see the explicitly "shelved" goal *)
+
+Lemma f3 (b:comparison) : b=b.
+unshelve refine (match b with
+ Eq => ltac:(shelve)
+ | Lt => ltac:(give_up)
+ | Gt => _
+ end).
+(* Note: unshelve puts goals at the beginning *)
+exact (eq_refl Eq).
+exact (eq_refl Gt).
+Fail auto. (* Check that there are no more regular subgoals *)
+Admitted.
diff --git a/test-suite/bugs/closed/6634.v b/test-suite/bugs/closed/6634.v
new file mode 100644
index 000000000..7f33afcc2
--- /dev/null
+++ b/test-suite/bugs/closed/6634.v
@@ -0,0 +1,6 @@
+From Coq Require Import ssreflect.
+
+Lemma normalizeP (p : tt = tt) : p = p.
+Proof.
+Fail move: {2} tt p.
+Abort.
diff --git a/test-suite/bugs/closed/6910.v b/test-suite/bugs/closed/6910.v
new file mode 100644
index 000000000..5167a5364
--- /dev/null
+++ b/test-suite/bugs/closed/6910.v
@@ -0,0 +1,5 @@
+From Coq Require Import ssreflect ssrfun.
+
+(* We should be able to use Some_inj as a view: *)
+Lemma foo (x y : nat) : Some x = Some y -> x = y.
+Proof. by move/Some_inj. Qed.
diff --git a/test-suite/bugs/closed/HoTT_coq_077.v b/test-suite/bugs/closed/HoTT_coq_077.v
index 017780c1f..f69c71a02 100644
--- a/test-suite/bugs/closed/HoTT_coq_077.v
+++ b/test-suite/bugs/closed/HoTT_coq_077.v
@@ -3,7 +3,7 @@ Set Implicit Arguments.
Require Import Logic.
Set Asymmetric Patterns.
-Set Record Elimination Schemes.
+Set Nonrecursive Elimination Schemes.
Set Primitive Projections.
Record prod (A B : Type) : Type :=
diff --git a/test-suite/bugs/closed/HoTT_coq_104.v b/test-suite/bugs/closed/HoTT_coq_104.v
index 5bb7fa8c1..a6ff78d12 100644
--- a/test-suite/bugs/closed/HoTT_coq_104.v
+++ b/test-suite/bugs/closed/HoTT_coq_104.v
@@ -4,7 +4,7 @@ Require Import Logic.
Global Set Universe Polymorphism.
Global Set Asymmetric Patterns.
-Local Set Record Elimination Schemes.
+Local Set Nonrecursive Elimination Schemes.
Local Set Primitive Projections.
Record prod (A B : Type) : Type :=
diff --git a/test-suite/bugs/opened/1596.v b/test-suite/bugs/opened/1596.v
index 0b576db6b..820022d99 100644
--- a/test-suite/bugs/opened/1596.v
+++ b/test-suite/bugs/opened/1596.v
@@ -2,7 +2,6 @@ Require Import Relations.
Require Import FSets.
Require Import Arith.
Require Import Omega.
-Unset Standard Proposition Elimination Names.
Set Keyed Unification.
diff --git a/test-suite/bugs/opened/3926.v b/test-suite/bugs/opened/3926.v
deleted file mode 100644
index cfad76357..000000000
--- a/test-suite/bugs/opened/3926.v
+++ /dev/null
@@ -1,30 +0,0 @@
-Notation compose := (fun g f x => g (f x)).
-Notation "g 'o' f" := (compose g f) (at level 40, left associativity) : function_scope.
-Open Scope function_scope.
-Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope.
-Arguments idpath {A a} , [A] a.
-Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y := match p with idpath => idpath end.
-Class IsEquiv {A B : Type} (f : A -> B) := { equiv_inv : B -> A }.
-Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'") : equiv_scope.
-Local Open Scope equiv_scope.
-Axiom eisretr : forall {A B} (f : A -> B) `{IsEquiv A B f} x, f (f^-1 x) = x.
-Generalizable Variables A B C f g.
-Global Instance isequiv_compose `{IsEquiv A B f} `{IsEquiv B C g} : IsEquiv (compose g f) | 1000
- := Build_IsEquiv A C (compose g f) (compose f^-1 g^-1).
-Definition isequiv_homotopic {A B} (f : A -> B) {g : A -> B} `{IsEquiv A B f} (h : forall x, f x = g x) : IsEquiv g
- := Build_IsEquiv _ _ g (f ^-1).
-Global Instance isequiv_inverse {A B} (f : A -> B) `{IsEquiv A B f} : IsEquiv f^-1 | 10000
- := Build_IsEquiv B A f^-1 f.
-Definition cancelR_isequiv {A B C} (f : A -> B) {g : B -> C}
- `{IsEquiv A B f} `{IsEquiv A C (g o f)}
- : IsEquiv g.
-Proof.
- Unset Typeclasses Modulo Eta.
- exact (isequiv_homotopic (compose (compose g f) f^-1)
- (fun b => ap g (eisretr f b))) || fail "too early".
- Undo.
- Set Typeclasses Modulo Eta.
- Set Typeclasses Dependency Order.
- Set Typeclasses Debug.
- Fail exact (isequiv_homotopic (compose (compose g f) f^-1)
- (fun b => ap g (eisretr f b))).
diff --git a/test-suite/failure/fixpointeta.v b/test-suite/failure/fixpointeta.v
new file mode 100644
index 000000000..9af719322
--- /dev/null
+++ b/test-suite/failure/fixpointeta.v
@@ -0,0 +1,70 @@
+
+Set Primitive Projections.
+
+Record R := C { p : nat }.
+(* R is defined
+p is defined *)
+
+Unset Primitive Projections.
+Record R' := C' { p' : nat }.
+
+
+
+Fail Definition f := fix f (x : R) : nat := p x.
+(** Not allowed to make fixpoint defs on (non-recursive) records
+ having eta *)
+
+Fail Definition f := fix f (x : R') : nat := p' x.
+(** Even without eta (R' is not primitive here), as long as they're
+ found to be BiFinite (non-recursive), we disallow it *)
+
+(*
+
+(* Subject reduction failure example, if we allowed fixpoints *)
+
+Set Primitive Projections.
+
+Record R := C { p : nat }.
+
+Definition f := fix f (x : R) : nat := p x.
+
+(* eta rule for R *)
+Definition Rtr (P : R -> Type) x (v : P (C (p x))) : P x
+ := v.
+
+Definition goal := forall x, f x = p x.
+
+(* when we compute the Rtr away typechecking will fail *)
+Definition thing : goal := fun x =>
+(Rtr (fun x => f x = p x) x (eq_refl _)).
+
+Definition thing' := Eval compute in thing.
+
+Fail Check (thing = thing').
+(*
+The command has indeed failed with message:
+The term "thing'" has type "forall x : R, (let (p) := x in p) = (let (p) := x in p)"
+while it is expected to have type "goal" (cannot unify "(let (p) := x in p) = (let (p) := x in p)"
+and "f x = p x").
+*)
+
+Definition thing_refl := eq_refl thing.
+
+Fail Definition thing_refl' := Eval compute in thing_refl.
+(*
+The command has indeed failed with message:
+Illegal application:
+The term "@eq_refl" of type "forall (A : Type) (x : A), x = x"
+cannot be applied to the terms
+ "forall x : R, (fix f (x0 : R) : nat := let (p) := x0 in p) x = (let (p) := x in p)" : "Prop"
+ "fun x : R => eq_refl" : "forall x : R, (let (p) := x in p) = (let (p) := x in p)"
+The 2nd term has type "forall x : R, (let (p) := x in p) = (let (p) := x in p)"
+which should be coercible to
+ "forall x : R, (fix f (x0 : R) : nat := let (p) := x0 in p) x = (let (p) := x in p)".
+ *)
+
+Definition more_refls : thing_refl = thing_refl.
+Proof.
+ compute. reflexivity.
+Fail Defined. Abort.
+ *)
diff --git a/test-suite/micromega/square.v b/test-suite/micromega/square.v
index abf8be72e..d163dfbcd 100644
--- a/test-suite/micromega/square.v
+++ b/test-suite/micromega/square.v
@@ -40,7 +40,7 @@ Proof.
Qed.
-Lemma QdenZpower : forall x : Q, ' Qden (x ^ 2)%Q = ('(Qden x) ^ 2) %Z.
+Lemma QdenZpower : forall x : Q, Zpos (Qden (x ^ 2)%Q) = (Zpos (Qden x) ^ 2) %Z.
Proof.
intros.
destruct x.
@@ -54,9 +54,9 @@ Qed.
Theorem sqrt2_not_rational : ~exists x:Q, x^2==2#1.
Proof.
unfold Qeq; intros (x,HQeq); simpl (Qden (2#1)) in HQeq; rewrite Z.mul_1_r in HQeq.
- assert (Heq : (Qnum x ^ 2 = 2 * ' Qden x ^ 2%Q)%Z) by
+ assert (Heq : (Qnum x ^ 2 = 2 * Zpos (Qden x) ^ 2%Q)%Z) by
(rewrite QnumZpower in HQeq ; rewrite QdenZpower in HQeq ; auto).
assert (Hnx : (Qnum x <> 0)%Z)
by (intros Hx; simpl in HQeq; rewrite Hx in HQeq; discriminate HQeq).
- apply integer_statement; exists (Qnum x); exists (' Qden x); auto.
+ apply integer_statement; exists (Qnum x); exists (Zpos (Qden x)); auto.
Qed.
diff --git a/test-suite/modules/WithDefUBinders.v b/test-suite/modules/WithDefUBinders.v
new file mode 100644
index 000000000..e68345516
--- /dev/null
+++ b/test-suite/modules/WithDefUBinders.v
@@ -0,0 +1,15 @@
+
+Set Universe Polymorphism.
+Module Type T.
+ Axiom foo@{u v|u < v} : Type@{v}.
+End T.
+
+Module M : T with Definition foo@{u v} := Type@{u} : Type@{v}.
+ Definition foo@{u v} := Type@{u} : Type@{v}.
+End M.
+
+Fail Module M' : T with Definition foo := Type.
+
+(* Without the binder expression we have to do trickery to get the
+ universes in the right order. *)
+Module M' : T with Definition foo := let t := Type in t.
diff --git a/test-suite/output/Arguments_renaming.out b/test-suite/output/Arguments_renaming.out
index 4df21ae35..e73312c67 100644
--- a/test-suite/output/Arguments_renaming.out
+++ b/test-suite/output/Arguments_renaming.out
@@ -11,7 +11,7 @@ notation scopes add ': clear scopes' [arguments-assert,vernacular]
eq_refl
: ?y = ?y
where
-?y : [ |- nat]
+?y : [ |- nat]
Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x
For eq_refl: Arguments are renamed to B, y
diff --git a/test-suite/output/Existentials.out b/test-suite/output/Existentials.out
index 9680d2bbf..18f5d89f6 100644
--- a/test-suite/output/Existentials.out
+++ b/test-suite/output/Existentials.out
@@ -1,4 +1,4 @@
-Existential 1 = ?Goal : [p : nat q := S p : nat n : nat m : nat |- ?y = m]
+Existential 1 = ?Goal : [p : nat q := S p : nat n : nat m : nat |- ?y = m]
Existential 2 =
-?y : [p : nat q := S p : nat n : nat m : nat |- nat] (p, q cannot be used)
-Existential 3 = ?Goal0 : [q : nat n : nat m : nat |- n = ?y]
+?y : [p : nat q := S p : nat n : nat m : nat |- nat] (p, q cannot be used) (shelved)
+Existential 3 = ?Goal0 : [q : nat n : nat m : nat |- n = ?y]
diff --git a/test-suite/output/Notations3.out b/test-suite/output/Notations3.out
index e6a6e0288..864b6151a 100644
--- a/test-suite/output/Notations3.out
+++ b/test-suite/output/Notations3.out
@@ -33,24 +33,24 @@ fun f : forall x : nat * (bool * unit), ?T => CURRY (x : nat) (y : bool), f
: (forall x : nat * (bool * unit), ?T) ->
forall (x : nat) (y : bool), ?T@{x:=(x, (y, tt))}
where
-?T : [x : nat * (bool * unit) |- Type]
+?T : [x : nat * (bool * unit) |- Type]
fun f : forall x : bool * (nat * unit), ?T =>
CURRYINV (x : nat) (y : bool), f
: (forall x : bool * (nat * unit), ?T) ->
forall (x : nat) (y : bool), ?T@{x:=(y, (x, tt))}
where
-?T : [x : bool * (nat * unit) |- Type]
+?T : [x : bool * (nat * unit) |- Type]
fun f : forall x : unit * nat * bool, ?T => CURRYLEFT (x : nat) (y : bool), f
: (forall x : unit * nat * bool, ?T) ->
forall (x : nat) (y : bool), ?T@{x:=(tt, x, y)}
where
-?T : [x : unit * nat * bool |- Type]
+?T : [x : unit * nat * bool |- Type]
fun f : forall x : unit * bool * nat, ?T =>
CURRYINVLEFT (x : nat) (y : bool), f
: (forall x : unit * bool * nat, ?T) ->
forall (x : nat) (y : bool), ?T@{x:=(tt, y, x)}
where
-?T : [x : unit * bool * nat |- Type]
+?T : [x : unit * bool * nat |- Type]
forall n : nat, {#n | 1 > n}
: Prop
forall x : nat, {|x | x > 0|}
diff --git a/test-suite/output/inference.out b/test-suite/output/inference.out
index d28ee4276..5e9eff048 100644
--- a/test-suite/output/inference.out
+++ b/test-suite/output/inference.out
@@ -9,10 +9,10 @@ fun (m n p : nat) (H : S m <= S n + p) => le_S_n m (n + p) H
fun n : nat => let y : T n := A n in ?t ?x : T n
: forall n : nat, T n
where
-?t : [n : nat y := A n : T n |- ?T -> T n]
-?x : [n : nat y := A n : T n |- ?T]
+?t : [n : nat y := A n : T n |- ?T -> T n]
+?x : [n : nat y := A n : T n |- ?T]
fun n : nat => ?t ?x : T n
: forall n : nat, T n
where
-?t : [n : nat |- ?T -> T n]
-?x : [n : nat |- ?T]
+?t : [n : nat |- ?T -> T n]
+?x : [n : nat |- ?T]
diff --git a/test-suite/success/Hints.v b/test-suite/success/Hints.v
index 6962e43e7..8d08f5975 100644
--- a/test-suite/success/Hints.v
+++ b/test-suite/success/Hints.v
@@ -172,3 +172,14 @@ Hint Cut [_* (a_is_b | b_is_c | c_is_d | d_is_e)
Timeout 1 Fail apply _. (* 0.06s *)
Abort.
End HintCut.
+
+
+(* Check that auto-like tactics do not prefer "eq_refl" over more complex solutions, *)
+(* e.g. those tactics when considering a goal with existential varibles *)
+(* like "m = ?n" won't pick "plus_n_O" hint over "eq_refl" hint. *)
+(* See this Coq club post for more detail: *)
+(* https://sympa.inria.fr/sympa/arc/coq-club/2017-12/msg00103.html *)
+
+Goal forall (m : nat), exists n, m = n /\ m = n.
+ intros m; eexists; split; [trivial | reflexivity].
+Qed.
diff --git a/test-suite/success/Inductive.v b/test-suite/success/Inductive.v
index 893d75b77..5b1482fd5 100644
--- a/test-suite/success/Inductive.v
+++ b/test-suite/success/Inductive.v
@@ -200,3 +200,9 @@ Module NonRecLetIn.
(fun n b c => f_equal (Rec n) eq_refl) 0 (Rec 0 (Base 1)).
End NonRecLetIn.
+
+(* Test treatment of let-in in the definition of Records *)
+(* Should fail with "Sort expected" *)
+
+Fail Inductive foo (T : Type) : let T := Type in T :=
+ { r : forall x : T, x = x }.
diff --git a/test-suite/success/ShowExtraction.v b/test-suite/success/ShowExtraction.v
new file mode 100644
index 000000000..e34c240c5
--- /dev/null
+++ b/test-suite/success/ShowExtraction.v
@@ -0,0 +1,31 @@
+
+Require Extraction.
+Require Import List.
+
+Section Test.
+Variable A : Type.
+Variable decA : forall (x y:A), {x=y}+{x<>y}.
+
+(** Should fail when no proofs are started *)
+Fail Show Extraction.
+
+Lemma decListA : forall (xs ys : list A), {xs=ys}+{xs<>ys}.
+Proof.
+Show Extraction.
+fix 1.
+destruct xs as [|x xs], ys as [|y ys].
+Show Extraction.
+- now left.
+- now right.
+- now right.
+- Show Extraction.
+ destruct (decA x y).
+ + destruct (decListA xs ys).
+ * left; now f_equal.
+ * Show Extraction.
+ right. congruence.
+ + right. congruence.
+Show Extraction.
+Defined.
+
+End Test.
diff --git a/test-suite/success/cumulativity.v b/test-suite/success/cumulativity.v
index e05762477..4dda36042 100644
--- a/test-suite/success/cumulativity.v
+++ b/test-suite/success/cumulativity.v
@@ -134,3 +134,24 @@ Definition withparams_co@{i i' j|i < i', i' < j} : withparams@{i j} -> withparam
Fail Definition withparams_not_irr@{i i' j|i' < i, i' < j} : withparams@{i j} -> withparams@{i' j}
:= fun x => x.
+
+(** Cumulative constructors *)
+
+
+Record twotys@{u v w} : Type@{w} :=
+ twoconstr { fstty : Type@{u}; sndty : Type@{v} }.
+
+Monomorphic Universes i j k l.
+
+Monomorphic Constraint i < j.
+Monomorphic Constraint j < k.
+Monomorphic Constraint k < l.
+
+Parameter Tyi : Type@{i}.
+
+Definition checkcumul :=
+ eq_refl _ : @eq twotys@{k k l} (twoconstr@{i j k} Tyi Tyi) (twoconstr@{j i k} Tyi Tyi).
+
+(* They can only be compared at the highest type *)
+Fail Definition checkcumul' :=
+ eq_refl _ : @eq twotys@{i k l} (twoconstr@{i j k} Tyi Tyi) (twoconstr@{j i k} Tyi Tyi).
diff --git a/test-suite/success/letproj.v b/test-suite/success/letproj.v
index a183be622..de2857b43 100644
--- a/test-suite/success/letproj.v
+++ b/test-suite/success/letproj.v
@@ -1,5 +1,5 @@
Set Primitive Projections.
-Set Record Elimination Schemes.
+Set Nonrecursive Elimination Schemes.
Record Foo (A : Type) := { bar : A -> A; baz : A }.
Definition test (A : Type) (f : Foo A) :=
diff --git a/test-suite/success/name_mangling.v b/test-suite/success/name_mangling.v
new file mode 100644
index 000000000..571dde880
--- /dev/null
+++ b/test-suite/success/name_mangling.v
@@ -0,0 +1,192 @@
+(* -*- coq-prog-args: ("-mangle-names" "_") -*- *)
+
+(* Check that refine policy of redefining previous names make these names private *)
+(* abstract can change names in the environment! See bug #3146 *)
+
+Goal True -> True.
+intro.
+Fail exact H.
+exact _0.
+Abort.
+
+Unset Mangle Names.
+Goal True -> True.
+intro; exact H.
+Abort.
+
+Set Mangle Names.
+Set Mangle Names Prefix "baz".
+Goal True -> True.
+intro.
+Fail exact H.
+Fail exact _0.
+exact baz0.
+Abort.
+
+Goal True -> True.
+intro; assumption.
+Abort.
+
+Goal True -> True.
+intro x; exact x.
+Abort.
+
+Goal forall x y, x+y=0.
+intro x.
+refine (fun x => _).
+Fail Check x0.
+Check x.
+Abort.
+
+(* Example from Emilio *)
+
+Goal forall b : False, b = b.
+intro b.
+refine (let b := I in _).
+Fail destruct b0.
+Abort.
+
+(* Example from Cyprien *)
+
+Goal True -> True.
+Proof.
+ refine (fun _ => _).
+ Fail exact t.
+Abort.
+
+(* Example from Jason *)
+
+Goal False -> False.
+intro H.
+Fail abstract exact H.
+Abort.
+
+(* Variant *)
+
+Goal False -> False.
+intro.
+Fail abstract exact H.
+Abort.
+
+(* Example from Jason *)
+
+Goal False -> False.
+intro H.
+(* Name H' is from Ltac here, so it preserves the privacy *)
+(* But abstract messes everything up *)
+Fail let H' := H in abstract exact H'.
+let H' := H in exact H'.
+Qed.
+
+(* Variant *)
+
+Goal False -> False.
+intro.
+Fail let H' := H in abstract exact H'.
+Abort.
+
+(* Indirectly testing preservation of names by move (derived from Jason) *)
+
+Inductive nat2 := S2 (_ _ : nat2).
+Goal forall t : nat2, True.
+ intro t.
+ let IHt1 := fresh "IHt1" in
+ let IHt2 := fresh "IHt2" in
+ induction t as [? IHt1 ? IHt2].
+ Fail exact IHt1.
+Abort.
+
+(* Example on "pose proof" (from Jason) *)
+
+Goal False -> False.
+intro; pose proof I as H0.
+Fail exact H.
+Abort.
+
+(* Testing the approach for which non alpha-renamed quantified names are user-generated *)
+
+Section foo.
+Context (b : True).
+Goal forall b : False, b = b.
+Fail destruct b0.
+Abort.
+
+Goal forall b : False, b = b.
+now destruct b.
+Qed.
+End foo.
+
+(* Test stability of "fix" *)
+
+Lemma a : forall n, n = 0.
+Proof.
+fix a 1.
+Check a.
+fix 1.
+Fail Check a0.
+Abort.
+
+(* Test stability of "induction" *)
+
+Lemma a : forall n : nat, n = n.
+Proof.
+intro n; induction n as [ | n IHn ].
+- auto.
+- Check n.
+ Check IHn.
+Abort.
+
+Inductive I := C : I -> I -> I.
+
+Lemma a : forall n : I, n = n.
+Proof.
+intro n; induction n as [ n1 IHn1 n2 IHn2 ].
+Check n1.
+Check n2.
+apply f_equal2.
++ apply IHn1.
++ apply IHn2.
+Qed.
+
+(* Testing remember *)
+
+Lemma c : 0 = 0.
+Proof.
+remember 0 as x eqn:Heqx.
+Check Heqx.
+Abort.
+
+Lemma c : forall Heqx, Heqx -> 0 = 0.
+Proof.
+intros Heqx X.
+remember 0 as x.
+Fail Check Heqx0. (* Heqx0 is not canonical *)
+Abort.
+
+(* An example by Jason from the discussion for PR #268 *)
+
+Goal nat -> Set -> True.
+ intros x y.
+ match goal with
+ | [ x : _, y : _ |- _ ]
+ => let z := fresh "z" in
+ rename y into z, x into y;
+ let x' := fresh "x" in
+ rename z into x'
+ end.
+ revert y. (* x has been explicitly moved to y *)
+ Fail revert x. (* x comes from "fresh" *)
+Abort.
+
+Goal nat -> Set -> True.
+ intros.
+ match goal with
+ | [ x : _, y : _ |- _ ]
+ => let z := fresh "z" in
+ rename y into z, x into y;
+ let x' := fresh "x" in
+ rename z into x'
+ end.
+ Fail revert y. (* generated by intros *)
+ Fail revert x. (* generated by intros *)
+Abort.
diff --git a/test-suite/success/old_typeclass.v b/test-suite/success/old_typeclass.v
deleted file mode 100644
index 01e35810b..000000000
--- a/test-suite/success/old_typeclass.v
+++ /dev/null
@@ -1,13 +0,0 @@
-Require Import Setoid Coq.Classes.Morphisms.
-Set Typeclasses Legacy Resolution.
-
-Declare Instance and_Proper_eq: Proper (Logic.eq ==> Logic.eq ==> Logic.eq) and.
-
-Axiom In : Prop.
-Axiom union_spec : In <-> True.
-
-Lemma foo : In /\ True.
-Proof.
-progress rewrite union_spec.
-repeat constructor.
-Qed.
diff --git a/test-suite/success/primitiveproj.v b/test-suite/success/primitiveproj.v
index 576bdbf71..31a1608c4 100644
--- a/test-suite/success/primitiveproj.v
+++ b/test-suite/success/primitiveproj.v
@@ -1,5 +1,5 @@
Set Primitive Projections.
-Set Record Elimination Schemes.
+Set Nonrecursive Elimination Schemes.
Module Prim.
Record F := { a : nat; b : a = a }.
diff --git a/test-suite/success/shrink_abstract.v b/test-suite/success/shrink_abstract.v
index 3f6b9cb39..916bb846a 100644
--- a/test-suite/success/shrink_abstract.v
+++ b/test-suite/success/shrink_abstract.v
@@ -1,5 +1,3 @@
-Set Shrink Abstract.
-
Definition foo : forall (n m : nat), bool.
Proof.
pose (p := 0).
diff --git a/theories/Compat/Coq87.v b/theories/Compat/Coq87.v
index 89556ee75..dc1397aff 100644
--- a/theories/Compat/Coq87.v
+++ b/theories/Compat/Coq87.v
@@ -9,6 +9,7 @@
(************************************************************************)
(** Compatibility file for making Coq act similar to Coq v8.7 *)
+Require Export Coq.Compat.Coq88.
(* In 8.7, omega wasn't taking advantage of local abbreviations,
see bug 148 and PR#768. For adjusting this flag, we're forced to
diff --git a/theories/Compat/Coq88.v b/theories/Compat/Coq88.v
new file mode 100644
index 000000000..4142af05d
--- /dev/null
+++ b/theories/Compat/Coq88.v
@@ -0,0 +1,11 @@
+(************************************************************************)
+(* * 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) *)
+(************************************************************************)
+
+(** Compatibility file for making Coq act similar to Coq v8.8 *)
diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v
index 683a442cb..72073bb4f 100644
--- a/theories/Init/Notations.v
+++ b/theories/Init/Notations.v
@@ -77,6 +77,7 @@ Reserved Notation "{ x | P & Q }" (at level 0, x at level 99).
Reserved Notation "{ x : A | P }" (at level 0, x at level 99).
Reserved Notation "{ x : A | P & Q }" (at level 0, x at level 99).
+Reserved Notation "{ x & P }" (at level 0, x at level 99).
Reserved Notation "{ x : A & P }" (at level 0, x at level 99).
Reserved Notation "{ x : A & P & Q }" (at level 0, x at level 99).
diff --git a/theories/Init/Peano.v b/theories/Init/Peano.v
index 73c8c5ef4..d5322d094 100644
--- a/theories/Init/Peano.v
+++ b/theories/Init/Peano.v
@@ -92,7 +92,9 @@ Lemma plus_n_O : forall n:nat, n = n + 0.
Proof.
induction n; simpl; auto.
Qed.
-Hint Resolve plus_n_O: core.
+
+Remove Hints eq_refl : core.
+Hint Resolve plus_n_O eq_refl: core. (* We want eq_refl to have higher priority than plus_n_O *)
Lemma plus_O_n : forall n:nat, 0 + n = n.
Proof.
diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v
index 137bd3a0f..b6afba29a 100644
--- a/theories/Init/Specif.v
+++ b/theories/Init/Specif.v
@@ -51,6 +51,7 @@ Notation "{ x | P & Q }" := (sig2 (fun x => P) (fun x => Q)) : type_scope.
Notation "{ x : A | P }" := (sig (A:=A) (fun x => P)) : type_scope.
Notation "{ x : A | P & Q }" := (sig2 (A:=A) (fun x => P) (fun x => Q)) :
type_scope.
+Notation "{ x & P }" := (sigT (fun x => P)) : type_scope.
Notation "{ x : A & P }" := (sigT (A:=A) (fun x => P)) : type_scope.
Notation "{ x : A & P & Q }" := (sigT2 (A:=A) (fun x => P) (fun x => Q)) :
type_scope.
diff --git a/theories/Logic/ChoiceFacts.v b/theories/Logic/ChoiceFacts.v
index 9fd52866e..238ac7df0 100644
--- a/theories/Logic/ChoiceFacts.v
+++ b/theories/Logic/ChoiceFacts.v
@@ -28,6 +28,8 @@ intentional type theory, Journal of Symbolic Logic 70(2):488-514, 2005.
[[Werner97]] Benjamin Werner, Sets in Types, Types in Sets, TACS, 1997.
*)
+Require Import RelationClasses Logic.
+
Set Implicit Arguments.
Local Unset Intuition Negation Unfolding.
@@ -125,8 +127,6 @@ Definition DependentFunctionalRelReification_on (A:Type) (B:A -> Type) :=
formulation of choice); Note also a typo in its intended
formulation in [[Werner97]]. *)
-Require Import RelationClasses Logic.
-
Definition RepresentativeFunctionalChoice_on :=
forall R:A->A->Prop,
(Equivalence R) ->
diff --git a/theories/QArith/QArith_base.v b/theories/QArith/QArith_base.v
index 467f263be..35706e7fa 100644
--- a/theories/QArith/QArith_base.v
+++ b/theories/QArith/QArith_base.v
@@ -227,9 +227,7 @@ Infix "/" := Qdiv : Q_scope.
(** A light notation for [Zpos] *)
-Notation " ' x " := (Zpos x) (at level 20, no associativity) : Z_scope.
-
-Lemma Qmake_Qdiv a b : a#b==inject_Z a/inject_Z ('b).
+Lemma Qmake_Qdiv a b : a#b==inject_Z a/inject_Z (Zpos b).
Proof.
unfold Qeq. simpl. ring.
Qed.
@@ -242,9 +240,9 @@ Proof.
Open Scope Z_scope.
intros (p1, p2) (q1, q2) H (r1, r2) (s1, s2) H0; simpl in *.
simpl_mult; ring_simplify.
- replace (p1 * 'r2 * 'q2) with (p1 * 'q2 * 'r2) by ring.
+ replace (p1 * Zpos r2 * Zpos q2) with (p1 * Zpos q2 * Zpos r2) by ring.
rewrite H.
- replace (r1 * 'p2 * 'q2 * 's2) with (r1 * 's2 * 'p2 * 'q2) by ring.
+ replace (r1 * Zpos p2 * Zpos q2 * Zpos s2) with (r1 * Zpos s2 * Zpos p2 * Zpos q2) by ring.
rewrite H0.
ring.
Close Scope Z_scope.
@@ -255,7 +253,7 @@ Proof.
unfold Qeq, Qopp; simpl.
Open Scope Z_scope.
intros x y H; simpl.
- replace (- Qnum x * ' Qden y) with (- (Qnum x * ' Qden y)) by ring.
+ replace (- Qnum x * Zpos (Qden y)) with (- (Qnum x * Zpos (Qden y))) by ring.
rewrite H; ring.
Close Scope Z_scope.
Qed.
@@ -272,9 +270,9 @@ Proof.
Open Scope Z_scope.
intros (p1, p2) (q1, q2) H (r1, r2) (s1, s2) H0; simpl in *.
intros; simpl_mult; ring_simplify.
- replace (q1 * s1 * 'p2) with (q1 * 'p2 * s1) by ring.
+ replace (q1 * s1 * Zpos p2) with (q1 * Zpos p2 * s1) by ring.
rewrite <- H.
- replace (p1 * r1 * 'q2 * 's2) with (r1 * 's2 * p1 * 'q2) by ring.
+ replace (p1 * r1 * Zpos q2 * Zpos s2) with (r1 * Zpos s2 * p1 * Zpos q2) by ring.
rewrite H0.
ring.
Close Scope Z_scope.
@@ -305,13 +303,13 @@ Proof.
unfold Qeq, Qcompare.
Open Scope Z_scope.
intros (p1,p2) (q1,q2) H (r1,r2) (s1,s2) H'; simpl in *.
- rewrite <- (Zcompare_mult_compat (q2*s2) (p1*'r2)).
- rewrite <- (Zcompare_mult_compat (p2*r2) (q1*'s2)).
- change ('(q2*s2)) with ('q2 * 's2).
- change ('(p2*r2)) with ('p2 * 'r2).
- replace ('q2 * 's2 * (p1*'r2)) with ((p1*'q2)*'r2*'s2) by ring.
+ rewrite <- (Zcompare_mult_compat (q2*s2) (p1*Zpos r2)).
+ rewrite <- (Zcompare_mult_compat (p2*r2) (q1*Zpos s2)).
+ change (Zpos (q2*s2)) with (Zpos q2 * Zpos s2).
+ change (Zpos (p2*r2)) with (Zpos p2 * Zpos r2).
+ replace (Zpos q2 * Zpos s2 * (p1*Zpos r2)) with ((p1*Zpos q2)*Zpos r2*Zpos s2) by ring.
rewrite H.
- replace ('q2 * 's2 * (r1*'p2)) with ((r1*'s2)*'q2*'p2) by ring.
+ replace (Zpos q2 * Zpos s2 * (r1*Zpos p2)) with ((r1*Zpos s2)*Zpos q2*Zpos p2) by ring.
rewrite H'.
f_equal; ring.
Close Scope Z_scope.
@@ -572,8 +570,8 @@ Lemma Qle_trans : forall x y z, x<=y -> y<=z -> x<=z.
Proof.
unfold Qle; intros (x1, x2) (y1, y2) (z1, z2); simpl; intros.
Open Scope Z_scope.
- apply Z.mul_le_mono_pos_r with ('y2); [easy|].
- apply Z.le_trans with (y1 * 'x2 * 'z2).
+ apply Z.mul_le_mono_pos_r with (Zpos y2); [easy|].
+ apply Z.le_trans with (y1 * Zpos x2 * Zpos z2).
- rewrite Z.mul_shuffle0. now apply Z.mul_le_mono_pos_r.
- rewrite Z.mul_shuffle0, (Z.mul_shuffle0 z1).
now apply Z.mul_le_mono_pos_r.
@@ -620,8 +618,8 @@ Lemma Qle_lt_trans : forall x y z, x<=y -> y<z -> x<z.
Proof.
unfold Qle, Qlt; intros (x1, x2) (y1, y2) (z1, z2); simpl; intros.
Open Scope Z_scope.
- apply Z.mul_lt_mono_pos_r with ('y2); [easy|].
- apply Z.le_lt_trans with (y1 * 'x2 * 'z2).
+ apply Z.mul_lt_mono_pos_r with (Zpos y2); [easy|].
+ apply Z.le_lt_trans with (y1 * Zpos x2 * Zpos z2).
- rewrite Z.mul_shuffle0. now apply Z.mul_le_mono_pos_r.
- rewrite Z.mul_shuffle0, (Z.mul_shuffle0 z1).
now apply Z.mul_lt_mono_pos_r.
@@ -632,8 +630,8 @@ Lemma Qlt_le_trans : forall x y z, x<y -> y<=z -> x<z.
Proof.
unfold Qle, Qlt; intros (x1, x2) (y1, y2) (z1, z2); simpl; intros.
Open Scope Z_scope.
- apply Z.mul_lt_mono_pos_r with ('y2); [easy|].
- apply Z.lt_le_trans with (y1 * 'x2 * 'z2).
+ apply Z.mul_lt_mono_pos_r with (Zpos y2); [easy|].
+ apply Z.lt_le_trans with (y1 * Zpos x2 * Zpos z2).
- rewrite Z.mul_shuffle0. now apply Z.mul_lt_mono_pos_r.
- rewrite Z.mul_shuffle0, (Z.mul_shuffle0 z1).
now apply Z.mul_le_mono_pos_r.
@@ -723,9 +721,9 @@ Proof.
match goal with |- ?a <= ?b => ring_simplify a b end.
rewrite Z.add_comm.
apply Z.add_le_mono.
- match goal with |- ?a <= ?b => ring_simplify z1 t1 ('z2) ('t2) a b end.
+ match goal with |- ?a <= ?b => ring_simplify z1 t1 (Zpos z2) (Zpos t2) a b end.
auto with zarith.
- match goal with |- ?a <= ?b => ring_simplify x1 y1 ('x2) ('y2) a b end.
+ match goal with |- ?a <= ?b => ring_simplify x1 y1 (Zpos x2) (Zpos y2) a b end.
auto with zarith.
Close Scope Z_scope.
Qed.
@@ -740,9 +738,9 @@ Proof.
match goal with |- ?a < ?b => ring_simplify a b end.
rewrite Z.add_comm.
apply Z.add_le_lt_mono.
- match goal with |- ?a <= ?b => ring_simplify z1 t1 ('z2) ('t2) a b end.
+ match goal with |- ?a <= ?b => ring_simplify z1 t1 (Zpos z2) (Zpos t2) a b end.
auto with zarith.
- match goal with |- ?a < ?b => ring_simplify x1 y1 ('x2) ('y2) a b end.
+ match goal with |- ?a < ?b => ring_simplify x1 y1 (Zpos x2) (Zpos y2) a b end.
do 2 (apply Z.mul_lt_mono_pos_r;try easy).
Close Scope Z_scope.
Qed.
diff --git a/theories/QArith/Qabs.v b/theories/QArith/Qabs.v
index 48be89417..31eb41bc9 100644
--- a/theories/QArith/Qabs.v
+++ b/theories/QArith/Qabs.v
@@ -28,8 +28,8 @@ intros [xn xd] [yn yd] H.
simpl.
unfold Qeq in *.
simpl in *.
-change (' yd)%Z with (Z.abs (' yd)).
-change (' xd)%Z with (Z.abs (' xd)).
+change (Zpos yd)%Z with (Z.abs (Zpos yd)).
+change (Zpos xd)%Z with (Z.abs (Zpos xd)).
repeat rewrite <- Z.abs_mul.
congruence.
Qed.
@@ -88,8 +88,8 @@ unfold Qplus.
unfold Qle.
simpl.
apply Z.mul_le_mono_nonneg_r;auto with *.
-change (' yd)%Z with (Z.abs (' yd)).
-change (' xd)%Z with (Z.abs (' xd)).
+change (Zpos yd)%Z with (Z.abs (Zpos yd)).
+change (Zpos xd)%Z with (Z.abs (Zpos xd)).
repeat rewrite <- Z.abs_mul.
apply Z.abs_triangle.
Qed.
diff --git a/theories/QArith/Qcanon.v b/theories/QArith/Qcanon.v
index e25f69c31..1510a7b82 100644
--- a/theories/QArith/Qcanon.v
+++ b/theories/QArith/Qcanon.v
@@ -30,7 +30,7 @@ Lemma Qred_identity :
Proof.
intros (a,b) H; simpl in *.
rewrite <- Z.ggcd_gcd in H.
- generalize (Z.ggcd_correct_divisors a ('b)).
+ generalize (Z.ggcd_correct_divisors a (Zpos b)).
destruct Z.ggcd as (g,(aa,bb)); simpl in *; subst.
rewrite !Z.mul_1_l. now intros (<-,<-).
Qed.
@@ -39,7 +39,7 @@ Lemma Qred_identity2 :
forall q:Q, Qred q = q -> Z.gcd (Qnum q) (QDen q) = 1%Z.
Proof.
intros (a,b) H; simpl in *.
- generalize (Z.gcd_nonneg a ('b)) (Z.ggcd_correct_divisors a ('b)).
+ generalize (Z.gcd_nonneg a (Zpos b)) (Z.ggcd_correct_divisors a (Zpos b)).
rewrite <- Z.ggcd_gcd.
destruct Z.ggcd as (g,(aa,bb)); simpl in *.
injection H as <- <-. intros H (_,H').
diff --git a/theories/QArith/Qpower.v b/theories/QArith/Qpower.v
index 3fd78f092..010782209 100644
--- a/theories/QArith/Qpower.v
+++ b/theories/QArith/Qpower.v
@@ -90,7 +90,7 @@ rewrite Qinv_power.
reflexivity.
Qed.
-Lemma Qinv_power_n : forall n p, (1#p)^n == /(inject_Z ('p))^n.
+Lemma Qinv_power_n : forall n p, (1#p)^n == /(inject_Z (Zpos p))^n.
Proof.
intros n p.
rewrite Qmake_Qdiv.
@@ -190,7 +190,7 @@ unfold Z.succ.
rewrite Zpower_exp; auto with *; try discriminate.
rewrite Qpower_plus' by discriminate.
rewrite <- IHn by discriminate.
-replace (a^'n*a^1)%Z with (a^'n*a)%Z by ring.
+replace (a^Zpos n*a^1)%Z with (a^Zpos n*a)%Z by ring.
ring_simplify.
reflexivity.
Qed.
diff --git a/theories/QArith/Qreals.v b/theories/QArith/Qreals.v
index 14ab1700e..c83296259 100644
--- a/theories/QArith/Qreals.v
+++ b/theories/QArith/Qreals.v
@@ -167,8 +167,8 @@ unfold Qinv, Q2R, Qeq; intros (x1, x2). case x1; unfold Qnum, Qden.
simpl; intros; elim H; trivial.
intros; field; auto.
intros;
- change (IZR (Zneg x2)) with (- IZR (' x2))%R;
- change (IZR (Zneg p)) with (- IZR (' p))%R;
+ change (IZR (Zneg x2)) with (- IZR (Zpos x2))%R;
+ change (IZR (Zneg p)) with (- IZR (Zpos p))%R;
simpl; field; (*auto 8 with real.*)
repeat split; auto; auto with real.
Qed.
diff --git a/theories/QArith/Qreduction.v b/theories/QArith/Qreduction.v
index 7b08515d2..17307c827 100644
--- a/theories/QArith/Qreduction.v
+++ b/theories/QArith/Qreduction.v
@@ -21,14 +21,14 @@ Notation Z2P_correct := Z2Pos.id (only parsing).
Definition Qred (q:Q) :=
let (q1,q2) := q in
- let (r1,r2) := snd (Z.ggcd q1 ('q2))
+ let (r1,r2) := snd (Z.ggcd q1 (Zpos q2))
in r1#(Z.to_pos r2).
Lemma Qred_correct : forall q, (Qred q) == q.
Proof.
unfold Qred, Qeq; intros (n,d); simpl.
- generalize (Z.ggcd_gcd n ('d)) (Z.gcd_nonneg n ('d))
- (Z.ggcd_correct_divisors n ('d)).
+ generalize (Z.ggcd_gcd n (Zpos d)) (Z.gcd_nonneg n (Zpos d))
+ (Z.ggcd_correct_divisors n (Zpos d)).
destruct (Z.ggcd n (Zpos d)) as (g,(nn,dd)); simpl.
Open Scope Z_scope.
intros Hg LE (Hn,Hd). rewrite Hd, Hn.
@@ -45,13 +45,13 @@ Proof.
unfold Qred, Qeq in *; simpl in *.
Open Scope Z_scope.
intros H.
- generalize (Z.ggcd_gcd a ('b)) (Zgcd_is_gcd a ('b))
- (Z.gcd_nonneg a ('b)) (Z.ggcd_correct_divisors a ('b)).
+ generalize (Z.ggcd_gcd a (Zpos b)) (Zgcd_is_gcd a (Zpos b))
+ (Z.gcd_nonneg a (Zpos b)) (Z.ggcd_correct_divisors a (Zpos b)).
destruct (Z.ggcd a (Zpos b)) as (g,(aa,bb)).
simpl. intros <- Hg1 Hg2 (Hg3,Hg4).
assert (Hg0 : g <> 0) by (intro; now subst g).
- generalize (Z.ggcd_gcd c ('d)) (Zgcd_is_gcd c ('d))
- (Z.gcd_nonneg c ('d)) (Z.ggcd_correct_divisors c ('d)).
+ generalize (Z.ggcd_gcd c (Zpos d)) (Zgcd_is_gcd c (Zpos d))
+ (Z.gcd_nonneg c (Zpos d)) (Z.ggcd_correct_divisors c (Zpos d)).
destruct (Z.ggcd c (Zpos d)) as (g',(cc,dd)).
simpl. intros <- Hg'1 Hg'2 (Hg'3,Hg'4).
assert (Hg'0 : g' <> 0) by (intro; now subst g').
diff --git a/theories/QArith/Qround.v b/theories/QArith/Qround.v
index e4e974972..7c5ddbb6a 100644
--- a/theories/QArith/Qround.v
+++ b/theories/QArith/Qround.v
@@ -80,11 +80,11 @@ unfold Qlt.
simpl.
replace (n*1)%Z with n by ring.
ring_simplify.
-replace (n / ' d * ' d + ' d)%Z with
- (('d * (n / 'd) + n mod 'd) + 'd - n mod 'd)%Z by ring.
+replace (n / Zpos d * Zpos d + Zpos d)%Z with
+ ((Zpos d * (n / Zpos d) + n mod Zpos d) + Zpos d - n mod Zpos d)%Z by ring.
rewrite <- Z_div_mod_eq; auto with*.
rewrite <- Z.lt_add_lt_sub_r.
-destruct (Z_mod_lt n ('d)); auto with *.
+destruct (Z_mod_lt n (Zpos d)); auto with *.
Qed.
Hint Resolve Qlt_floor : qarith.
@@ -107,9 +107,9 @@ Proof.
intros [xn xd] [yn yd] Hxy.
unfold Qle in *.
simpl in *.
-rewrite <- (Zdiv_mult_cancel_r xn ('xd) ('yd)); auto with *.
-rewrite <- (Zdiv_mult_cancel_r yn ('yd) ('xd)); auto with *.
-rewrite (Z.mul_comm ('yd) ('xd)).
+rewrite <- (Zdiv_mult_cancel_r xn (Zpos xd) (Zpos yd)); auto with *.
+rewrite <- (Zdiv_mult_cancel_r yn (Zpos yd) (Zpos xd)); auto with *.
+rewrite (Z.mul_comm (Zpos yd) (Zpos xd)).
apply Z_div_le; auto with *.
Qed.
diff --git a/theories/Reals/Ranalysis5.v b/theories/Reals/Ranalysis5.v
index 88ab4d6e1..afb78e1c8 100644
--- a/theories/Reals/Ranalysis5.v
+++ b/theories/Reals/Ranalysis5.v
@@ -29,46 +29,34 @@ Lemma f_incr_implies_g_incr_interv : forall f g:R->R, forall lb ub,
(forall x , f lb <= x -> x <= f ub -> lb <= g x <= ub) ->
(forall x y, f lb <= x -> x < y -> y <= f ub -> g x < g y).
Proof.
-intros f g lb ub lb_lt_ub f_incr f_eq_g g_ok x y lb_le_x x_lt_y y_le_ub.
- assert (x_encad : f lb <= x <= f ub).
- split ; [assumption | apply Rle_trans with (r2:=y) ; [apply Rlt_le|] ; assumption].
- assert (y_encad : f lb <= y <= f ub).
- split ; [apply Rle_trans with (r2:=x) ; [|apply Rlt_le] ; assumption | assumption].
- assert (Temp1 : lb <= lb) by intuition ; assert (Temp2 : ub <= ub) by intuition.
- assert (gx_encad := g_ok _ (proj1 x_encad) (proj2 x_encad)).
- assert (gy_encad := g_ok _ (proj1 y_encad) (proj2 y_encad)).
- clear Temp1 Temp2.
- case (Rlt_dec (g x) (g y)).
- intuition.
+ intros f g lb ub lb_lt_ub f_incr f_eq_g g_ok x y lb_le_x x_lt_y y_le_ub.
+ assert (x_encad : f lb <= x <= f ub) by lra.
+ assert (y_encad : f lb <= y <= f ub) by lra.
+ assert (gx_encad := g_ok _ (proj1 x_encad) (proj2 x_encad)).
+ assert (gy_encad := g_ok _ (proj1 y_encad) (proj2 y_encad)).
+ case (Rlt_dec (g x) (g y)); [ easy |].
intros Hfalse.
- assert (Temp := Rnot_lt_le _ _ Hfalse).
- assert (Hcontradiction : y <= x).
- replace y with (id y) by intuition ; replace x with (id x) by intuition ;
- rewrite <- f_eq_g. rewrite <- f_eq_g.
- assert (f_incr2 : forall x y, lb <= x -> x <= y -> y < ub -> f x <= f y).
+ assert (Temp := Rnot_lt_le _ _ Hfalse).
+ enough (y <= x) by lra.
+ replace y with (id y) by easy.
+ replace x with (id x) by easy.
+ rewrite <- f_eq_g by easy.
+ rewrite <- f_eq_g by easy.
+ assert (f_incr2 : forall x y, lb <= x -> x <= y -> y < ub -> f x <= f y). {
intros m n lb_le_m m_le_n n_lt_ub.
case (m_le_n).
- intros ; apply Rlt_le ; apply f_incr ; [| | apply Rlt_le] ; assumption.
- intros Hyp ; rewrite Hyp ; apply Req_le ; reflexivity.
- apply f_incr2.
- intuition. intuition.
- Focus 3. intuition.
- Focus 2. intuition.
- Focus 2. intuition. Focus 2. intuition.
- assert (Temp2 : g x <> ub).
- intro Hf.
- assert (Htemp : (comp f g) x = f ub).
- unfold comp ; rewrite Hf ; reflexivity.
- rewrite f_eq_g in Htemp ; unfold id in Htemp.
- assert (Htemp2 : x < f ub).
- apply Rlt_le_trans with (r2:=y) ; intuition.
- clear -Htemp Htemp2. fourier.
- intuition. intuition.
- clear -Temp2 gx_encad.
- case (proj2 gx_encad).
- intuition.
- intro Hfalse ; apply False_ind ; apply Temp2 ; assumption.
- apply False_ind. clear - Hcontradiction x_lt_y. fourier.
+ - intros; apply Rlt_le, f_incr, Rlt_le; assumption.
+ - intros Hyp; rewrite Hyp; apply Req_le; reflexivity.
+ }
+ apply f_incr2; intuition.
+ enough (g x <> ub) by lra.
+ intro Hf.
+ assert (Htemp : (comp f g) x = f ub). {
+ unfold comp; rewrite Hf; reflexivity.
+ }
+ rewrite f_eq_g in Htemp by easy.
+ unfold id in Htemp.
+ fourier.
Qed.
Lemma derivable_pt_id_interv : forall (lb ub x:R),
diff --git a/theories/Sets/Multiset.v b/theories/Sets/Multiset.v
index a50140628..a79ddead2 100644
--- a/theories/Sets/Multiset.v
+++ b/theories/Sets/Multiset.v
@@ -11,6 +11,7 @@
(* G. Huet 1-9-95 *)
Require Import Permut Setoid.
+Require Plus. (* comm. and ass. of plus *)
Set Implicit Arguments.
@@ -69,9 +70,6 @@ Section multiset_defs.
unfold meq; unfold munion; simpl; auto.
Qed.
-
- Require Plus. (* comm. and ass. of plus *)
-
Lemma munion_comm : forall x y:multiset, meq (munion x y) (munion y x).
Proof.
unfold meq; unfold multiplicity; unfold munion.
diff --git a/theories/Sets/Uniset.v b/theories/Sets/Uniset.v
index 95ba93232..7940bda1a 100644
--- a/theories/Sets/Uniset.v
+++ b/theories/Sets/Uniset.v
@@ -13,7 +13,7 @@
(* G. Huet 1-9-95 *)
(* Updated Papageno 12/98 *)
-Require Import Bool.
+Require Import Bool Permut.
Set Implicit Arguments.
@@ -140,8 +140,6 @@ Hint Resolve seq_right.
(** Here we should make uniset an abstract datatype, by hiding [Charac],
[union], [charac]; all further properties are proved abstractly *)
-Require Import Permut.
-
Lemma union_rotate :
forall x y z:uniset, seq (union x (union y z)) (union z (union x y)).
Proof.
diff --git a/theories/Sorting/Heap.v b/theories/Sorting/Heap.v
index 8f583be97..d9e5ad676 100644
--- a/theories/Sorting/Heap.v
+++ b/theories/Sorting/Heap.v
@@ -136,7 +136,7 @@ Section defs.
(munion (list_contents _ eqA_dec l1) (list_contents _ eqA_dec l2)) ->
(forall a, HdRel leA a l1 -> HdRel leA a l2 -> HdRel leA a l) ->
merge_lem l1 l2.
- Require Import Morphisms.
+ Import Morphisms.
Instance: Equivalence (@meq A).
Proof. constructor; auto with datatypes. red. apply meq_trans. Defined.
diff --git a/theories/Strings/String.v b/theories/Strings/String.v
index a302b8329..2be6618ad 100644
--- a/theories/Strings/String.v
+++ b/theories/Strings/String.v
@@ -165,6 +165,18 @@ intros n0 H; apply Rec; simpl; auto.
apply Le.le_S_n; auto.
Qed.
+(** *** Concatenating lists of strings *)
+
+(** [concat sep sl] concatenates the list of strings [sl], inserting
+ the separator string [sep] between each. *)
+
+Fixpoint concat (sep : string) (ls : list string) :=
+ match ls with
+ | nil => EmptyString
+ | cons x nil => x
+ | cons x xs => x ++ sep ++ concat sep xs
+ end.
+
(** *** Test functions *)
(** Test if [s1] is a prefix of [s2] *)
diff --git a/tools/CoqMakefile.in b/tools/CoqMakefile.in
index 727fd3ec3..e9f64542c 100644
--- a/tools/CoqMakefile.in
+++ b/tools/CoqMakefile.in
@@ -23,6 +23,7 @@ MLFILES := $(COQMF_MLFILES)
ML4FILES := $(COQMF_ML4FILES)
MLPACKFILES := $(COQMF_MLPACKFILES)
MLLIBFILES := $(COQMF_MLLIBFILES)
+CMDLINE_VFILES := $(COQMF_CMDLINE_VFILES)
INSTALLCOQDOCROOT := $(COQMF_INSTALLCOQDOCROOT)
OTHERFLAGS := $(COQMF_OTHERFLAGS)
COQ_SRC_SUBDIRS := $(COQMF_COQ_SRC_SUBDIRS)
@@ -30,6 +31,7 @@ OCAMLLIBS := $(COQMF_OCAMLLIBS)
SRC_SUBDIRS := $(COQMF_SRC_SUBDIRS)
COQLIBS := $(COQMF_COQLIBS)
COQLIBS_NOML := $(COQMF_COQLIBS_NOML)
+CMDLINE_COQLIBS := $(COQMF_CMDLINE_COQLIBS)
LOCAL := $(COQMF_LOCAL)
COQLIB := $(COQMF_COQLIB)
DOCDIR := $(COQMF_DOCDIR)
@@ -724,9 +726,14 @@ $(addsuffix .d,$(MLPACKFILES)): %.mlpack.d: %.mlpack
$(SHOW)'COQDEP $<'
$(HIDE)$(COQDEP) $(OCAMLLIBS) -c "$<" $(redir_if_ok)
+# If this makefile is created using a _CoqProject we have coqdep get
+# options from it. This avoids argument length limits for pathological
+# projects. Note that extra options might be on the command line.
+VDFILE_FLAGS:=$(if @PROJECT_FILE@,-f @PROJECT_FILE@,) $(CMDLINE_COQLIBS) $(CMDLINE_VFILES)
+
$(VDFILE).d: $(VFILES)
$(SHOW)'COQDEP VFILES'
- $(HIDE)$(COQDEP) $(COQLIBS) -dyndep var -c $(VFILES) $(redir_if_ok)
+ $(HIDE)$(COQDEP) -dyndep var $(VDFILE_FLAGS) $(redir_if_ok)
# Misc ########################################################################
diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml
index ef4428755..6cd520d60 100644
--- a/tools/coq_makefile.ml
+++ b/tools/coq_makefile.ml
@@ -13,6 +13,8 @@
open CoqProject_file
open Printf
+let (>) f g = fun x -> g (f x)
+
let output_channel = ref stdout
let makefile_name = ref "Makefile"
let make_name = ref ""
@@ -175,21 +177,22 @@ let generate_conf_extra_target oc sps =
in
if sps <> [] then
section oc "Extra targets. (-extra and -extra-phony, DEPRECATED)";
- List.iter pr_path sps
+ List.iter (forget_source > pr_path) sps
let generate_conf_subdirs oc sds =
if sds <> [] then section oc "Subdirectories. (DEPRECATED)";
- List.iter (fprintf oc ".PHONY:%s\n") sds;
- List.iter (fprintf oc "post-all::\n\tcd \"%s\" && $(MAKE) all\n") sds;
- List.iter (fprintf oc "clean::\n\tcd \"%s\" && $(MAKE) clean\n") sds;
- List.iter (fprintf oc "archclean::\n\tcd \"%s\" && $(MAKE) archclean\n") sds;
- List.iter (fprintf oc "install-extra::\n\tcd \"%s\" && $(MAKE) install\n") sds
+ let iter f = List.iter (forget_source > f) in
+ iter (fprintf oc ".PHONY:%s\n") sds;
+ iter (fprintf oc "post-all::\n\tcd \"%s\" && $(MAKE) all\n") sds;
+ iter (fprintf oc "clean::\n\tcd \"%s\" && $(MAKE) clean\n") sds;
+ iter (fprintf oc "archclean::\n\tcd \"%s\" && $(MAKE) archclean\n") sds;
+ iter (fprintf oc "install-extra::\n\tcd \"%s\" && $(MAKE) install\n") sds
let generate_conf_includes oc { ml_includes; r_includes; q_includes } =
section oc "Path directives (-I, -R, -Q).";
let module S = String in
- let open List in
+ let map = map_sourced_list in
let dash1 opt v = sprintf "-%s %s" opt (quote v) in
let dash2 opt v1 v2 = sprintf "-%s %s %s" opt (quote v1) (quote v2) in
fprintf oc "COQMF_OCAMLLIBS = %s\n"
@@ -202,7 +205,11 @@ let generate_conf_includes oc { ml_includes; r_includes; q_includes } =
(S.concat " " (map (fun ({ path },l) -> dash2 "R" path l) r_includes));
fprintf oc "COQMF_COQLIBS_NOML = %s %s\n"
(S.concat " " (map (fun ({ path },l) -> dash2 "Q" path l) q_includes))
- (S.concat " " (map (fun ({ path },l) -> dash2 "R" path l) r_includes))
+ (S.concat " " (map (fun ({ path },l) -> dash2 "R" path l) r_includes));
+ fprintf oc "COQMF_CMDLINE_COQLIBS = %s %s %s\n"
+ (S.concat " " (map_cmdline (fun { path } -> dash1 "I" path) ml_includes))
+ (S.concat " " (map_cmdline (fun ({ path },l) -> dash2 "Q" path l) q_includes))
+ (S.concat " " (map_cmdline (fun ({ path },l) -> dash2 "R" path l) r_includes));
;;
let windrive s =
@@ -219,10 +226,10 @@ let generate_conf_coq_config oc args =
;;
let generate_conf_files oc
- { v_files; mli_files; ml4_files; ml_files; mllib_files; mlpack_files }
+ { v_files; mli_files; ml4_files; ml_files; mllib_files; mlpack_files; }
=
let module S = String in
- let open List in
+ let map = map_sourced_list in
section oc "Project files.";
fprintf oc "COQMF_VFILES = %s\n" (S.concat " " (map quote v_files));
fprintf oc "COQMF_MLIFILES = %s\n" (S.concat " " (map quote mli_files));
@@ -230,6 +237,8 @@ let generate_conf_files oc
fprintf oc "COQMF_ML4FILES = %s\n" (S.concat " " (map quote ml4_files));
fprintf oc "COQMF_MLPACKFILES = %s\n" (S.concat " " (map quote mlpack_files));
fprintf oc "COQMF_MLLIBFILES = %s\n" (S.concat " " (map quote mllib_files));
+ let cmdline_vfiles = filter_cmdline v_files in
+ fprintf oc "COQMF_CMDLINE_VFILES = %s\n" (S.concat " " (List.map quote cmdline_vfiles));
;;
let rec all_start_with prefix = function
@@ -246,12 +255,12 @@ let rec logic_gcd acc = function
else acc
let generate_conf_doc oc { defs; q_includes; r_includes } =
- let includes = List.map snd (q_includes @ r_includes) in
+ let includes = List.map (forget_source > snd) (q_includes @ r_includes) in
let logpaths = List.map (CString.split '.') includes in
let gcd = logic_gcd [] logpaths in
let root =
if gcd = [] then
- if not (List.mem_assoc "INSTALLDEFAULTROOT" defs) then begin
+ if not (List.exists (fun x -> fst x.thing = "INSTALLDEFAULTROOT") defs) then begin
let destination = "orphan_" ^ (String.concat "_" includes) in
eprintf "Warning: no common logical root\n";
eprintf "Warning: in such case INSTALLDEFAULTROOT must be defined\n";
@@ -264,9 +273,9 @@ let generate_conf_doc oc { defs; q_includes; r_includes } =
let generate_conf_defs oc { defs; extra_args } =
section oc "Extra variables.";
- List.iter (fun (k,v) -> Printf.fprintf oc "%s = %s\n" k v) defs;
+ List.iter (forget_source > (fun (k,v) -> Printf.fprintf oc "%s = %s\n" k v)) defs;
Printf.fprintf oc "COQMF_OTHERFLAGS = %s\n"
- (String.concat " " extra_args)
+ (String.concat " " (List.map forget_source extra_args))
let generate_conf oc project args =
fprintf oc "# This configuration file was generated by running:\n";
@@ -284,10 +293,10 @@ let ensure_root_dir
({ ml_includes; r_includes; q_includes;
v_files; ml_files; mli_files; ml4_files;
mllib_files; mlpack_files } as project)
-=
- let open List in
+ =
+ let exists f = List.exists (forget_source > f) in
let here = Sys.getcwd () in
- let not_tops = List.for_all (fun s -> s <> Filename.basename s) in
+ let not_tops = List.for_all (fun s -> s.thing <> Filename.basename s.thing) in
if exists (fun { canonical_path = x } -> x = here) ml_includes
|| exists (fun ({ canonical_path = x },_) -> is_prefix x here) r_includes
|| exists (fun ({ canonical_path = x },_) -> is_prefix x here) q_includes
@@ -297,29 +306,27 @@ let ensure_root_dir
then
project
else
+ let source x = {thing=x; source=CmdLine} in
let here_path = { path = "."; canonical_path = here } in
{ project with
- ml_includes = here_path :: ml_includes;
- r_includes = (here_path, "Top") :: r_includes }
+ ml_includes = source here_path :: ml_includes;
+ r_includes = source (here_path, "Top") :: r_includes }
;;
let warn_install_at_root_directory
- { q_includes; r_includes;
- v_files; ml_files; mli_files; ml4_files;
- mllib_files; mlpack_files }
+ ({ q_includes; r_includes; } as project)
=
let open CList in
let inc_top_p =
map_filter
- (fun ({ path } ,ldir) -> if ldir = "" then Some path else None)
+ (fun {thing=({ path } ,ldir)} -> if ldir = "" then Some path else None)
(r_includes @ q_includes) in
- let files =
- v_files @ mli_files @ ml4_files @ ml_files @ mllib_files @ mlpack_files in
- let bad = filter (fun f -> mem (Filename.dirname f) inc_top_p) files in
+ let files = all_files project in
+ let bad = filter (fun f -> mem (Filename.dirname f.thing) inc_top_p) files in
if bad <> [] then begin
eprintf "Warning: No file should be installed at the root of Coq's library.\n";
eprintf "Warning: No logical path (-R, -Q) applies to these files:\n";
- List.iter (fun x -> eprintf "Warning: %s\n" x) bad;
+ List.iter (fun x -> eprintf "Warning: %s\n" x.thing) bad;
eprintf "\n";
end
;;
@@ -328,10 +335,10 @@ let check_overlapping_include { q_includes; r_includes } =
let pwd = Sys.getcwd () in
let aux = function
| [] -> ()
- | ({ path; canonical_path }, _) :: l ->
+ | {thing = { path; canonical_path }, _} :: l ->
if not (is_prefix pwd canonical_path) then
eprintf "Warning: %s (used in -R or -Q) is not a subdirectory of the current directory\n\n" path;
- List.iter (fun ({ path = p; canonical_path = cp }, _) ->
+ List.iter (fun {thing={ path = p; canonical_path = cp }, _} ->
if is_prefix canonical_path cp || is_prefix cp canonical_path then
eprintf "Warning: %s and %s overlap (used in -R or -Q)\n\n"
path p) l
@@ -354,7 +361,7 @@ let destination_of { ml_includes; q_includes; r_includes; } file =
clean_path (physical_dir_of_logical_dir logic ^ "/" ^
chop_prefix canonical_path file_dir ^ "/") in
let candidates =
- CList.map_filter (fun ({ canonical_path }, logic) ->
+ CList.map_filter (fun {thing={ canonical_path }, logic} ->
if is_prefix canonical_path file_dir then
Some(mk_destination logic canonical_path)
else None) includes
@@ -364,10 +371,10 @@ let destination_of { ml_includes; q_includes; r_includes; } file =
(* BACKWARD COMPATIBILITY: -I into the only logical root *)
begin match
r_includes,
- List.find (fun { canonical_path = p } -> is_prefix p file_dir)
+ List.find (fun {thing={ canonical_path = p }} -> is_prefix p file_dir)
ml_includes
with
- | [{ canonical_path }, logic], { canonical_path = p } ->
+ | [{thing={ canonical_path }, logic}], {thing={ canonical_path = p }} ->
let destination =
clean_path (physical_dir_of_logical_dir logic ^ "/" ^
chop_prefix p file_dir ^ "/") in
diff --git a/tools/coqc.ml b/tools/coqc.ml
index 3181ef910..90d8e67c1 100644
--- a/tools/coqc.ml
+++ b/tools/coqc.ml
@@ -111,7 +111,7 @@ let parse_args () =
|"-load-ml-source"|"-require"|"-load-ml-object"
|"-init-file"|"-dump-glob"|"-compat"|"-coqlib"|"-top"
|"-async-proofs-j" |"-async-proofs-private-flags" |"-async-proofs" |"-w"
- |"-o"|"-profile-ltac-cutoff"
+ |"-o"|"-profile-ltac-cutoff"|"-mangle-names"
as o) :: rem ->
begin
match rem with
diff --git a/tools/coqdep.ml b/tools/coqdep.ml
index f4f143b3b..12b5cab0a 100644
--- a/tools/coqdep.ml
+++ b/tools/coqdep.ml
@@ -446,6 +446,7 @@ let usage () =
eprintf " -boot : For coq developers, prints dependencies over coq library files (omitted by default).\n";
eprintf " -sort : output the given file name ordered by dependencies\n";
eprintf " -noglob | -no-glob : \n";
+ eprintf " -f file : read -I, -Q, -R and filenames from _CoqProject-formatted FILE.";
eprintf " -I dir -as logname : add (non recursively) dir to coq load path under logical name logname\n";
eprintf " -I dir : add (non recursively) dir to ocaml path\n";
eprintf " -R dir -as logname : add and import dir recursively to coq load path under logical name logname\n"; (* deprecate? *)
@@ -462,6 +463,19 @@ let usage () =
let split_period = Str.split (Str.regexp (Str.quote "."))
+let add_q_include path l = add_rec_dir_no_import add_known path (split_period l)
+
+let add_r_include path l = add_rec_dir_import add_known path (split_period l)
+
+let treat_coqproject f =
+ let open CoqProject_file in
+ let iter_sourced f = List.iter (fun {thing} -> f thing) in
+ let project = read_project_file f in
+ iter_sourced (fun { path } -> add_caml_dir path) project.ml_includes;
+ iter_sourced (fun ({ path }, l) -> add_q_include path l) project.q_includes;
+ iter_sourced (fun ({ path }, l) -> add_r_include path l) project.r_includes;
+ iter_sourced (fun f -> treat_file None f) (all_files project)
+
let rec parse = function
| "-c" :: ll -> option_c := true; parse ll
| "-D" :: ll -> option_D := true; parse ll
@@ -469,10 +483,11 @@ let rec parse = function
| "-boot" :: ll -> option_boot := true; parse ll
| "-sort" :: ll -> option_sort := true; parse ll
| ("-noglob" | "-no-glob") :: ll -> option_noglob := true; parse ll
+ | "-f" :: f :: ll -> treat_coqproject f; parse ll
| "-I" :: r :: ll -> add_caml_dir r; parse ll
| "-I" :: [] -> usage ()
- | "-R" :: r :: ln :: ll -> add_rec_dir_import add_known r (split_period ln); parse ll
- | "-Q" :: r :: ln :: ll -> add_rec_dir_no_import add_known r (split_period ln); parse ll
+ | "-R" :: r :: ln :: ll -> add_r_include r ln; parse ll
+ | "-Q" :: r :: ln :: ll -> add_q_include r ln; parse ll
| "-R" :: ([] | [_]) -> usage ()
| "-dumpgraph" :: f :: ll -> option_dump := Some (false, f); parse ll
| "-dumpgraphbox" :: f :: ll -> option_dump := Some (true, f); parse ll
diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml
index 06b2ba41b..a1a07fce8 100644
--- a/toplevel/coqargs.ml
+++ b/toplevel/coqargs.ml
@@ -271,6 +271,11 @@ let get_cache opt = function
| "force" -> Some Stm.AsyncOpts.Force
| _ -> prerr_endline ("Error: force expected after "^opt); exit 1
+let get_identifier opt s =
+ try Names.Id.of_string s
+ with CErrors.UserError _ ->
+ prerr_endline ("Error: valid identifier expected after option "^opt); exit 1
+
let is_not_dash_option = function
| Some f when String.length f > 0 && f.[0] <> '-' -> true
| _ -> false
@@ -466,6 +471,9 @@ let parse_args arglist : coq_cmdopts * string list =
|"-load-vernac-source-verbose"|"-lv" ->
add_load_vernacular oval true (next ())
+ |"-mangle-names" ->
+ Namegen.set_mangle_names_mode (get_identifier opt (next ())); oval
+
|"-print-mod-uid" ->
let s = String.concat " " (List.map get_native_name rem) in print_endline s; exit 0
diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml
index 1da46e8ce..a103cfe7f 100644
--- a/toplevel/coqloop.ml
+++ b/toplevel/coqloop.ml
@@ -341,6 +341,22 @@ 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
+let cproof p1 p2 =
+ let (a1,a2,a3,a4,_),(b1,b2,b3,b4,_) = Proof.proof p1, Proof.proof p2 in
+ evleq a1 b1 &&
+ CList.equal (pequal evleq evleq) a2 b2 &&
+ CList.equal Evar.equal a3 b3 &&
+ CList.equal Evar.equal a4 b4
+
let drop_last_doc = ref None
let rec loop ~time ~state =
@@ -351,6 +367,10 @@ let rec loop ~time ~state =
(* Be careful to keep this loop tail-recursive *)
let rec vernac_loop ~state =
let nstate = do_vernac ~time ~state in
+ let proof_changed = not (Option.equal cproof nstate.proof state.proof) 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 ());
loop_flush_all ();
vernac_loop ~state:nstate
(* We recover the current stateid, threading from the caller is
diff --git a/toplevel/usage.ml b/toplevel/usage.ml
index 07553a2ab..504ffa521 100644
--- a/toplevel/usage.ml
+++ b/toplevel/usage.ml
@@ -79,6 +79,7 @@ let print_usage_channel co command =
\n -impredicative-set set sort Set impredicative\
\n -indices-matter levels of indices (and nonuniform parameters) contribute to the level of inductives\
\n -type-in-type disable universe consistency checking\
+\n -mangle-names x mangle auto-generated names using prefix x\
\n -time display the time taken by each command\
\n -profile-ltac display the time taken by each (sub)tactic\
\n -m, --memory display total heap size at program exit\
diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml
index 7c889500a..56bdcc7e5 100644
--- a/toplevel/vernac.ml
+++ b/toplevel/vernac.ml
@@ -70,12 +70,6 @@ let print_cmd_header ?loc com =
Pp.pp_with !Topfmt.std_ft (pp_cmd_header ?loc com);
Format.pp_print_flush !Topfmt.std_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 ""
-
(* Reenable when we get back to feedback printing *)
(* let is_end_of_input any = match any with *)
(* Stm.End_of_input -> true *)
@@ -94,23 +88,8 @@ end
let interp_vernac ~time ~check ~interactive ~state (loc,com) =
let open State in
try
- (* XXX: We need to run this before add as the classification is
- highly dynamic and depends on the structure of the
- document. Hopefully this is fixed when VtMeta can be removed
- and Undo etc... are just interpreted regularly. *)
-
- (* XXX: The classifier can emit warnings so we need to guard
- against that... *)
- let wflags = CWarnings.get_flags () in
- CWarnings.set_flags "none";
- let is_proof_step = match fst (Vernac_classifier.classify_vernac com) with
- | VtProofStep _ | VtMeta | VtStartProof _ -> true
- | _ -> false
- in
- CWarnings.set_flags wflags;
-
- (* The -time option is only supported from console-based
- clients due to the way it prints. *)
+ (* The -time option is only supported from console-based clients
+ due to the way it prints. *)
if time then print_cmd_header ?loc com;
let com = if time then VernacTime(time,(CAst.make ?loc com)) else com in
let doc, nsid, ntip = Stm.add ~doc:state.doc ~ontop:state.sid (not !Flags.quiet) (loc,com) in
@@ -123,14 +102,6 @@ let interp_vernac ~time ~check ~interactive ~state (loc,com) =
it otherwise reveals bugs *)
(* Stm.observe nsid; *)
let ndoc = if check then Stm.finish ~doc else doc in
-
- (* We could use a more refined criteria that depends on the
- vernac. For now we imitate the old approach and rely on the
- classification. *)
- let print_goals = interactive && not !Flags.quiet &&
- is_proof_step && Proof_global.there_are_pending_proofs () in
-
- if print_goals then Feedback.msg_notice (pr_open_cur_subgoals ());
let new_proof = Proof_global.give_me_the_proof_opt () in
{ doc = ndoc; sid = nsid; proof = new_proof }
with reraise ->
diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml
index 9b7b88b51..2879feba7 100644
--- a/vernac/auto_ind_decl.ml
+++ b/vernac/auto_ind_decl.ml
@@ -323,7 +323,7 @@ let build_beq_scheme mode kn =
raise NoDecidabilityCoInductive;
let fix = mkFix (((Array.make nb_ind 0),i),(names,types,cores)) in
create_input fix),
- Evd.make_evar_universe_context (Global.env ()) None),
+ UState.make (Global.universes ())),
!eff
let beq_scheme_kind = declare_mutual_scheme_object "_beq" build_beq_scheme
@@ -671,7 +671,7 @@ let make_bl_scheme mode mind =
let lnonparrec,lnamesparrec = (* TODO subst *)
context_chop (nparams-nparrec) mib.mind_params_ctxt in
let bl_goal, eff = compute_bl_goal ind lnamesparrec nparrec in
- let ctx = Evd.make_evar_universe_context (Global.env ()) None in
+ let ctx = UState.make (Global.universes ()) in
let side_eff = side_effect_of_mode mode in
let bl_goal = EConstr.of_constr bl_goal in
let (ans, _, ctx) = Pfedit.build_by_tactic ~side_eff (Global.env()) ctx bl_goal
@@ -795,7 +795,7 @@ let make_lb_scheme mode mind =
let lnonparrec,lnamesparrec =
context_chop (nparams-nparrec) mib.mind_params_ctxt in
let lb_goal, eff = compute_lb_goal ind lnamesparrec nparrec in
- let ctx = Evd.make_evar_universe_context (Global.env ()) None in
+ let ctx = UState.make (Global.universes ()) in
let side_eff = side_effect_of_mode mode in
let lb_goal = EConstr.of_constr lb_goal in
let (ans, _, ctx) = Pfedit.build_by_tactic ~side_eff (Global.env()) ctx lb_goal
@@ -965,7 +965,7 @@ let make_eq_decidability mode mind =
let nparams = mib.mind_nparams in
let nparrec = mib.mind_nparams_rec in
let u = Univ.Instance.empty in
- let ctx = Evd.make_evar_universe_context (Global.env ()) None in
+ let ctx = UState.make (Global.universes ()) in
let lnonparrec,lnamesparrec =
context_chop (nparams-nparrec) mib.mind_params_ctxt in
let side_eff = side_effect_of_mode mode in
diff --git a/vernac/classes.ml b/vernac/classes.ml
index 25d893bfb..192cc8a55 100644
--- a/vernac/classes.ml
+++ b/vernac/classes.ml
@@ -374,16 +374,34 @@ let context poly l =
with e when CErrors.noncritical e ->
user_err Pp.(str "Anonymous variables not allowed in contexts.")
in
- let uctx = ref (Evd.universe_context_set sigma) in
+ let univs =
+ let uctx = Evd.universe_context_set sigma in
+ match ctx with
+ | [] -> assert false
+ | [_] ->
+ if poly
+ then Polymorphic_const_entry (Univ.ContextSet.to_context uctx)
+ else Monomorphic_const_entry uctx
+ | _::_::_ ->
+ if Lib.sections_are_opened ()
+ then
+ begin
+ Declare.declare_universe_context poly uctx;
+ if poly then Polymorphic_const_entry Univ.UContext.empty
+ else Monomorphic_const_entry Univ.ContextSet.empty
+ end
+ else if poly
+ then Polymorphic_const_entry (Univ.ContextSet.to_context uctx)
+ else
+ begin
+ Declare.declare_universe_context poly uctx;
+ Monomorphic_const_entry Univ.ContextSet.empty
+ end
+ in
let fn status (id, b, t) =
let b, t = Option.map (to_constr sigma) b, to_constr sigma t in
if Lib.is_modtype () && not (Lib.sections_are_opened ()) then
(* Declare the universe context once *)
- let univs = if poly
- then Polymorphic_const_entry (Univ.ContextSet.to_context !uctx)
- else Monomorphic_const_entry !uctx
- in
- let () = uctx := Univ.ContextSet.empty in
let decl = match b with
| None ->
(ParameterEntry (None,(t,univs),None), IsAssumption Logical)
@@ -405,10 +423,6 @@ let context poly l =
in
let impl = List.exists test impls in
let decl = (Discharge, poly, Definitional) in
- let univs = if poly
- then Polymorphic_const_entry (Univ.ContextSet.to_context !uctx)
- else Monomorphic_const_entry !uctx
- in
let nstatus = match b with
| None ->
pi3 (ComAssumption.declare_assumption false decl (t, univs) Universes.empty_binders [] impl
@@ -422,6 +436,4 @@ let context poly l =
in
status && nstatus
in
- if Lib.sections_are_opened () then
- Declare.declare_universe_context poly !uctx;
List.fold_left fn true (List.rev ctx)
diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml
index 1712634da..6a590758f 100644
--- a/vernac/comAssumption.ml
+++ b/vernac/comAssumption.ml
@@ -160,7 +160,7 @@ let do_assumptions kind nl l =
in
let sigma = solve_remaining_evars all_and_fail_flags env sigma Evd.empty in
(* The universe constraints come from the whole telescope. *)
- let sigma = Evd.nf_constraints sigma in
+ let sigma = Evd.minimize_universes sigma in
let nf_evar c = EConstr.to_constr sigma c in
let uvars, l = List.fold_left_map (fun uvars (coe,t,imps) ->
let t = nf_evar t in
diff --git a/vernac/comAssumption.mli b/vernac/comAssumption.mli
index f235de350..56e324376 100644
--- a/vernac/comAssumption.mli
+++ b/vernac/comAssumption.mli
@@ -19,7 +19,7 @@ open Decl_kinds
(** {6 Parameters/Assumptions} *)
val do_assumptions : locality * polymorphic * assumption_object_kind ->
- Vernacexpr.inline -> (Vernacexpr.ident_decl list * constr_expr) with_coercion list -> bool
+ Vernacexpr.inline -> (ident_decl list * constr_expr) with_coercion list -> bool
(************************************************************************)
(** Internal API *)
diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml
index 01dbe0a0d..b18a60a1f 100644
--- a/vernac/comDefinition.ml
+++ b/vernac/comDefinition.ml
@@ -85,7 +85,7 @@ let interp_definition pl bl poly red_option c ctypopt =
evd, c, imps1@Impargs.lift_implicits (Context.Rel.nhyps ctx) impsty, Some ty
in
(* universe minimization *)
- let evd = Evd.nf_constraints evd in
+ let evd = Evd.minimize_universes evd in
(* Substitute evars and universes, and add parameters.
Note: in program mode some evars may remain. *)
let ctx = List.map (EConstr.to_rel_decl evd) ctx in
diff --git a/vernac/comDefinition.mli b/vernac/comDefinition.mli
index 0d6367291..6f81c4575 100644
--- a/vernac/comDefinition.mli
+++ b/vernac/comDefinition.mli
@@ -17,7 +17,7 @@ open Constrexpr
(** {6 Definitions/Let} *)
val do_definition : program_mode:bool ->
- Id.t -> definition_kind -> Vernacexpr.universe_decl_expr option ->
+ Id.t -> definition_kind -> universe_decl_expr option ->
local_binder_expr list -> red_expr option -> constr_expr ->
constr_expr option -> unit Lemmas.declaration_hook -> unit
@@ -27,6 +27,6 @@ val do_definition : program_mode:bool ->
(** Not used anywhere. *)
val interp_definition :
- Vernacexpr.universe_decl_expr option -> local_binder_expr list -> polymorphic -> red_expr option -> constr_expr ->
+ universe_decl_expr option -> local_binder_expr list -> polymorphic -> red_expr option -> constr_expr ->
constr_expr option -> Safe_typing.private_constants definition_entry * Evd.evar_map *
Univdecls.universe_decl * Impargs.manual_implicits
diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml
index edfe7aa81..a794c2db0 100644
--- a/vernac/comFixpoint.ml
+++ b/vernac/comFixpoint.ml
@@ -14,7 +14,6 @@ open Pretyping
open Evarutil
open Evarconv
open Misctypes
-open Vernacexpr
module RelDecl = Context.Rel.Declaration
diff --git a/vernac/comFixpoint.mli b/vernac/comFixpoint.mli
index b181984e0..36c2993af 100644
--- a/vernac/comFixpoint.mli
+++ b/vernac/comFixpoint.mli
@@ -32,7 +32,7 @@ val do_cofixpoint :
type structured_fixpoint_expr = {
fix_name : Id.t;
- fix_univs : Vernacexpr.universe_decl_expr option;
+ fix_univs : Constrexpr.universe_decl_expr option;
fix_annot : Misctypes.lident option;
fix_binders : local_binder_expr list;
fix_body : constr_expr option;
diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml
index 457a1da05..c59286d1a 100644
--- a/vernac/comInductive.ml
+++ b/vernac/comInductive.ml
@@ -57,7 +57,7 @@ let push_types env idl tl =
type structured_one_inductive_expr = {
ind_name : Id.t;
- ind_univs : Vernacexpr.universe_decl_expr option;
+ ind_univs : universe_decl_expr option;
ind_arity : constr_expr;
ind_lc : (Id.t * constr_expr) list
}
diff --git a/vernac/comInductive.mli b/vernac/comInductive.mli
index b8d85c8d9..833935724 100644
--- a/vernac/comInductive.mli
+++ b/vernac/comInductive.mli
@@ -47,7 +47,7 @@ val declare_mutual_inductive_with_eliminations :
type structured_one_inductive_expr = {
ind_name : Id.t;
- ind_univs : Vernacexpr.universe_decl_expr option;
+ ind_univs : universe_decl_expr option;
ind_arity : constr_expr;
ind_lc : (Id.t * constr_expr) list
}
diff --git a/vernac/himsg.ml b/vernac/himsg.ml
index c839ed0c7..131b1fab6 100644
--- a/vernac/himsg.ml
+++ b/vernac/himsg.ml
@@ -425,7 +425,7 @@ let explain_ill_formed_rec_body env sigma err names i fixenv vdefj =
str "Not enough abstractions in the definition"
| RecursionNotOnInductiveType c ->
str "Recursive definition on" ++ spc () ++ pr_lconstr_env env sigma c ++
- spc () ++ str "which should be an inductive type"
+ spc () ++ str "which should be a recursive inductive type"
| RecursionOnIllegalTerm(j,(arg_env, arg),le,lt) ->
let arg_env = make_all_name_different arg_env sigma in
let called =
diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml
index 779926a7d..27587416b 100644
--- a/vernac/indschemes.ml
+++ b/vernac/indschemes.ml
@@ -61,13 +61,6 @@ let _ =
optkey = ["Nonrecursive";"Elimination";"Schemes"];
optread = (fun () -> !bifinite_elim_flag) ;
optwrite = (fun b -> bifinite_elim_flag := b) }
-let _ =
- declare_bool_option
- { optdepr = true; (* compatibility 2014-09-03*)
- optname = "automatic declaration of induction schemes for non-recursive types";
- optkey = ["Record";"Elimination";"Schemes"];
- optread = (fun () -> !bifinite_elim_flag) ;
- optwrite = (fun b -> bifinite_elim_flag := b) }
let case_flag = ref false
let _ =
@@ -388,7 +381,7 @@ let do_mutual_induction_scheme lnamedepindsort =
| None ->
let _, ctx = Global.type_of_global_in_context env0 (IndRef ind) in
let u, ctx = Universes.fresh_instance_from ctx None in
- let evd = Evd.from_ctx (Evd.evar_universe_context_of ctx) in
+ let evd = Evd.from_ctx (UState.of_context_set ctx) in
evd, (ind,u), Some u
| Some ui -> evd, (ind, ui), inst
in
diff --git a/vernac/obligations.ml b/vernac/obligations.ml
index 6447fc350..4f16e1cf6 100644
--- a/vernac/obligations.ml
+++ b/vernac/obligations.ml
@@ -472,7 +472,7 @@ let subst_body expand prg =
let declare_definition prg =
let body, typ = subst_body true prg in
let nf = Universes.nf_evars_and_universes_opt_subst (fun x -> None)
- (Evd.evar_universe_context_subst prg.prg_ctx) in
+ (UState.subst prg.prg_ctx) in
let opaque = prg.prg_opaque in
let fix_exn = Hook.get get_fix_exn () in
let typ = nf typ in
diff --git a/vernac/record.ml b/vernac/record.ml
index 1991a8640..e21f53f55 100644
--- a/vernac/record.ml
+++ b/vernac/record.ml
@@ -124,7 +124,7 @@ let typecheck_params_and_fields finite def id poly pl t ps nots fs =
match t with
| { CAst.v = CSort (Misctypes.GType []) } -> true | _ -> false in
let sigma, s = interp_type_evars env sigma ~impls:empty_internalization_env t in
- let sred = Reductionops.whd_all env sigma s in
+ let sred = Reductionops.whd_allnolet env sigma s in
(match EConstr.kind sigma sred with
| Sort s' ->
let s' = EConstr.ESorts.kind sigma s' in
diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml
index 0ff6d9c17..4c9b41b21 100644
--- a/vernac/vernacentries.ml
+++ b/vernac/vernacentries.ml
@@ -66,13 +66,13 @@ let show_proof () =
let show_top_evars () =
(* spiwack: new as of Feb. 2010: shows goal evars in addition to non-goal evars. *)
let pfts = Proof_global.give_me_the_proof () in
- let gls,_,_,_,sigma = Proof.proof pfts in
- pr_evars_int sigma 1 (Evd.undefined_map sigma)
+ let gls,_,shelf,givenup,sigma = Proof.proof pfts in
+ pr_evars_int sigma ~shelf ~givenup 1 (Evd.undefined_map sigma)
let show_universes () =
let pfts = Proof_global.give_me_the_proof () in
let gls,_,_,_,sigma = Proof.proof pfts in
- let ctx = Evd.universe_context_set (Evd.nf_constraints sigma) in
+ let ctx = Evd.universe_context_set (Evd.minimize_universes sigma) in
Termops.pr_evar_universe_context (Evd.evar_universe_context sigma) ++ fnl () ++
str "Normalized constraints: " ++ Univ.pr_universe_context_set (Termops.pr_evd_level sigma) ctx
@@ -805,7 +805,14 @@ let vernac_end_segment ({v=id} as lid) =
(* Libraries *)
+let warn_require_in_section =
+ let name = "require-in-section" in
+ let category = "deprecated" in
+ CWarnings.create ~name ~category
+ (fun () -> strbrk "Use of “Require” inside a section is deprecated.")
+
let vernac_require from import qidl =
+ if Lib.sections_are_opened () then warn_require_in_section ();
let qidl = List.map qualid_of_reference qidl in
let root = match from with
| None -> None