diff options
106 files changed, 3117 insertions, 7690 deletions
diff --git a/.circleci/config.yml b/.circleci/config.yml new file mode 100644 index 0000000000..c49bc3b08b --- /dev/null +++ b/.circleci/config.yml @@ -0,0 +1,404 @@ +defaults: + params: ¶ms + # Following parameters are used in Coq CircleCI Job (using yaml + # reference syntax) + working_directory: ~/coq + docker: + - image: ocaml/opam:ubuntu + + environment: &envvars + # required by some of the targets, e.g. compcert, passed for + # instance to opam to configure the number of parallel jobs + # allowed + NJOBS: 2 + COMPILER: "system" + CAMLP5_VER: "6.14" + NATIVE_COMP: "yes" + + # some useful values + COMPILER_32BIT: &compiler-32bit "4.02.3+32bit" + + COMPILER_BLEEDING_EDGE: &compiler-be "4.06.0" + CAMLP5_VER_BLEEDING_EDGE: &camlp5-ver-be "7.03" + + TIMING_PACKAGES: &timing-packages "time python" + + COQIDE_PACKAGES: &coqide-packages "libgtk2.0-dev libgtksourceview2.0-dev" + #COQIDE_PACKAGES_32BIT: "libgtk2.0-dev:i386 libgtksourceview2.0-dev:i386" + COQIDE_OPAM: &coqide-opam "lablgtk-extras" + COQIDE_OPAM_BE: &coqide-opam-be "num lablgtk.2.18.6 lablgtk-extras.1.6" + COQDOC_PACKAGES: &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: &coqdoc-opam "hevea" + +version: 2 + +before_script: &before_script + name: Install system packages + command: | + echo export TERM=xterm >> ~/.profile + source ~/.profile + printenv + #if [ "$COMPILER" = "$COMPILER_32BIT" ]; then sudo dpkg --add-architecture i386; fi + if [ -n "${EXTRA_PACKAGES}" ]; then sudo apt-get update -yq && sudo apt-get install -yq --no-install-recommends ${EXTRA_PACKAGES}; fi + +opam-switch: &opam-switch + name: Select opam switch + command: | + source ~/.profile + opam switch ${COMPILER} + opam config list + opam list + +.opam-boot-template: &opam-boot-template + <<: *params + steps: + - checkout + - run: *before_script + - restore_cache: + keys: + - coq-opam-cache-v1-{{ arch }}-{{ .Environment.COMPILER }}-{{ checksum ".circleci/config.yml" }}- + - coq-opam-cache-v1-{{ arch }}-{{ .Environment.COMPILER }}- # this grabs old cache if checksum doesn't match + - run: + name: Update opam lists + command: | + source ~/.profile + opam repository set-url default https://opam.ocaml.org + opam update + - run: + name: Install opam packages + command: | + source ~/.profile + opam switch -j ${NJOBS} ${COMPILER} + opam install -j ${NJOBS} -y camlp5.${CAMLP5_VER} ocamlfind ${COQIDE_OPAM} ${COQDOC_OPAM} ${EXTRA_OPAM} + - run: + name: Clean cache + command: | + source ~/.profile + rm -rf ~/.opam/log/ + - save_cache: + key: coq-opam-cache-v1-{{ arch }}-{{ .Environment.COMPILER }}-{{ checksum ".circleci/config.yml" }}- + paths: + - ~/.opam + - persist_to_workspace: + root: &workspace ~/ + paths: + - .opam/ + +.build-template: &build-template + <<: *params + steps: + - checkout + - run: *before_script + - attach_workspace: &attach_workspace + at: *workspace + - run: *opam-switch + - run: &build-configure + name: Configure + command: | + source ~/.profile + + ./configure -local -native-compiler ${NATIVE_COMP} ${EXTRA_CONF} + - run: &build-build + name: Build + command: | + source ~/.profile + make -j ${NJOBS} byte + make -j ${NJOBS} + make test-suite/misc/universes/all_stdlib.v + - persist_to_workspace: + root: *workspace + paths: + - coq/ + + environment: &build-variables + <<: *envvars + EXTRA_CONF: "-coqide opt" + EXTRA_PACKAGES: *coqide-packages + +.validate-template: &validate-template + <<: *params + steps: + - run: *before_script + - attach_workspace: *attach_workspace + - run: + name: Validate + command: | + source ~/.profile + make validate + environment: *envvars + +.documentation-template: &documentation-template + <<: *params + steps: + - run: *before_script + - attach_workspace: *attach_workspace + - run: + name: Documentation + command: | + source ~/.profile + make -j ${NJOBS} doc + environment: &documentation-variables + <<: *envvars + EXTRA_PACKAGES: *coqdoc-packages + +.test-suite-template: &test-suite-template + <<: *params + steps: + - run: *before_script + - attach_workspace: *attach_workspace + - run: + name: Test + command: | + source ~/.profile + cd test-suite + make clean + make -j ${NJOBS} all + environment: &test-suite-variables + <<: *envvars + EXTRA_PACKAGES: *timing-packages + +.ci-template: &ci-template + <<: *params + steps: + - run: *before_script + - attach_workspace: *attach_workspace + - run: + name: Test + command: | + source ~/.profile + dev/ci/ci-wrapper.sh ${CIRCLE_JOB} + - persist_to_workspace: + root: *workspace + paths: + - coq/ + environment: &ci-template-vars + <<: *envvars + EXTRA_PACKAGES: *timing-packages + +# Defines individual jobs, see the workflows section below for job orchestration +jobs: + # TODO: linter + + opam-boot: + <<: *opam-boot-template + environment: + <<: *envvars + EXTRA_PACKAGES: *coqide-packages + EXTRA_OPAM: "ocamlgraph" + + opam-boot-32bit: + <<: *opam-boot-template + environment: + <<: *envvars + EXTRA_PACKAGES: "gcc-multilib" + COMPILER: *compiler-32bit + COQIDE_OPAM: "" + COQDOC_OPAM: "" + + opam-boot-be: + <<: *opam-boot-template + environment: + <<: *envvars + EXTRA_PACKAGES: *coqide-packages + COMPILER: *compiler-be + CAMLP5_VER: *camlp5-ver-be + COQIDE_OPAM: *coqide-opam-be + + # Build and prepare test environment + build: *build-template + + build-32bit: + <<: *build-template + environment: + <<: *envvars # no coqide for 32bit + EXTRA_PACKAGES: "gcc-multilib" + COMPILER: *compiler-32bit + + build-be: + <<: *build-template + environment: + <<: *build-variables + COMPILER: *compiler-be + + validate: *validate-template + + validate-32bit: + <<: *validate-template + environment: + <<: *envvars + COMPILER: *compiler-32bit + EXTRA_PACKAGES: "gcc-multilib" + + documentation: *documentation-template + + documentation-be: + <<: *documentation-template + environment: + <<: *documentation-variables + COMPILER: *compiler-be + CAMLP5_VER: *camlp5-ver-be + + test-suite: + <<: *test-suite-template + + test-suite-32bit: + <<: *test-suite-template + environment: + <<: *test-suite-variables + COMPILER: *compiler-32bit + EXTRA_PACKAGES: "gcc-multilib time python" + + test-suite-be: + <<: *test-suite-template + environment: + <<: *test-suite-variables + COMPILER: *compiler-be + EXTRA_PACKAGES: *timing-packages + + bignums: + <<: *ci-template + + color: + <<: *ci-template + environment: + <<: *ci-template-vars + EXTRA_PACKAGES: *timing-packages + + compcert: + <<: *ci-template + + coq-dpdgraph: + <<: *ci-template + environment: + <<: *ci-template-vars + EXTRA_PACKAGES: "time python autoconf automake" + + coquelicot: + <<: *ci-template + environment: + <<: *ci-template-vars + EXTRA_PACKAGES: "time python autoconf automake" + + equations: + <<: *ci-template + + geocoq: + <<: *ci-template + + fiat-crypto: + <<: *ci-template + + fiat-parsers: + <<: *ci-template + environment: + <<: *ci-template-vars + EXTRA_PACKAGES: *timing-packages + + flocq: + <<: *ci-template + environment: + <<: *ci-template-vars + EXTRA_PACKAGES: "time python autoconf automake" + + math-classes: + <<: *ci-template + + corn: + <<: *ci-template + + formal-topology: + <<: *ci-template + + hott: + <<: *ci-template + environment: + <<: *ci-template-vars + EXTRA_PACKAGES: "time python autoconf automake" + + iris-lambda-rust: + <<: *ci-template + + ltac2: + <<: *ci-template + + math-comp: + <<: *ci-template + + sf: + <<: *ci-template + environment: + <<: *ci-template-vars + EXTRA_PACKAGES: "time python wget" + + unimath: + <<: *ci-template + + vst: + <<: *ci-template + +workflows: + version: 2 + # Run on each push + main: + jobs: + - opam-boot + - opam-boot-32bit + - opam-boot-be + + - build: + requires: + - opam-boot + - validate: &req-main + requires: + - build + - test-suite: *req-main + - documentation: *req-main + + - bignums: *req-main + - color: + requires: + - build + - bignums + - compcert: *req-main + - coq-dpdgraph: *req-main + - coquelicot: *req-main + - equations: *req-main + - geocoq: *req-main + - fiat-crypto: *req-main + - fiat-parsers: *req-main + - flocq: *req-main + - math-classes: + requires: + - build + - bignums + - corn: + requires: + - build + - math-classes + - formal-topology: + requires: + - build + - corn + - hott: *req-main + - iris-lambda-rust: *req-main + - ltac2: *req-main + - math-comp: *req-main + - sf: *req-main + - unimath: *req-main + - vst: *req-main + + - build-32bit: + requires: + - opam-boot-32bit + - validate-32bit: &req-32bit + requires: + - build-32bit + - test-suite-32bit: *req-32bit + + - build-be: + requires: + - opam-boot-be + - test-suite-be: &req-be + requires: + - build-be + - documentation-be: *req-be diff --git a/.travis.yml b/.travis.yml index 54e7754f21..0bc43c1104 100644 --- a/.travis.yml +++ b/.travis.yml @@ -46,29 +46,29 @@ env: - TEST_TARGET="validate" TW="travis_wait" - TEST_TARGET="validate" COMPILER="4.02.3+32bit" TW="travis_wait" - TEST_TARGET="validate" COMPILER="${COMPILER_BE}+flambda" CAMLP5_VER="${CAMLP5_VER_BE}" NATIVE_COMP="no" EXTRA_CONF="-flambda-opts -O3" EXTRA_OPAM="num" FINDLIB_VER="${FINDLIB_VER_BE}" - - TEST_TARGET="ci-bignums TIMED=1" - - TEST_TARGET="ci-color TIMED=1" - - TEST_TARGET="ci-compcert TIMED=1" + - TEST_TARGET="ci-bignums" + - TEST_TARGET="ci-color" + - TEST_TARGET="ci-compcert" - TEST_TARGET="ci-coq-dpdgraph" EXTRA_OPAM="ocamlgraph" - - TEST_TARGET="ci-coquelicot TIMED=1" - - TEST_TARGET="ci-equations TIMED=1" - - TEST_TARGET="ci-geocoq TIMED=1" - - TEST_TARGET="ci-fiat-crypto TIMED=1" - - TEST_TARGET="ci-fiat-parsers TIMED=1" - - TEST_TARGET="ci-flocq TIMED=1" - - TEST_TARGET="ci-formal-topology TIMED=1" - - TEST_TARGET="ci-hott TIMED=1" - - TEST_TARGET="ci-iris-lambda-rust TIMED=1" - - TEST_TARGET="ci-ltac2 TIMED=1" - - TEST_TARGET="ci-math-classes TIMED=1" - - TEST_TARGET="ci-math-comp TIMED=1" - - TEST_TARGET="ci-sf TIMED=1" - - TEST_TARGET="ci-unimath TIMED=1" - - TEST_TARGET="ci-vst TIMED=1" + - TEST_TARGET="ci-coquelicot" + - TEST_TARGET="ci-equations" + - TEST_TARGET="ci-geocoq" + - TEST_TARGET="ci-fiat-crypto" + - TEST_TARGET="ci-fiat-parsers" + - TEST_TARGET="ci-flocq" + - TEST_TARGET="ci-formal-topology" + - TEST_TARGET="ci-hott" + - TEST_TARGET="ci-iris-lambda-rust" + - TEST_TARGET="ci-ltac2" + - TEST_TARGET="ci-math-classes" + - TEST_TARGET="ci-math-comp" + - TEST_TARGET="ci-sf" + - TEST_TARGET="ci-unimath" + - TEST_TARGET="ci-vst" # Not ready yet for 8.7 - # - TEST_TARGET="ci-cpdt TIMED=1" - # - TEST_TARGET="ci-metacoq TIMED=1" - # - TEST_TARGET="ci-tlc TIMED=1" + # - TEST_TARGET="ci-cpdt" + # - TEST_TARGET="ci-metacoq" + # - TEST_TARGET="ci-tlc" matrix: diff --git a/API/API.ml b/API/API.ml index 378c03ee4f..081ac2bb28 100644 --- a/API/API.ml +++ b/API/API.ml @@ -267,7 +267,9 @@ module Metasyntax = Metasyntax module Search = Search (* module Indschemes *) module Obligations = Obligations -module Command = Command +module ComDefinition = ComDefinition +module ComInductive = ComInductive +module ComFixpoint = ComFixpoint module Classes = Classes (* module Record *) (* module Assumptions *) diff --git a/API/API.mli b/API/API.mli index 8f46a58321..a69766901b 100644 --- a/API/API.mli +++ b/API/API.mli @@ -4620,6 +4620,9 @@ end module Constrintern : sig + + open Evd + type ltac_sign = { ltac_vars : Names.Id.Set.t; ltac_bound : Names.Id.Set.t; @@ -4635,11 +4638,11 @@ sig | Variable type internalization_env = var_internalization_data Names.Id.Map.t - val interp_constr_evars : Environ.env -> Evd.evar_map ref -> - ?impls:internalization_env -> Constrexpr.constr_expr -> EConstr.constr + val interp_constr_evars : Environ.env -> evar_map -> + ?impls:internalization_env -> Constrexpr.constr_expr -> evar_map * EConstr.constr - val interp_type_evars : Environ.env -> Evd.evar_map ref -> - ?impls:internalization_env -> Constrexpr.constr_expr -> EConstr.types + val interp_type_evars : Environ.env -> Evd.evar_map -> + ?impls:internalization_env -> Constrexpr.constr_expr -> evar_map * EConstr.types val empty_ltac_sign : ltac_sign val intern_gen : Pretyping.typing_constraint -> Environ.env -> @@ -4657,10 +4660,12 @@ sig val locate_reference : Libnames.qualid -> Globnames.global_reference val interp_type : Environ.env -> Evd.evar_map -> ?impls:internalization_env -> Constrexpr.constr_expr -> Constr.types Evd.in_evar_universe_context + val interp_context_evars : ?global_level:bool -> ?impl_env:internalization_env -> ?shift:int -> - Environ.env -> Evd.evar_map ref -> Constrexpr.local_binder_expr list -> - internalization_env * ((Environ.env * EConstr.rel_context) * Impargs.manual_implicits) + Environ.env -> Evd.evar_map -> Constrexpr.local_binder_expr list -> + evar_map * (internalization_env * ((Environ.env * EConstr.rel_context) * Impargs.manual_implicits)) + val compute_internalization_data : Environ.env -> var_internalization_type -> Constr.types -> Impargs.manual_explicitation list -> var_internalization_data val empty_internalization_env : internalization_env @@ -6045,21 +6050,53 @@ sig val show_term : Names.Id.t option -> Pp.t end -module Command : +module ComDefinition : +sig + val do_definition : + program_mode:bool -> + Names.Id.t -> Decl_kinds.definition_kind -> Vernacexpr.universe_decl_expr option -> + Constrexpr.local_binder_expr list -> Redexpr.red_expr option -> Constrexpr.constr_expr -> + Constrexpr.constr_expr option -> unit Lemmas.declaration_hook -> unit +end + +module ComFixpoint : sig + open Names open Constrexpr - open Vernacexpr type structured_fixpoint_expr = { fix_name : Id.t; - fix_univs : universe_decl_expr option; + fix_univs : Vernacexpr.universe_decl_expr option; fix_annot : Id.t Loc.located option; fix_binders : local_binder_expr list; fix_body : constr_expr option; fix_type : constr_expr } + type recursive_preentry = Names.Id.t list * Constr.t option list * Constr.types list + + val interp_fixpoint : + cofix:bool -> + structured_fixpoint_expr list -> Vernacexpr.decl_notation list -> + recursive_preentry * Univdecls.universe_decl * UState.t * + (EConstr.rel_context * Impargs.manual_implicits * int option) list + + val extract_fixpoint_components : bool -> + (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list -> + structured_fixpoint_expr list * Vernacexpr.decl_notation list + + val do_fixpoint : + Decl_kinds.locality -> Decl_kinds.polymorphic -> (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list -> unit + +end + +module ComInductive : +sig + open Names + open Constrexpr + open Vernacexpr + type structured_one_inductive_expr = { ind_name : Id.t; ind_univs : universe_decl_expr option; @@ -6070,30 +6107,12 @@ sig type structured_inductive_expr = local_binder_expr list * structured_one_inductive_expr list - type recursive_preentry = Names.Id.t list * Constr.t option list * Constr.types list - type one_inductive_impls val do_mutual_inductive : (Vernacexpr.one_inductive_expr * Vernacexpr.decl_notation list) list -> Decl_kinds.cumulative_inductive_flag -> Decl_kinds.polymorphic -> Decl_kinds.private_flag -> Declarations.recursivity_kind -> unit - val do_definition : Names.Id.t -> Decl_kinds.definition_kind -> Vernacexpr.universe_decl_expr option -> - Constrexpr.local_binder_expr list -> Redexpr.red_expr option -> Constrexpr.constr_expr -> - Constrexpr.constr_expr option -> unit Lemmas.declaration_hook -> unit - - val do_fixpoint : - Decl_kinds.locality -> Decl_kinds.polymorphic -> (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list -> unit - - val extract_fixpoint_components : bool -> - (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list -> - structured_fixpoint_expr list * Vernacexpr.decl_notation list - - val interp_fixpoint : - structured_fixpoint_expr list -> Vernacexpr.decl_notation list -> - recursive_preentry * Univdecls.universe_decl * UState.t * - (EConstr.rel_context * Impargs.manual_implicits * int option) list - val extract_mutual_inductive_declaration_components : (Vernacexpr.one_inductive_expr * Vernacexpr.decl_notation list) list -> structured_inductive_expr * Libnames.qualid list * Vernacexpr.decl_notation list @@ -6117,6 +6136,7 @@ sig ?abstract:bool -> ?global:bool -> ?refine:bool -> + program_mode:bool -> Decl_kinds.polymorphic -> Constrexpr.local_binder_expr list -> Vernacexpr.typeclass_constraint -> @@ -34,11 +34,16 @@ Tactics - The tactic "romega" is also aware now of the bodies of context variables. - Tactic "decide equality" now able to manage constructors which contain proofs. +- Added tactics reset ltac profile, show ltac profile (and variants) +- Added tactics restart_timer, finish_timing, and time_constr as an + experimental way of timing Ltac's evaluation phase Vernacular Commands - The deprecated Coercion Local, Open Local Scope, Notation Local syntax 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. Universes @@ -52,6 +57,12 @@ Checker - The checker now accepts filenames in addition to logical paths. +Documentation + +- The Coq FAQ, formerly located at https://coq.inria.fr/faq, has been + moved to the GitHub wiki section of this repository; the main entry + page is https://github.com/coq/coq/wiki/The-Coq-FAQ. + Changes from 8.7.0 to 8.7.1 =========================== @@ -286,7 +297,7 @@ Changes from 8.6 to 8.6.1 - Fix bug 5550: "typeclasses eauto with" does not work with section variables. - Bug 5546, qualify datatype constructors when needed in Show Match - Bug #5535, test for Show with -emacs -- Fix bug #5486, don't reverse ids in tuples +- Fix bug #5486, don't reverse ids in tuples - Fixing #5522 (anomaly with free vars of pat) - Fix bug #5526, don't check for nonlinearity in notation if printing only - Fix bug #5255 @@ -308,7 +319,7 @@ Changes from 8.6 to 8.6.1 - show unused intro pattern warning - [future] Be eager when "chaining" already resolved future values. - Opaque side effects -- Fix #5132: coq_makefile generates incorrect install goal +- Fix #5132: coq_makefile generates incorrect install goal - Run non-tactic comands without resilient_command - Univs: fix bug #5365, generation of u+k <= v constraints - make `emit' tail recursive @@ -47,13 +47,17 @@ package "vm" ( directory = "kernel/byterun" -# We should generate this file at configure time for local byte builds -# to work properly. - -# Enable this setting for local byte builds, disabling the one below. +# We could generate this file at configure time for the share byte +# build path to work properly. +# +# Enable this setting for local byte builds if you want dynamic linking: +# # linkopts(byte) = "-dllpath path_to_coq/kernel/byterun/ -dllib -lcoqrun" - linkopts(byte) = "-dllib -lcoqrun" +# We currently prefer static linking of the VM. + archive(byte) = "libcoqrun.a" + linkopts(byte) = "-custom" + linkopts(native) = "-cclib -lcoqrun" ) @@ -233,8 +233,7 @@ docclean: doc/stdlib/*Library.coqdoc.tex doc/stdlib/library.files \ doc/stdlib/library.files.ls doc/stdlib/FullLibrary.tex rm -f doc/*/*.ps doc/*/*.pdf doc/*/*.eps doc/*/*.pdf_t doc/*/*.eps_t - rm -f doc/faq/axioms.png - rm -rf doc/refman/html doc/stdlib/html doc/faq/html doc/tutorial/tutorial.v.html + rm -rf doc/refman/html doc/stdlib/html doc/tutorial/tutorial.v.html rm -f doc/refman/euclid.ml doc/refman/euclid.mli rm -f doc/refman/heapsort.ml doc/refman/heapsort.mli rm -f doc/common/version.tex diff --git a/Makefile.build b/Makefile.build index 940943c41f..2f7ce6ef35 100644 --- a/Makefile.build +++ b/Makefile.build @@ -147,8 +147,14 @@ endif # For creating the missing .d, make will recursively build things like # coqdep_boot (for the .v.d files) or grammar.cma (for .ml4 -> .ml -> .ml.d). +VDFILE := .vfiles +MLDFILE := .mlfiles +PLUGMLDFILE := plugins/.mlfiles +MLLIBDFILE := .mllibfiles +PLUGMLLIBDFILE := plugins/.mllibfiles + DEPENDENCIES := \ - $(addsuffix .d, $(MLFILES) $(MLIFILES) $(MLLIBFILES) $(MLPACKFILES) $(CFILES) $(VFILES)) + $(addsuffix .d, $(MLDFILE) $(MLLIBDFILE) $(PLUGMLDFILE) $(PLUGMLLIBDFILE) $(CFILES) $(VDFILE)) -include $(DEPENDENCIES) @@ -189,7 +195,7 @@ TIMER=$(if $(TIMED), $(STDTIME), $(TIMECMD)) COQOPTS=$(NATIVECOMPUTE) BOOTCOQC=$(TIMER) $(COQTOPBEST) -boot $(COQOPTS) -compile -LOCALINCLUDES=$(if $(filter plugins/%,$<),-I lib -I API -open API $(addprefix -I plugins/,$(PLUGINDIRS)),$(addprefix -I ,$(SRCDIRS))) +LOCALINCLUDES=$(if $(filter plugins/%,$@),-I lib -I API -open API $(addprefix -I plugins/,$(PLUGINDIRS)),$(addprefix -I ,$(SRCDIRS))) MLINCLUDES=$(LOCALINCLUDES) -I $(MYCAMLP4LIB) OCAMLC := $(OCAMLFIND) ocamlc $(CAMLFLAGS) @@ -197,7 +203,7 @@ OCAMLOPT := $(OCAMLFIND) opt $(CAMLFLAGS) BYTEFLAGS=$(CAMLDEBUG) $(USERFLAGS) OPTFLAGS=$(CAMLDEBUGOPT) $(CAMLTIMEPROF) $(USERFLAGS) $(FLAMBDA_FLAGS) -DEPFLAGS=$(LOCALINCLUDES)$(if $(filter plugins/%,$<),, -I ide -I ide/utils) +DEPFLAGS=$(LOCALINCLUDES)$(if $(filter plugins/%,$@),, -I ide -I ide/utils) # On MacOS, the binaries are signed, except our private ones ifeq ($(shell which codesign > /dev/null 2>&1 && echo $(ARCH)),Darwin) @@ -301,7 +307,7 @@ kernel/byterun/coq_jumptbl.h : kernel/byterun/coq_instruct.h -e '/^}/q' $< $(TOTARGET) kernel/copcodes.ml: kernel/byterun/coq_instruct.h - sed -n -e '/^enum/p' -e 's/,//g' -e '/^ /p' $< | \ + tr -d "\r" < $< | sed -n -e '/^enum/p' -e 's/,//g' -e '/^ /p' | \ awk -f kernel/make-opcodes $(TOTARGET) %.o: %.c @@ -671,21 +677,24 @@ plugins/%.cmx: plugins/%.ml # Ocamldep is now used directly again (thanks to -ml-synonym in OCaml >= 3.12) OCAMLDEP = $(OCAMLFIND) ocamldep -slash -ml-synonym .ml4 -ml-synonym .mlpack -%.ml.d: $(D_DEPEND_BEFORE_SRC) %.ml $(D_DEPEND_AFTER_SRC) $(GENFILES) - $(SHOW)'OCAMLDEP $<' - $(HIDE)$(OCAMLDEP) $(DEPFLAGS) "$<" $(TOTARGET) +MAINMLFILES := $(filter-out checker/% plugins/%, $(MLFILES) $(MLIFILES)) +MAINMLLIBFILES := $(filter-out checker/% plugins/%, $(MLLIBFILES) $(MLPACKFILES)) + +$(MLDFILE).d: $(D_DEPEND_BEFORE_SRC) $(MAINMLFILES) $(D_DEPEND_AFTER_SRC) $(GENFILES) + $(SHOW)'OCAMLDEP MLFILES MLIFILES' + $(HIDE)$(OCAMLDEP) $(DEPFLAGS) $(MAINMLFILES) $(TOTARGET) -%.mli.d: $(D_DEPEND_BEFORE_SRC) %.mli $(D_DEPEND_AFTER_SRC) $(GENFILES) - $(SHOW)'OCAMLDEP $<' - $(HIDE)$(OCAMLDEP) $(DEPFLAGS) "$<" $(TOTARGET) +$(MLLIBDFILE).d: $(D_DEPEND_BEFORE_SRC) $(MAINMLLIBFILES) $(D_DEPEND_AFTER_SRC) $(OCAMLLIBDEP) $(GENFILES) + $(SHOW)'OCAMLLIBDEP MLLIBFILES MLPACKFILES' + $(HIDE)$(OCAMLLIBDEP) $(DEPFLAGS) $(MAINMLLIBFILES) $(TOTARGET) -%.mllib.d: $(D_DEPEND_BEFORE_SRC) %.mllib $(D_DEPEND_AFTER_SRC) $(OCAMLLIBDEP) $(GENFILES) - $(SHOW)'OCAMLLIBDEP $<' - $(HIDE)$(OCAMLLIBDEP) $(DEPFLAGS) "$<" $(TOTARGET) +$(PLUGMLDFILE).d: $(D_DEPEND_BEFORE_SRC) $(filter plugins/%, $(MLFILES) $(MLIFILES)) $(D_DEPEND_AFTER_SRC) $(GENFILES) + $(SHOW)'OCAMLDEP plugins/MLFILES plugins/MLIFILES' + $(HIDE)$(OCAMLDEP) $(DEPFLAGS) $(filter plugins/%, $(MLFILES) $(MLIFILES)) $(TOTARGET) -%.mlpack.d: $(D_DEPEND_BEFORE_SRC) %.mlpack $(D_DEPEND_AFTER_SRC) $(OCAMLLIBDEP) $(GENFILES) - $(SHOW)'OCAMLLIBDEP $<' - $(HIDE)$(OCAMLLIBDEP) $(DEPFLAGS) "$<" $(TOTARGET) +$(PLUGMLLIBDFILE).d: $(D_DEPEND_BEFORE_SRC) $(filter plugins/%, $(MLLIBFILES) $(MLPACKFILES)) $(D_DEPEND_AFTER_SRC) $(OCAMLLIBDEP) $(GENFILES) + $(SHOW)'OCAMLLIBDEP plugins/MLLIBFILES plugins/MLPACKFILES' + $(HIDE)$(OCAMLLIBDEP) $(DEPFLAGS) $(filter plugins/%, $(MLLIBFILES) $(MLPACKFILES)) $(TOTARGET) ########################################################################### # Compilation of .v files @@ -718,26 +727,6 @@ theories/Init/%.vo theories/Init/%.glob: theories/Init/%.v $(VO_TOOLS_DEP) $(HIDE)rm -f theories/Init/$*.glob $(HIDE)$(BOOTCOQC) $< -noinit -R theories Coq $(TIMING_ARG) $(TIMING_EXTRA) -# MExtraction.v generates the ml core file of the micromega tactic. -# We check that this generated code is still in sync with the version -# of micromega.ml in the archive. - -# Note: we now dump to stdout there via "Recursive Extraction" for better -# control on the name of the generated file, and avoid a .ml that -# would end in our $(MLFILES). The "sed" below is to kill the final -# blank line printed by Recursive Extraction (unlike Extraction "foo"). - -MICROMEGAV:=plugins/micromega/MExtraction.v -MICROMEGAML:=plugins/micromega/micromega.ml -MICROMEGAGEN:=plugins/micromega/.micromega.ml.generated - -$(MICROMEGAV:.v=.vo) $(MICROMEGAV:.v=.glob) : $(MICROMEGAV) theories/Init/Prelude.vo $(VO_TOOLS_DEP) - $(SHOW)'COQC $<' - $(HIDE)rm -f $*.glob - $(HIDE)$(BOOTCOQC) $< | sed -e '$$d' > $(MICROMEGAGEN) - $(HIDE)diff -u --strip-trailing-cr $(MICROMEGAML) $(MICROMEGAGEN) || \ - (2>&1 echo "Error: $(MICROMEGAML) and the code generated by $(MICROMEGAV) differ !" && false) - # The general rule for building .vo files : %.vo %.glob: %.v theories/Init/Prelude.vo $(VO_TOOLS_DEP) @@ -757,9 +746,9 @@ endif # Dependencies of .v files -%.v.d: $(D_DEPEND_BEFORE_SRC) %.v $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) - $(SHOW)'COQDEP $<' - $(HIDE)$(COQDEPBOOT) -boot $(DYNDEP) "$<" $(TOTARGET) +$(VDFILE).d: $(D_DEPEND_BEFORE_SRC) $(VFILES) $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) + $(SHOW)'COQDEP VFILES' + $(HIDE)$(COQDEPBOOT) -boot $(DYNDEP) $(VFILES) $(TOTARGET) ########################################################################### diff --git a/Makefile.checker b/Makefile.checker index b14f705bed..7e0f588759 100644 --- a/Makefile.checker +++ b/Makefile.checker @@ -26,6 +26,12 @@ CHKLIBS:= -I config -I lib -I checker # The rules +CHECKMLDFILE := checker/.mlfiles +CHECKMLLIBFILE := checker/.mllibfiles + +CHECKERDEPS := $(addsuffix .d, $(CHECKMLDFILE) $(CHECKMLLIBFILE)) +-include $(CHECKERDEPS) + ifeq ($(BEST),opt) $(CHICKEN): checker/check.cmxa checker/main.ml $(SHOW)'OCAMLOPT -o $@' @@ -49,17 +55,13 @@ checker/check.cmxa: checker/check.mllib | md5chk $(SHOW)'OCAMLOPT -a -o $@' $(HIDE)$(OCAMLOPT) $(CHKLIBS) $(OPTFLAGS) -a -o $@ $(filter-out %.mllib, $^) -checker/%.ml.d: checker/%.ml - $(SHOW)'OCAMLDEP $<' - $(HIDE)$(OCAMLFIND) ocamldep -slash $(CHKLIBS) "$<" $(TOTARGET) - -checker/%.mli.d: checker/%.mli - $(SHOW)'OCAMLDEP $<' - $(HIDE)$(OCAMLFIND) ocamldep -slash $(CHKLIBS) "$<" $(TOTARGET) +$(CHECKMLDFILE).d: $(filter checker/%, $(MLFILES) $(MLIFILES)) + $(SHOW)'OCAMLDEP checker/MLFILES checker/MLIFILES' + $(HIDE)$(OCAMLFIND) ocamldep -slash $(CHKLIBS) $(filter checker/%, $(MLFILES) $(MLIFILES)) $(TOTARGET) -checker/%.mllib.d: checker/%.mllib | $(OCAMLLIBDEP) - $(SHOW)'OCAMLLIBDEP $<' - $(HIDE)$(OCAMLLIBDEP) $(CHKLIBS) "$<" $(TOTARGET) +$(CHECKMLLIBFILE).d: $(filter checker/%, $(MLLIBFILES) $(MLPACKFILES)) | $(OCAMLLIBDEP) + $(SHOW)'OCAMLLIBDEP checker/MLLIBFILES checker/MLPACKFILES' + $(HIDE)$(OCAMLLIBDEP) $(CHKLIBS) $(filter checker/%, $(MLLIBFILES) $(MLPACKFILES)) $(TOTARGET) checker/%.cmi: checker/%.mli $(SHOW)'OCAMLC $<' @@ -75,8 +77,9 @@ checker/%.cmx: checker/%.ml md5chk: $(SHOW)'MD5SUM cic.mli' - $(HIDE)if grep -q `$(MD5SUM) checker/cic.mli` checker/values.ml; \ - then true; else echo "Error: outdated checker/values.ml"; false; fi + $(HIDE)v=`tr -d "\r" < checker/cic.mli | $(MD5SUM) | sed -n -e 's/ .*//' -e '/^/p'`; \ + if grep -q "$$v" checker/values.ml; \ + then true; else echo "Error: outdated checker/values.ml: $$v" >&2; false; fi .PHONY: md5chk diff --git a/Makefile.ci b/Makefile.ci index a17d4ddf75..334827a937 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -4,6 +4,7 @@ CI_TARGETS=ci-all \ ci-compcert \ ci-coq-dpdgraph \ ci-coquelicot \ + ci-corn \ ci-cpdt \ ci-equations \ ci-fiat-crypto \ @@ -24,6 +25,19 @@ CI_TARGETS=ci-all \ .PHONY: $(CI_TARGETS) +ci-color: ci-bignums + +ci-math-classes: ci-bignums + +ci-corn: ci-math-classes + +ci-formal-topology: ci-corn + # Generic rule, we use make to ease travis integration with mixed rules $(CI_TARGETS): ci-%: - +./dev/ci/ci-wrapper.sh ci-$*.sh + +./dev/ci/ci-wrapper.sh $* + +# For emacs: +# Local Variables: +# mode: makefile +# End: diff --git a/Makefile.doc b/Makefile.doc index faa9c879c1..1b0803f199 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -77,23 +77,23 @@ REFMANPNGFILES:=$(REFMANEPSFILES:.eps=.png) ###################################################################### .PHONY: doc doc-html doc-pdf doc-ps refman refman-quick tutorial -.PHONY: stdlib full-stdlib faq rectutorial refman-html-dir +.PHONY: stdlib full-stdlib rectutorial refman-html-dir INDEXURLS:=doc/refman/html/index_urls.txt -doc: refman faq tutorial rectutorial stdlib $(INDEXURLS) +doc: refman tutorial rectutorial stdlib $(INDEXURLS) doc-html:\ doc/tutorial/Tutorial.v.html doc/refman/html/index.html \ - doc/faq/html/index.html doc/stdlib/html/index.html doc/RecTutorial/RecTutorial.html + doc/stdlib/html/index.html doc/RecTutorial/RecTutorial.html doc-pdf:\ doc/tutorial/Tutorial.v.pdf doc/refman/Reference-Manual.pdf \ - doc/faq/FAQ.v.pdf doc/stdlib/Library.pdf doc/RecTutorial/RecTutorial.pdf + doc/stdlib/Library.pdf doc/RecTutorial/RecTutorial.pdf doc-ps:\ doc/tutorial/Tutorial.v.ps doc/refman/Reference-Manual.ps \ - doc/faq/FAQ.v.ps doc/stdlib/Library.ps doc/RecTutorial/RecTutorial.ps + doc/stdlib/Library.ps doc/RecTutorial/RecTutorial.ps refman: \ doc/refman/html/index.html doc/refman/Reference-Manual.ps doc/refman/Reference-Manual.pdf @@ -107,8 +107,6 @@ stdlib: \ full-stdlib: \ doc/stdlib/html/index.html doc/stdlib/FullLibrary.ps doc/stdlib/FullLibrary.pdf -faq: doc/faq/html/index.html doc/faq/FAQ.v.ps doc/faq/FAQ.v.pdf - rectutorial: doc/RecTutorial/RecTutorial.html \ doc/RecTutorial/RecTutorial.ps doc/RecTutorial/RecTutorial.pdf @@ -148,9 +146,6 @@ endif HIDEBIBTEXINFO=| grep -v "^A level-1 auxiliary file" SHOWMAKEINDEXERROR=egrep '^!! Input index error|^\*\* Input style error|^ --' -# Empty subsection levels in faq are on purpose -HEVEAFAQFILTER=2>&1 | grep -v "^Warning: List with no item" - ###################################################################### # Common ###################################################################### @@ -253,33 +248,6 @@ doc/tutorial/Tutorial.v.pdf: $(DOCCOMMON) doc/tutorial/Tutorial.v.tex doc/tutorial/Tutorial.v.html: $(DOCCOMMON) doc/tutorial/Tutorial.v.tex (cd doc/tutorial; $(HEVEA) $(HEVEAOPTS) Tutorial.v) - -###################################################################### -# FAQ -###################################################################### - -doc/faq/FAQ.v.dvi: doc/common/version.tex doc/common/title.tex doc/faq/FAQ.v.tex doc/faq/axioms.eps - (cd doc/faq;\ - $(LATEX) -interaction=batchmode FAQ.v;\ - $(BIBTEX) -terse FAQ.v;\ - $(LATEX) -interaction=batchmode FAQ.v > /dev/null;\ - $(LATEX) -interaction=batchmode FAQ.v > /dev/null;\ - ../tools/show_latex_messages FAQ.v.log) - -doc/faq/FAQ.v.pdf: doc/common/version.tex doc/common/title.tex doc/faq/FAQ.v.dvi doc/faq/axioms.pdf - (cd doc/faq;\ - $(PDFLATEX) -interaction=batchmode FAQ.v.tex;\ - ../tools/show_latex_messages FAQ.v.log) - -doc/faq/FAQ.v.html: doc/faq/FAQ.v.dvi doc/faq/axioms.png # to ensure FAQ.v.bbl - (cd doc/faq; ($(HEVEA) $(HEVEAOPTS) FAQ.v.tex $(HEVEAFAQFILTER))) - -doc/faq/html/index.html: doc/faq/FAQ.v.html - - rm -rf doc/faq/html - $(MKDIR) doc/faq/html - $(INSTALLLIB) doc/faq/interval_discr.v doc/faq/axioms.png doc/faq/html - $(INSTALLLIB) doc/faq/FAQ.v.html doc/faq/html/index.html - ###################################################################### # Standard library ###################################################################### @@ -386,14 +354,13 @@ install-doc-meta: $(INSTALLLIB) doc/LICENSE $(FULLDOCDIR)/LICENSE.doc install-doc-html: - $(MKDIR) $(addprefix $(FULLDOCDIR)/html/, refman stdlib faq) + $(MKDIR) $(addprefix $(FULLDOCDIR)/html/, refman stdlib) (for f in `cd doc/refman/html; find . -type f`; do \ $(MKDIR) $$(dirname $(FULLDOCDIR)/html/refman/$$f);\ $(INSTALLLIB) doc/refman/html/$$f $(FULLDOCDIR)/html/refman/$$f;\ done) $(INSTALLLIB) doc/stdlib/html/* $(FULLDOCDIR)/html/stdlib $(INSTALLLIB) doc/RecTutorial/RecTutorial.html $(FULLDOCDIR)/html/RecTutorial.html - $(INSTALLLIB) doc/faq/html/* $(FULLDOCDIR)/html/faq $(INSTALLLIB) doc/tutorial/Tutorial.v.html $(FULLDOCDIR)/html/Tutorial.html install-doc-printable: @@ -404,10 +371,8 @@ install-doc-printable: doc/stdlib/Library.ps $(FULLDOCDIR)/ps $(INSTALLLIB) doc/tutorial/Tutorial.v.pdf $(FULLDOCDIR)/pdf/Tutorial.pdf $(INSTALLLIB) doc/RecTutorial/RecTutorial.pdf $(FULLDOCDIR)/pdf/RecTutorial.pdf - $(INSTALLLIB) doc/faq/FAQ.v.pdf $(FULLDOCDIR)/pdf/FAQ.pdf $(INSTALLLIB) doc/tutorial/Tutorial.v.ps $(FULLDOCDIR)/ps/Tutorial.ps $(INSTALLLIB) doc/RecTutorial/RecTutorial.ps $(FULLDOCDIR)/ps/RecTutorial.ps - $(INSTALLLIB) doc/faq/FAQ.v.ps $(FULLDOCDIR)/ps/FAQ.ps install-doc-index-urls: $(MKDIR) $(FULLDATADIR) diff --git a/Makefile.install b/Makefile.install index 84aa11a5ee..9a7229d524 100644 --- a/Makefile.install +++ b/Makefile.install @@ -107,9 +107,10 @@ install-devfiles: $(MKDIR) $(FULLBINDIR) $(MKDIR) $(FULLCOQLIB) $(INSTALLSH) $(FULLCOQLIB) $(GRAMMARCMA) - $(INSTALLSH) $(FULLCOQLIB) $(INSTALLCMI) - $(INSTALLSH) $(FULLCOQLIB) $(INSTALLCMX) - $(INSTALLSH) $(FULLCOQLIB) $(PLUGINSCMO:.cmo=.o) + $(INSTALLSH) $(FULLCOQLIB) $(INSTALLCMI) # Regular CMI files + $(INSTALLSH) $(FULLCOQLIB) $(INSTALLCMX) # To avoid warning 58 "-opaque" + $(INSTALLSH) $(FULLCOQLIB) $(PLUGINSCMO:.cmo=.cmx) # For static linking of plugins + $(INSTALLSH) $(FULLCOQLIB) $(PLUGINSCMO:.cmo=.o) # For static linking of plugins $(INSTALLSH) $(FULLCOQLIB) $(TOOLS_HELPERS) ifeq ($(BEST),opt) $(INSTALLSH) $(FULLCOQLIB) $(LINKCMX) $(CORECMA:.cma=.a) $(STATICPLUGINS:.cma=.a) @@ -1,6 +1,10 @@ # Coq -[](https://travis-ci.org/coq/coq/builds) [](https://ci.appveyor.com/project/coq/coq/branch/master) [](https://gitter.im/coq/coq) +- [](https://travis-ci.org/coq/coq/builds) Travis CI +- [](https://ci.appveyor.com/project/coq/coq/branch/master) Appveyor CI (Windows) +- [](https://circleci.com/gh/SkySkimmer/workflows/coq) Circle CI + +[](https://gitter.im/coq/coq) Coq is a formal proof management system. It provides a formal language to write mathematical definitions, executable algorithms and theorems together with an diff --git a/dev/base_include b/dev/base_include index 1da5e3ed18..d7059fe74f 100644 --- a/dev/base_include +++ b/dev/base_include @@ -170,7 +170,7 @@ open Eqschemes open ExplainErr open Class -open Command +open ComDefinition open Indschemes open Ind_tables open Auto_ind_decl diff --git a/dev/build/windows/MakeCoq_MinGW.bat b/dev/build/windows/MakeCoq_MinGW.bat index f91b301b8c..665d541761 100644 --- a/dev/build/windows/MakeCoq_MinGW.bat +++ b/dev/build/windows/MakeCoq_MinGW.bat @@ -345,7 +345,7 @@ IF "%COQREGTESTING%" == "Y" ( SET "EXTRAPACKAGES= " IF NOT "%APPVEYOR%" == "True" ( - SET EXTRAPACKAGES="-P wget,curl,git,gcc-core,gcc-g++,automake1.5" + SET EXTRAPACKAGES=-P wget,curl,git,gcc-core,gcc-g++,automake1.5 ) IF "%RUNSETUP%"=="Y" ( diff --git a/dev/ci/ci-bignums.sh b/dev/ci/ci-bignums.sh index d68674381a..c90e516ae9 100755 --- a/dev/ci/ci-bignums.sh +++ b/dev/ci/ci-bignums.sh @@ -13,4 +13,4 @@ bignums_CI_DIR=${CI_BUILD_DIR}/Bignums git_checkout ${bignums_CI_BRANCH} ${bignums_CI_GITURL} ${bignums_CI_DIR} -( cd ${bignums_CI_DIR} && make -j ${NJOBS} && make install) +( cd ${bignums_CI_DIR} && make && make install) diff --git a/dev/ci/ci-color.sh b/dev/ci/ci-color.sh index c3ae7552a9..558e8cbb8c 100755 --- a/dev/ci/ci-color.sh +++ b/dev/ci/ci-color.sh @@ -5,9 +5,6 @@ source ${ci_dir}/ci-common.sh CoLoR_CI_DIR=${CI_BUILD_DIR}/color -# Setup Bignums -source ${ci_dir}/ci-bignums.sh - # Compile CoLoR git_checkout ${CoLoR_CI_BRANCH} ${CoLoR_CI_GITURL} ${CoLoR_CI_DIR} ( cd ${CoLoR_CI_DIR} && make ) diff --git a/dev/ci/ci-common.sh b/dev/ci/ci-common.sh index 1bfdf7dfbe..23131c94c6 100644 --- a/dev/ci/ci-common.sh +++ b/dev/ci/ci-common.sh @@ -53,6 +53,18 @@ checkout_mathcomp() git_checkout ${mathcomp_CI_BRANCH} ${mathcomp_CI_GITURL} ${1} } +make() +{ + # +x: add x only if defined + if [ -z "${MAKEFLAGS+x}" ] && [ -n "${NJOBS}" ]; + then + # Not submake and parallel make requested + command make -j "$NJOBS" "$@" + else + command make "$@" + fi +} + # this installs just the ssreflect library of math-comp install_ssreflect() { diff --git a/dev/ci/ci-coq-dpdgraph.sh b/dev/ci/ci-coq-dpdgraph.sh index b610f70004..5d6bd6a368 100755 --- a/dev/ci/ci-coq-dpdgraph.sh +++ b/dev/ci/ci-coq-dpdgraph.sh @@ -7,4 +7,4 @@ coq_dpdgraph_CI_DIR=${CI_BUILD_DIR}/coq-dpdgraph git_checkout ${coq_dpdgraph_CI_BRANCH} ${coq_dpdgraph_CI_GITURL} ${coq_dpdgraph_CI_DIR} -( cd ${coq_dpdgraph_CI_DIR} && autoconf && ./configure && make -j ${NJOBS} && make test-suite ) +( cd ${coq_dpdgraph_CI_DIR} && autoconf && ./configure && make && make test-suite ) diff --git a/dev/ci/ci-corn.sh b/dev/ci/ci-corn.sh new file mode 100755 index 0000000000..54cad5df4c --- /dev/null +++ b/dev/ci/ci-corn.sh @@ -0,0 +1,10 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +Corn_CI_DIR=${CI_BUILD_DIR}/corn + +git_checkout ${Corn_CI_BRANCH} ${Corn_CI_GITURL} ${Corn_CI_DIR} + +( cd ${Corn_CI_DIR} && make && make install ) diff --git a/dev/ci/ci-equations.sh b/dev/ci/ci-equations.sh index f7470463d9..62854afac6 100755 --- a/dev/ci/ci-equations.sh +++ b/dev/ci/ci-equations.sh @@ -7,4 +7,4 @@ Equations_CI_DIR=${CI_BUILD_DIR}/Equations git_checkout ${Equations_CI_BRANCH} ${Equations_CI_GITURL} ${Equations_CI_DIR} -( cd ${Equations_CI_DIR} && coq_makefile -f _CoqProject -o Makefile && make -j ${NJOBS} && make -j ${NJOBS} test-suite && make -j ${NJOBS} examples && make install) +( cd ${Equations_CI_DIR} && coq_makefile -f _CoqProject -o Makefile && make && make test-suite && make examples && make install) diff --git a/dev/ci/ci-formal-topology.sh b/dev/ci/ci-formal-topology.sh index 2556f84a55..53eb55fc45 100755 --- a/dev/ci/ci-formal-topology.sh +++ b/dev/ci/ci-formal-topology.sh @@ -3,30 +3,8 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -math_classes_CI_DIR=${CI_BUILD_DIR}/math-classes - -Corn_CI_DIR=${CI_BUILD_DIR}/corn - formal_topology_CI_DIR=${CI_BUILD_DIR}/formal-topology -# Setup Bignums - -source ${ci_dir}/ci-bignums.sh - -# Setup Math-Classes - -git_checkout ${math_classes_CI_BRANCH} ${math_classes_CI_GITURL} ${math_classes_CI_DIR} - -( cd ${math_classes_CI_DIR} && make && make install ) - -# Setup Corn - -git_checkout ${Corn_CI_BRANCH} ${Corn_CI_GITURL} ${Corn_CI_DIR} - -( cd ${Corn_CI_DIR} && make && make install ) - -# Setup formal-topology - git_checkout ${formal_topology_CI_BRANCH} ${formal_topology_CI_GITURL} ${formal_topology_CI_DIR} ( cd ${formal_topology_CI_DIR} && make ) diff --git a/dev/ci/ci-hott.sh b/dev/ci/ci-hott.sh index 1bf6e9a872..693135a4c9 100755 --- a/dev/ci/ci-hott.sh +++ b/dev/ci/ci-hott.sh @@ -7,4 +7,4 @@ HoTT_CI_DIR=${CI_BUILD_DIR}/HoTT git_checkout ${HoTT_CI_BRANCH} ${HoTT_CI_GITURL} ${HoTT_CI_DIR} -( cd ${HoTT_CI_DIR} && ./autogen.sh && ./configure && make -j ${NJOBS} ) +( cd ${HoTT_CI_DIR} && ./autogen.sh && ./configure && make ) diff --git a/dev/ci/ci-ltac2.sh b/dev/ci/ci-ltac2.sh index ed40036012..820ff89eec 100755 --- a/dev/ci/ci-ltac2.sh +++ b/dev/ci/ci-ltac2.sh @@ -7,4 +7,4 @@ ltac2_CI_DIR=${CI_BUILD_DIR}/ltac2 git_checkout ${ltac2_CI_BRANCH} ${ltac2_CI_GITURL} ${ltac2_CI_DIR} -( cd ${ltac2_CI_DIR} && make -j ${NJOBS} && make tests && make install ) +( cd ${ltac2_CI_DIR} && make && make tests && make install ) diff --git a/dev/ci/ci-math-classes.sh b/dev/ci/ci-math-classes.sh index 2837dee963..db4a31e549 100755 --- a/dev/ci/ci-math-classes.sh +++ b/dev/ci/ci-math-classes.sh @@ -5,20 +5,6 @@ source ${ci_dir}/ci-common.sh math_classes_CI_DIR=${CI_BUILD_DIR}/math-classes -Corn_CI_DIR=${CI_BUILD_DIR}/corn - -# Setup Bignums - -source ${ci_dir}/ci-bignums.sh - -# Setup Math-Classes - git_checkout ${math_classes_CI_BRANCH} ${math_classes_CI_GITURL} ${math_classes_CI_DIR} ( cd ${math_classes_CI_DIR} && make && make install ) - -# Setup Corn - -git_checkout ${Corn_CI_BRANCH} ${Corn_CI_GITURL} ${Corn_CI_DIR} - -( cd ${Corn_CI_DIR} && make ) diff --git a/dev/ci/ci-wrapper.sh b/dev/ci/ci-wrapper.sh index 96acc5a11c..12a70176c2 100755 --- a/dev/ci/ci-wrapper.sh +++ b/dev/ci/ci-wrapper.sh @@ -13,11 +13,14 @@ function travis_fold { fi } -CI_SCRIPT="$1" +CI_NAME="$1" +CI_SCRIPT="ci-${CI_NAME}.sh" + DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" # assume this script is in dev/ci/, cd to the root Coq directory cd "${DIR}/../.." +export TIMED=1 "${DIR}/${CI_SCRIPT}" 2>&1 | tee time-of-build.log travis_fold 'start' 'coq.test.timing' && echo 'Aggregating timing log...' python ./tools/make-one-time-file.py time-of-build.log diff --git a/dev/ci/user-overlays/06217-coqdep-at-once.sh b/dev/ci/user-overlays/06217-coqdep-at-once.sh new file mode 100644 index 0000000000..68e1901f7f --- /dev/null +++ b/dev/ci/user-overlays/06217-coqdep-at-once.sh @@ -0,0 +1,3 @@ +if [ "$TRAVIS_PULL_REQUEST" = "6217" ] || [ "$TRAVIS_BRANCH" = "coqdep-at-once" ]; then + UniMath_CI_GITURL=https://github.com/SkySkimmer/UniMath.git +fi diff --git a/dev/ci/user-overlays/06413-ejgallego-interp+less_impstyle_p2.sh b/dev/ci/user-overlays/06413-ejgallego-interp+less_impstyle_p2.sh new file mode 100644 index 0000000000..8aea7dee3a --- /dev/null +++ b/dev/ci/user-overlays/06413-ejgallego-interp+less_impstyle_p2.sh @@ -0,0 +1,4 @@ +if [ "$TRAVIS_PULL_REQUEST" = "6413" ] || [ "$TRAVIS_BRANCH" = "interp+less_impstyle_p2" ]; then + Equations_CI_BRANCH=interp+less_impstyle_p2 + Equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations.git +fi diff --git a/dev/doc/changes.md b/dev/doc/changes.md index c69be4f4de..01aa6b599b 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -46,6 +46,11 @@ We changed the type of the following functions: - `Global.body_of_constant`: same as above. +- `Constrinterp.*` generally, many functions that used to take an + `evar_map ref` have been now switched to functions that will work in + a functional way. The old style of passing `evar_map`s as references + is not supported anymore. + We have changed the representation of the following types: - `Lib.object_prefix` is now a record instead of a nested tuple. diff --git a/doc/faq/FAQ.tex b/doc/faq/FAQ.tex deleted file mode 100644 index 541d39501b..0000000000 --- a/doc/faq/FAQ.tex +++ /dev/null @@ -1,2713 +0,0 @@ -\RequirePackage{ifpdf} -\ifpdf % si on est en pdflatex -\documentclass[a4paper,pdftex]{article} -\else -\documentclass[a4paper]{article} -\fi -\pagestyle{plain} - -% yay les symboles -\usepackage{textcomp} -\usepackage{stmaryrd} -\usepackage{amssymb} -\usepackage{url} -%\usepackage{multicol} -\usepackage{hevea} -\usepackage{fullpage} -\usepackage[utf8]{inputenc} -\usepackage[english]{babel} - -\ifpdf % si on est en pdflatex - \usepackage[pdftex]{graphicx} -\else - \usepackage[dvips]{graphicx} -\fi - -%\input{../macros.tex} - -% Making hevea happy -%HEVEA \renewcommand{\textbar}{|} -%HEVEA \renewcommand{\textunderscore}{\_} - -\def\Question#1{\stepcounter{question}\subsubsection{#1}} - -% version et date -\def\faqversion{0.1} - -% les macros d'amour -\def\Coq{\textsc{Coq}} -\def\Why{\textsc{Why}} -\def\Framac{\textsc{Frama-c}} -\def\Krakatoa{\textsc{Krakatoa}} -\def\Ltac{\textsc{Ltac}} -\def\CoqIde{\textsc{CoqIde}} - -\newcommand{\coqtt}[1]{{\tt #1}} -\newcommand{\coqimp}{{\mbox{\tt ->}}} -\newcommand{\coqequiv}{{\mbox{\tt <->}}} - - -% macro pour les tactics -\def\split{{\tt split}} -\def\assumption{{\tt assumption}} -\def\auto{{\tt auto}} -\def\trivial{{\tt trivial}} -\def\tauto{{\tt tauto}} -\def\left{{\tt left}} -\def\right{{\tt right}} -\def\decompose{{\tt decompose}} -\def\intro{{\tt intro}} -\def\intros{{\tt intros}} -\def\field{{\tt field}} -\def\ring{{\tt ring}} -\def\apply{{\tt apply}} -\def\exact{{\tt exact}} -\def\cut{{\tt cut}} -\def\assert{{\tt assert}} -\def\solve{{\tt solve}} -\def\idtac{{\tt idtac}} -\def\fail{{\tt fail}} -\def\existstac{{\tt exists}} -\def\firstorder{{\tt firstorder}} -\def\congruence{{\tt congruence}} -\def\gb{{\tt gb}} -\def\generalize{{\tt generalize}} -\def\abstracttac{{\tt abstract}} -\def\eapply{{\tt eapply}} -\def\unfold{{\tt unfold}} -\def\rewrite{{\tt rewrite}} -\def\replace{{\tt replace}} -\def\simpl{{\tt simpl}} -\def\elim{{\tt elim}} -\def\set{{\tt set}} -\def\pose{{\tt pose}} -\def\case{{\tt case}} -\def\destruct{{\tt destruct}} -\def\reflexivity{{\tt reflexivity}} -\def\transitivity{{\tt transitivity}} -\def\symmetry{{\tt symmetry}} -\def\Focus{{\tt Focus}} -\def\discriminate{{\tt discriminate}} -\def\contradiction{{\tt contradiction}} -\def\intuition{{\tt intuition}} -\def\try{{\tt try}} -\def\repeat{{\tt repeat}} -\def\eauto{{\tt eauto}} -\def\subst{{\tt subst}} -\def\symmetryin{{\tt symmetryin}} -\def\instantiate{{\tt instantiate}} -\def\inversion{{\tt inversion}} -\def\specialize{{\tt specialize}} -\def\Defined{{\tt Defined}} -\def\Qed{{\tt Qed}} -\def\pattern{{\tt pattern}} -\def\Type{{\tt Type}} -\def\Prop{{\tt Prop}} -\def\Set{{\tt Set}} - - -\newcommand\vfile[2]{\ahref{#1}{\tt {#2}.v}} -\urldef{\InitWf}\url - {http://coq.inria.fr/library/Coq.Init.Wf.html} -\urldef{\LogicBerardi}\url - {http://coq.inria.fr/library/Coq.Logic.Berardi.html} -\urldef{\LogicClassical}\url - {http://coq.inria.fr/library/Coq.Logic.Classical.html} -\urldef{\LogicClassicalFacts}\url - {http://coq.inria.fr/library/Coq.Logic.ClassicalFacts.html} -\urldef{\LogicClassicalDescription}\url - {http://coq.inria.fr/library/Coq.Logic.ClassicalDescription.html} -\urldef{\LogicProofIrrelevance}\url - {http://coq.inria.fr/library/Coq.Logic.ProofIrrelevance.html} -\urldef{\LogicEqdep}\url - {http://coq.inria.fr/library/Coq.Logic.Eqdep.html} -\urldef{\LogicEqdepDec}\url - {http://coq.inria.fr/library/Coq.Logic.Eqdep_dec.html} - - - - -\begin{document} -\bibliographystyle{plain} -\newcounter{question} -\renewcommand{\thesubsubsection}{\arabic{question}} - -%%%%%%% Coq pour les nuls %%%%%%% - -\title{Coq Version 8.4 for the Clueless\\ - \large(\protect\ref{lastquestion} - \ Hints) -} -\author{Pierre Castéran \and Hugo Herbelin \and Florent Kirchner \and Benjamin Monate \and Julien Narboux} -\maketitle - -%%%%%%% - -\begin{abstract} -This note intends to provide an easy way to get acquainted with the -{\Coq} theorem prover. It tries to formulate appropriate answers -to some of the questions any newcomers will face, and to give -pointers to other references when possible. -\end{abstract} - -%%%%%%% - -%\begin{multicols}{2} -\tableofcontents -%\end{multicols} - -%%%%%%% - -\newpage - -\section{Introduction} -This FAQ is the sum of the questions that came to mind as we developed -proofs in \Coq. Since we are singularly short-minded, we wrote the -answers we found on bits of papers to have them at hand whenever the -situation occurs again. This is pretty much the result of that: a -collection of tips one can refer to when proofs become intricate. Yes, -it means we won't take the blame for the shortcomings of this -FAQ. But if you want to contribute and send in your own question and -answers, feel free to write to us\ldots - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -\section{Presentation} - -\Question{What is {\Coq}?}\label{whatiscoq} -The {\Coq} tool is a formal proof management system: a proof done with {\Coq} is mechanically checked by the machine. -In particular, {\Coq} allows: -\begin{itemize} - \item the definition of mathematical objects and programming objects, - \item to state mathematical theorems and software specifications, - \item to interactively develop formal proofs of these theorems, - \item to check these proofs by a small certification ``kernel''. -\end{itemize} -{\Coq} is based on a logical framework called ``Calculus of Inductive -Constructions'' extended by a modular development system for theories. - -\Question{Did you really need to name it like that?} -Some French computer scientists have a tradition of naming their -software as animal species: Caml, Elan, Foc or Phox are examples -of this tacit convention. In French, ``coq'' means rooster, and it -sounds like the initials of the Calculus of Constructions CoC on which -it is based. - -\Question{Is {\Coq} a theorem prover?} - -{\Coq} comes with decision and semi-decision procedures ( -propositional calculus, Presburger's arithmetic, ring and field -simplification, resolution, ...) but the main style for proving -theorems is interactively by using LCF-style tactics. - - -\Question{What are the other theorem provers?} -Many other theorem provers are available for use nowadays. -Isabelle, HOL, HOL Light, Lego, Nuprl, PVS are examples of provers that are fairly similar -to {\Coq} by the way they interact with the user. Other relatives of -{\Coq} are ACL2, Agda/Alfa, Twelf, Kiv, Mizar, NqThm, -\begin{htmlonly}% -Omega\ldots -\end{htmlonly} -\begin{latexonly}% -{$\Omega$}mega\ldots -\end{latexonly} - -\Question{What do I have to trust when I see a proof checked by Coq?} - -You have to trust: - -\begin{description} -\item[The theory behind Coq] The theory of {\Coq} version 8.0 is -generally admitted to be consistent wrt Zermelo-Fraenkel set theory + -inaccessible cardinals. Proofs of consistency of subsystems of the -theory of Coq can be found in the literature. -\item[The Coq kernel implementation] You have to trust that the -implementation of the {\Coq} kernel mirrors the theory behind {\Coq}. The -kernel is intentionally small to limit the risk of conceptual or -accidental implementation bugs. -\item[The Objective Caml compiler] The {\Coq} kernel is written using the -Objective Caml language but it uses only the most standard features -(no object, no label ...), so that it is highly improbable that an -Objective Caml bug breaks the consistency of {\Coq} without breaking all -other kinds of features of {\Coq} or of other software compiled with -Objective Caml. -\item[Your hardware] In theory, if your hardware does not work -properly, it can accidentally be the case that False becomes -provable. But it is more likely the case that the whole {\Coq} system -will be unusable. You can check your proof using different computers -if you feel the need to. -\item[Your axioms] Your axioms must be consistent with the theory -behind {\Coq}. -\end{description} - - -\Question{Where can I find information about the theory behind {\Coq}?} -\begin{description} -\item[The Calculus of Inductive Constructions] The -\ahref{http://coq.inria.fr/doc/Reference-Manual006.html}{corresponding} -chapter and the chapter on -\ahref{http://coq.inria.fr/doc/Reference-Manual007.html}{modules} in -the {\Coq} Reference Manual. -\item[Type theory] A book~\cite{ProofsTypes} or some lecture -notes~\cite{Types:Dowek}. -\item[Inductive types] -Christine Paulin-Mohring's habilitation thesis~\cite{Pau96b}. -\item[Co-Inductive types] -Eduardo Giménez' thesis~\cite{EGThese}. -\item[Miscellaneous] A -\ahref{http://coq.inria.fr/doc/biblio.html}{bibliography} about Coq -\end{description} - - -\Question{How can I use {\Coq} to prove programs?} - -You can either extract a program from a proof by using the extraction -mechanism or use dedicated tools, such as -\ahref{http://why3.lri.fr}{\Why}, -\ahref{http://krakatoa.lri.fr}{\Krakatoa}, -\ahref{http://frama-c.com}{\Framac}, to prove -annotated programs written in other languages. - -%\Question{How many {\Coq} users are there?} -% -%An estimation is about 100 regular users. - -\Question{How old is {\Coq}?} - -The first implementation is from 1985 (it was named {\sf CoC} which is -the acronym of the name of the logic it implemented: the Calculus of -Constructions). The first official release of {\Coq} (version 4.10) -was distributed in 1989. - -\Question{What are the \Coq-related tools?} - -There are graphical user interfaces: -\begin{description} -\item[Coqide] A GTK based GUI for \Coq. -\item[Pcoq] A GUI for {\Coq} with proof by pointing and pretty printing. -\item[coqwc] A tool similar to {\tt wc} to count lines in {\Coq} files. -\item[Proof General] A emacs mode for {\Coq} and many other proof assistants. -\item[ProofWeb] The ProofWeb online web interface for {\Coq} (and other proof assistants), with a focus on teaching. -\item[ProverEditor] is an experimental Eclipse plugin with support for {\Coq}. -\end{description} - -There are documentation and browsing tools: - -\begin{description} -\item[coq-tex] A tool to insert {\Coq} examples within .tex files. -\item[coqdoc] A documentation tool for \Coq. -\item[coqgraph] A tool to generate a dependency graph from {\Coq} sources. -\end{description} - -There are front-ends for specific languages: - -\begin{description} -\item[Why] A back-end generator of verification conditions. -\item[Krakatoa] A Java code certification tool that uses both {\Coq} and {\Why} to verify the soundness of implementations with regards to the specifications. -\item[Caduceus] A C code certification tool that uses both {\Coq} and \Why. -\item[Zenon] A first-order theorem prover. -\item[Focal] The \ahref{http://focal.inria.fr}{Focal} project aims at building an environment to develop certified computer algebra libraries. -\item[Concoqtion] is a dependently-typed extension of Objective Caml (and of MetaOCaml) with specifications expressed and proved in Coq. -\item[Ynot] is an extension of Coq providing a "Hoare Type Theory" for specifying higher-order, imperative and concurrent programs. -\item[Ott]is a tool to translate the descriptions of the syntax and semantics of programming languages to the syntax of Coq, or of other provers. -\end{description} - -\Question{What are the high-level tactics of \Coq} - -\begin{itemize} -\item Decision of quantifier-free Presburger's Arithmetic -\item Simplification of expressions on rings and fields -\item Decision of closed systems of equations -\item Semi-decision of first-order logic -\item Prolog-style proof search, possibly involving equalities -\end{itemize} - -\Question{What are the main libraries available for \Coq} - -\begin{itemize} -\item Basic Peano's arithmetic, binary integer numbers, rational numbers, -\item Real analysis, -\item Libraries for lists, boolean, maps, floating-point numbers, -\item Libraries for relations, sets and constructive algebra, -\item Geometry -\end{itemize} - - -\Question{What are the mathematical applications for {\Coq}?} - -{\Coq} is used for formalizing mathematical theories, for teaching, -and for proving properties of algorithms or programs libraries. - -The largest mathematical formalization has been done at the University -of Nijmegen (see the -\ahref{http://c-corn.cs.ru.nl}{Constructive Coq -Repository at Nijmegen}). - -A symbolic step has also been obtained by formalizing in full a proof -of the Four Color Theorem. - -\Question{What are the industrial applications for {\Coq}?} - -{\Coq} is used e.g. to prove properties of the JavaCard system -(especially by Schlumberger and Trusted Logic). It has -also been used to formalize the semantics of the Lucid-Synchrone -data-flow synchronous calculus used by Esterel-Technologies. - -\iffalse -todo christine compilo lustre? -\fi - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -\section{Documentation} - -\Question{Where can I find documentation about {\Coq}?} -All the documentation about \Coq, from the reference manual~\cite{Coq:manual} to -friendly tutorials~\cite{Coq:Tutorial} and documentation of the standard library, is available -\ahref{http://coq.inria.fr/doc-eng.html}{online}. -All these documents are viewable either in browsable HTML, or as -downloadable postscripts. - -\Question{Where can I find this FAQ on the web?} - -This FAQ is available online at \ahref{http://coq.inria.fr/faq}{\url{http://coq.inria.fr/faq}}. - -\Question{How can I submit suggestions / improvements / additions for this FAQ?} - -This FAQ is unfinished (in the sense that there are some obvious -sections that are missing). Please send contributions to Coq-Club. - -\Question{Is there any mailing list about {\Coq}?} -The main {\Coq} mailing list is \url{coq-club@inria.fr}, which -broadcasts questions and suggestions about the implementation, the -logical formalism or proof developments. See -\ahref{http://sympa.inria.fr/sympa/info/coq-club}{\url{http://sympa.inria.fr/sympa/info/coq-club}} for -subscription. For bugs reports see question \ref{coqbug}. - -\Question{Where can I find an archive of the list?} -The archives of the {\Coq} mailing list are available at -\ahref{http://sympa.inria.fr/sympa/arc/coq-club}{\url{http://sympa.inria.fr/sympa/arc/coq-club}}. - - -\Question{How can I be kept informed of new releases of {\Coq}?} - -New versions of {\Coq} are announced on the coq-club mailing list. If you only want to receive information about new releases, you can subscribe to {\Coq} on \ahref{http://freshmeat.net/projects/coq/}{\url{http://freshmeat.net/projects/coq/}}. - - -\Question{Is there any book about {\Coq}?} - -The first book on \Coq, Yves Bertot and Pierre Castéran's Coq'Art has been published by Springer-Verlag in 2004: -\begin{quote} -``This book provides a pragmatic introduction to the development of -proofs and certified programs using \Coq. With its large collection of -examples and exercises it is an invaluable tool for researchers, -students, and engineers interested in formal methods and the -development of zero-default software.'' -\end{quote} - -\Question{Where can I find some {\Coq} examples?} - -There are examples in the manual~\cite{Coq:manual} and in the -Coq'Art~\cite{Coq:coqart} exercises \ahref{\url{http://www.labri.fr/Perso/~casteran/CoqArt/index.html}}{\url{http://www.labri.fr/Perso/~casteran/CoqArt/index.html}}. -You can also find large developments using -{\Coq} in the {\Coq} user contributions: -\ahref{http://coq.inria.fr/contribs}{\url{http://coq.inria.fr/contribs}}. - -\Question{How can I report a bug?}\label{coqbug} - -You can use the web interface accessible at \ahref{http://coq.inria.fr}{\url{http://coq.inria.fr}}, link ``contacts''. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -\section{Installation} - -\Question{What is the license of {\Coq}?} -{\Coq} is distributed under the GNU Lesser General License -(LGPL). - -\Question{Where can I find the sources of {\Coq}?} -The sources of {\Coq} can be found online in the tar.gz'ed packages -(\ahref{http://coq.inria.fr}{\url{http://coq.inria.fr}}, link -``download''). Development sources can be accessed at -\ahref{http://coq.gforge.inria.fr/}{\url{http://coq.gforge.inria.fr/}} - -\Question{On which platform is {\Coq} available?} -Compiled binaries are available for Linux, MacOS X, and Windows. The -sources can be easily compiled on all platforms supporting Objective -Caml. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -\section{The logic of {\Coq}} - -\subsection{General} - -\Question{What is the logic of \Coq?} - -{\Coq} is based on an axiom-free type theory called -the Calculus of Inductive Constructions (see Coquand \cite{CoHu86}, -Luo~\cite{Luo90} -and Coquand--Paulin-Mohring \cite{CoPa89}). It includes higher-order -functions and predicates, inductive and co-inductive datatypes and -predicates, and a stratified hierarchy of sets. - -\Question{Is \Coq's logic intuitionistic or classical?} - -{\Coq}'s logic is modular. The core logic is intuitionistic -(i.e. excluded-middle $A\vee\neg A$ is not granted by default). It can -be extended to classical logic on demand by requiring an -optional module stating $A\vee\neg A$. - -\Question{Can I define non-terminating programs in \Coq?} - -All programs in {\Coq} are terminating. Especially, loops -must come with an evidence of their termination. - -Non-terminating programs can be simulated by passing around a -bound on how long the program is allowed to run before dying. - -\Question{How is equational reasoning working in {\Coq}?} - - {\Coq} comes with an internal notion of computation called -{\em conversion} (e.g. $(x+1)+y$ is internally equivalent to -$(x+y)+1$; similarly applying argument $a$ to a function mapping $x$ -to some expression $t$ converts to the expression $t$ where $x$ is -replaced by $a$). This notion of conversion (which is decidable -because {\Coq} programs are terminating) covers a certain part of -equational reasoning but is limited to sequential evaluation of -expressions of (not necessarily closed) programs. Besides conversion, -equations have to be treated by hand or using specialised tactics. - -\subsection{Axioms} - -\Question{What axioms can be safely added to {\Coq}?} - -There are a few typical useful axioms that are independent from the -Calculus of Inductive Constructions and that are considered consistent with -the theory of {\Coq}. -Most of these axioms are stated in the directory {\tt Logic} of the -standard library of {\Coq}. The most interesting ones are - -\begin{itemize} -\item Excluded-middle: $\forall A:Prop, A \vee \neg A$ -\item Proof-irrelevance: $\forall A:Prop \forall p_1 p_2:A, p_1=p_2$ -\item Unicity of equality proofs (or equivalently Streicher's axiom $K$): -$\forall A \forall x y:A \forall p_1 p_2:x=y, p_1=p_2$ -\item Hilbert's $\epsilon$ operator: if $A \neq \emptyset$, then there is $\epsilon_P$ such that $\exists x P(x) \rightarrow P(\epsilon_P)$ -\item Church's $\iota$ operator: if $A \neq \emptyset$, then there is $\iota_P$ such that $\exists! x P(x) \rightarrow P(\iota_P)$ -\item The axiom of unique choice: $\forall x \exists! y R(x,y) \rightarrow \exists f \forall x R(x,f(x))$ -\item The functional axiom of choice: $\forall x \exists y R(x,y) \rightarrow \exists f \forall x R(x,f(x))$ -\item Extensionality of predicates: $\forall P Q:A\rightarrow Prop, (\forall x, P(x) \leftrightarrow Q(x)) \rightarrow P=Q$ -\item Extensionality of functions: $\forall f g:A\rightarrow B, (\forall x, f(x)=g(x)) \rightarrow f=g$ -\end{itemize} - -Figure~\ref{fig:axioms} is a summary of the relative strength of these -axioms, most proofs can be found in directory {\tt Logic} of the standard -library. (Statements in boldface are the most ``interesting'' ones for -Coq.) The justification of their validity relies on the interpretability -in set theory. - -\begin{figure}[htbp] -%HEVEA\imgsrc{axioms.png} -%BEGIN LATEX -\begin{center} -\ifpdf % si on est en pdflatex -\scalebox{0.65}{\input{axioms.pdf_t}} -\else -\scalebox{0.65}{\input{axioms.eps_t}} -\fi -\end{center} -%END LATEX -\caption{The dependency graph of axioms in the Calculus of Inductive Constructions} -\label{fig:axioms} -\end{figure} - -\Question{What standard axioms are inconsistent with {\Coq}?} - -The axiom of unique choice together with classical logic -(e.g. excluded-middle) are inconsistent in the variant of the Calculus -of Inductive Constructions where {\Set} is impredicative. - -As a consequence, the functional form of the axiom of choice and -excluded-middle, or any form of the axiom of choice together with -predicate extensionality are inconsistent in the {\Set}-impredicative -version of the Calculus of Inductive Constructions. - -The main purpose of the \Set-predicative restriction of the Calculus -of Inductive Constructions is precisely to accommodate these axioms -which are quite standard in mathematical usage. - -The $\Set$-predicative system is commonly considered consistent by -interpreting it in a standard set-theoretic boolean model, even with -classical logic, axiom of choice and predicate extensionality added. - -\Question{What is Streicher's axiom $K$} -\label{Streicher} - -Streicher's axiom $K$~\cite{HofStr98} is an axiom that asserts -dependent elimination of reflexive equality proofs. - -\begin{coq_example*} -Axiom Streicher_K : - forall (A:Type) (x:A) (P: x=x -> Prop), - P (eq_refl x) -> forall p: x=x, P p. -\end{coq_example*} - -In the general case, axiom $K$ is an independent statement of the -Calculus of Inductive Constructions. However, it is true on decidable -domains (see file \vfile{\LogicEqdepDec}{Eqdep\_dec}). It is also -trivially a consequence of proof-irrelevance (see -\ref{proof-irrelevance}) hence of classical logic. - -Axiom $K$ is equivalent to {\em Uniqueness of Identity Proofs} \cite{HofStr98} - -\begin{coq_example*} -Axiom UIP : forall (A:Set) (x y:A) (p1 p2: x=y), p1 = p2. -\end{coq_example*} - -Axiom $K$ is also equivalent to {\em Uniqueness of Reflexive Identity Proofs} \cite{HofStr98} - -\begin{coq_example*} -Axiom UIP_refl : forall (A:Set) (x:A) (p: x=x), p = eq_refl x. -\end{coq_example*} - -Axiom $K$ is also equivalent to - -\begin{coq_example*} -Axiom - eq_rec_eq : - forall (A:Set) (x:A) (P: A->Set) (p:P x) (h: x=x), - p = eq_rect x P p x h. -\end{coq_example*} - -It is also equivalent to the injectivity of dependent equality (dependent equality is itself equivalent to equality of dependent pairs). - -\begin{coq_example*} -Inductive eq_dep (U:Set) (P:U -> Set) (p:U) (x:P p) : -forall q:U, P q -> Prop := - eq_dep_intro : eq_dep U P p x p x. -Axiom - eq_dep_eq : - forall (U:Set) (u:U) (P:U -> Set) (p1 p2:P u), - eq_dep U P u p1 u p2 -> p1 = p2. -\end{coq_example*} - -\Question{What is proof-irrelevance} -\label{proof-irrelevance} - -A specificity of the Calculus of Inductive Constructions is to permit -statements about proofs. This leads to the question of comparing two -proofs of the same proposition. Identifying all proofs of the same -proposition is called {\em proof-irrelevance}: -$$ -\forall A:\Prop, \forall p q:A, p=q -$$ - -Proof-irrelevance (in {\Prop}) can be assumed without contradiction in -{\Coq}. It expresses that only provability matters, whatever the exact -form of the proof is. This is in harmony with the common purely -logical interpretation of {\Prop}. Contrastingly, proof-irrelevance is -inconsistent in {\Set} since there are types in {\Set}, such as the -type of booleans, that provably have at least two distinct elements. - -Proof-irrelevance (in {\Prop}) is a consequence of classical logic -(see proofs in file \vfile{\LogicClassical}{Classical} and -\vfile{\LogicBerardi}{Berardi}). Proof-irrelevance is also a -consequence of propositional extensionality (i.e. \coqtt{(A {\coqequiv} B) -{\coqimp} A=B}, see the proof in file -\vfile{\LogicClassicalFacts}{ClassicalFacts}). - -Proof-irrelevance directly implies Streicher's axiom $K$. - -\Question{What about functional extensionality?} - -Extensionality of functions is admittedly consistent with the -Set-predicative Calculus of Inductive Constructions. - -%\begin{coq_example*} -% Axiom extensionality : (A,B:Set)(f,g:(A->B))(x:A)(f x)=(g x)->f=g. -%\end{coq_example*} - -Let {\tt A}, {\tt B} be types. To deal with extensionality on -\verb=A->B= without relying on a general extensionality axiom, -a possible approach is to define one's own extensional equality on -\verb=A->B=. - -\begin{coq_eval} -Variables A B : Set. -\end{coq_eval} - -\begin{coq_example*} -Definition ext_eq (f g: A->B) := forall x:A, f x = g x. -\end{coq_example*} - -and to reason on \verb=A->B= as a setoid (see the Chapter on -Setoids in the Reference Manual). - -\Question{Is {\Prop} impredicative?} - -Yes, the sort {\Prop} of propositions is {\em -impredicative}. Otherwise said, a statement of the form $\forall -A:Prop, P(A)$ can be instantiated by itself: if $\forall A:\Prop, P(A)$ -is provable, then $P(\forall A:\Prop, P(A))$ is. - -\Question{Is {\Set} impredicative?} - -No, the sort {\Set} lying at the bottom of the hierarchy of -computational types is {\em predicative} in the basic {\Coq} system. -This means that a family of types in {\Set}, e.g. $\forall A:\Set, A -\rightarrow A$, is not a type in {\Set} and it cannot be applied on -itself. - -However, the sort {\Set} was impredicative in the original versions of -{\Coq}. For backward compatibility, or for experiments by -knowledgeable users, the logic of {\Coq} can be set impredicative for -{\Set} by calling {\Coq} with the option {\tt -impredicative-set}. - -{\Set} has been made predicative from version 8.0 of {\Coq}. The main -reason is to interact smoothly with a classical mathematical world -where both excluded-middle and the axiom of description are valid (see -file \vfile{\LogicClassicalDescription}{ClassicalDescription} for a -proof that excluded-middle and description implies the double negation -of excluded-middle in {\Set} and file {\tt Hurkens\_Set.v} from the -user contribution {\tt Paradoxes} at -\ahref{http://coq.inria.fr/contribs}{\url{http://coq.inria.fr/contribs}} -for a proof that impredicativity of {\Set} implies the simple negation -of excluded-middle in {\Set}). - -\Question{Is {\Type} impredicative?} - -No, {\Type} is stratified. This is hidden for the -user, but {\Coq} internally maintains a set of constraints ensuring -stratification. - -If {\Type} were impredicative then it would be possible to encode -Girard's systems $U-$ and $U$ in {\Coq} and it is known from Girard, -Coquand, Hurkens and Miquel that systems $U-$ and $U$ are inconsistent -[Girard 1972, Coquand 1991, Hurkens 1993, Miquel 2001]. This encoding -can be found in file {\tt Logic/Hurkens.v} of {\Coq} standard library. - -For instance, when the user see {\tt $\forall$ X:Type, X->X : Type}, each -occurrence of {\Type} is implicitly bound to a different level, say -$\alpha$ and $\beta$ and the actual statement is {\tt -forall X:Type($\alpha$), X->X : Type($\beta$)} with the constraint -$\alpha<\beta$. - -When a statement violates a constraint, the message {\tt Universe -inconsistency} appears. Example: {\tt fun (x:Type) (y:$\forall$ X:Type, X -{\coqimp} X) => y x x}. - -\Question{I have two proofs of the same proposition. Can I prove they are equal?} - -In the base {\Coq} system, the answer is generally no. However, if -classical logic is set, the answer is yes for propositions in {\Prop}. -The answer is also yes if proof irrelevance holds (see question -\ref{proof-irrelevance}). - -There are also ``simple enough'' propositions for which you can prove -the equality without requiring any extra axioms. This is typically -the case for propositions defined deterministically as a first-order -inductive predicate on decidable sets. See for instance in question -\ref{le-uniqueness} an axiom-free proof of the uniqueness of the proofs of -the proposition {\tt le m n} (less or equal on {\tt nat}). - -% It is an ongoing work of research to natively include proof -% irrelevance in {\Coq}. - -\Question{I have two proofs of an equality statement. Can I prove they are -equal?} - - Yes, if equality is decidable on the domain considered (which -is the case for {\tt nat}, {\tt bool}, etc): see {\Coq} file -\verb=Eqdep_dec.v=). No otherwise, unless -assuming Streicher's axiom $K$ (see \cite{HofStr98}) or a more general -assumption such as proof-irrelevance (see \ref{proof-irrelevance}) or -classical logic. - -All of these statements can be found in file \vfile{\LogicEqdep}{Eqdep}. - -\Question{Can I prove that the second components of equal dependent -pairs are equal?} - - The answer is the same as for proofs of equality -statements. It is provable if equality on the domain of the first -component is decidable (look at \verb=inj_right_pair= from file -\vfile{\LogicEqdepDec}{Eqdep\_dec}), but not provable in the general -case. However, it is consistent (with the Calculus of Constructions) -to assume it is true. The file \vfile{\LogicEqdep}{Eqdep} actually -provides an axiom (equivalent to Streicher's axiom $K$) which entails -the result (look at \verb=inj_pair2= in \vfile{\LogicEqdep}{Eqdep}). - -\subsection{Impredicativity} - -\Question{Why {\tt injection} does not work on impredicative {\tt Set}?} - - E.g. in this case (this occurs only in the {\tt Set}-impredicative - variant of \Coq): - -\begin{coq_example*} -Inductive I : Type := - intro : forall k:Set, k -> I. -Lemma eq_jdef : - forall x y:nat, intro _ x = intro _ y -> x = y. -Proof. - intros x y H; injection H. -\end{coq_example*} - -\begin{coq_eval} -Reset Initial. -\end{coq_eval} - - Injectivity of constructors is restricted to predicative types. If -injectivity on large inductive types were not restricted, we would be -allowed to derive an inconsistency (e.g. following the lines of -Burali-Forti paradox). The question remains open whether injectivity -is consistent on some large inductive types not expressive enough to -encode known paradoxes (such as type I above). - - -\Question{What is a ``large inductive definition''?} - -An inductive definition in {\Prop} or {\Set} is called large -if its constructors embed sets or propositions. As an example, here is -a large inductive type: - -\begin{coq_example*} -Inductive sigST (P:Set -> Set) : Type := - existST : forall X:Set, P X -> sigST P. -\end{coq_example*} - -In the {\tt Set} impredicative variant of {\Coq}, large inductive -definitions in {\tt Set} have restricted elimination schemes to -prevent inconsistencies. Especially, projecting the set or the -proposition content of a large inductive definition is forbidden. If -it were allowed, it would be possible to encode e.g. Burali-Forti -paradox \cite{Gir70,Coq85}. - - -\Question{Is Coq's logic conservative over Coquand's Calculus of -Constructions?} - -In the {\Set}-impredicative version of the Calculus of Inductive -Constructions (CIC), there are two ways to interpret the Calculus of -Constructions (CC) since the impredicative sort of CC can be -interpreted either as {\Prop} or as {\Set}. In the {\Set}-predicative -CIC, the impredicative sort of CC can only be interpreted as {\Prop}. - -If the impredicative sort of CC is interpreted as {\Set}, there is no -conservativity of CIC over CC as the discrimination of -constructors of inductive types in {\Set} transports to a -discrimination of constructors of inductive types encoded -impredicatively. Concretely, considering the impredicative encoding of -Boolean, equality and falsity, we can prove the following CC statement -DISCR in CIC which is not provable in CC, as CC has a -``term-irrelevant'' model. - -\begin{coq_example*} -Definition BOOL := forall X:Set, X -> X -> X. -Definition TRUE : BOOL := fun X x1 x2 => x1. -Definition FALSE : BOOL := fun X x1 x2 => x2. -Definition EQBOOL (x1 x2:BOOL) := forall P:BOOL->Set, P x1 -> P x2. -Definition BOT := forall X:Set, X. - -Definition BOOL2bool : BOOL -> bool := fun b => b bool true false. - -Theorem DISCR : EQBOOL TRUE FALSE -> BOT. -intro X. -assert (H : BOOL2bool TRUE = BOOL2bool FALSE). -{ apply X. trivial. } -discriminate H. -Qed. -\end{coq_example*} - -If the impredicative sort of CC is interpreted as {\Prop}, CIC is -presumably conservative over CC. The general idea is that no -proof-relevant information can flow from {\Prop} to {\Set}, even -though singleton elimination can be used. Hence types in {\Set} should -be smashable to the unit type and {\Set} and {\Type} themselves be -mapped to {\Prop}. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{Talkin' with the Rooster} - - -%%%%%%% -\subsection{My goal is ..., how can I prove it?} - - -\Question{My goal is a conjunction, how can I prove it?} - -Use some theorem or assumption or use the {\split} tactic. -\begin{coq_example} -Goal forall A B:Prop, A -> B -> A/\B. -intros. -split. -assumption. -assumption. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - -\Question{My goal contains a conjunction as an hypothesis, how can I use it?} - -If you want to decompose a hypothesis into several hypotheses, you can -use the {\destruct} tactic: - -\begin{coq_example} -Goal forall A B:Prop, A/\B -> B. -intros. -destruct H as [H1 H2]. -assumption. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - -You can also perform the destruction at the time of introduction: - -\begin{coq_example} -Goal forall A B:Prop, A/\B -> B. -intros A B [H1 H2]. -assumption. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - -\Question{My goal is a disjunction, how can I prove it?} - -You can prove the left part or the right part of the disjunction using -{\left} or {\right} tactics. If you want to do a classical -reasoning step, use the {\tt classic} axiom to prove the right part with the assumption -that the left part of the disjunction is false. - -\begin{coq_example} -Goal forall A B:Prop, A -> A\/B. -intros. -left. -assumption. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - -An example using classical reasoning: - -\begin{coq_example} -Require Import Classical. - -Ltac classical_right := -match goal with -| _:_ |- ?X1 \/ _ => (elim (classic X1);intro;[left;trivial|right]) -end. - -Ltac classical_left := -match goal with -| _:_ |- _ \/ ?X1 => (elim (classic X1);intro;[right;trivial|left]) -end. - - -Goal forall A B:Prop, (~A -> B) -> A\/B. -intros. -classical_right. -auto. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - -\Question{My goal is an universally quantified statement, how can I prove it?} - -Use some theorem or assumption or introduce the quantified variable in -the context using the {\intro} tactic. If there are several -variables you can use the {\intros} tactic. A good habit is to -provide names for these variables: {\Coq} will do it anyway, but such -automatic naming decreases legibility and robustness. - - -\Question{My goal contains an universally quantified statement, how can I use it?} - -If the universally quantified assumption matches the goal you can -use the {\apply} tactic. If it is an equation you can use the -{\rewrite} tactic. Otherwise you can use the {\specialize} tactic -to instantiate the quantified variables with terms. The variant -{\tt assert(Ht := H t)} makes a copy of assumption {\tt H} before -instantiating it. - - -\Question{My goal is an existential, how can I prove it?} - -Use some theorem or assumption or exhibit the witness using the {\existstac} tactic. -\begin{coq_example} -Goal exists x:nat, forall y, x+y=y. -exists 0. -intros. -auto. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - - -\Question{My goal is solvable by some lemma, how can I prove it?} - -Just use the {\apply} tactic. - -\begin{coq_eval} -Reset Initial. -\end{coq_eval} - -\begin{coq_example} -Lemma mylemma : forall x, x+0 = x. -auto. -Qed. - -Goal 3+0 = 3. -apply mylemma. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - - - -\Question{My goal contains False as an hypothesis, how can I prove it?} - -You can use the {\contradiction} or {\intuition} tactics. - - -\Question{My goal is an equality of two convertible terms, how can I prove it?} - -Just use the {\reflexivity} tactic. - -\begin{coq_example} -Goal forall x, 0+x = x. -intros. -reflexivity. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - -\Question{My goal is a {\tt let x := a in ...}, how can I prove it?} - -Just use the {\intro} tactic. - - -\Question{My goal is a {\tt let (a, ..., b) := c in}, how can I prove it?} - -Just use the {\destruct} c as (a,...,b) tactic. - - -\Question{My goal contains some existential hypotheses, how can I use it?} - -As with conjunctive hypotheses, you can use the {\destruct} tactic or -the {\intros} tactic to decompose them into several hypotheses. - -\begin{coq_example*} -Require Import Arith. -\end{coq_example*} -\begin{coq_example} -Goal forall x, (exists y, x * y = 1) -> x = 1. -intros x [y H]. -apply mult_is_one in H. -easy. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - - -\Question{My goal is an equality, how can I swap the left and right hand terms?} - -Just use the {\symmetry} tactic. -\begin{coq_example} -Goal forall x y : nat, x=y -> y=x. -intros. -symmetry. -assumption. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - -\Question{My hypothesis is an equality, how can I swap the left and right hand terms?} - -Just use the {\symmetryin} tactic. - -\begin{coq_example} -Goal forall x y : nat, x=y -> y=x. -intros. -symmetry in H. -assumption. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - - -\Question{My goal is an equality, how can I prove it by transitivity?} - -Just use the {\transitivity} tactic. -\begin{coq_example} -Goal forall x y z : nat, x=y -> y=z -> x=z. -intros. -transitivity y. -assumption. -assumption. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - - -\Question{My goal would be solvable using {\tt apply;assumption} if it would not create meta-variables, how can I prove it?} - -You can use {\tt eapply yourtheorem;eauto} but it won't work in all cases ! (for example if more than one hypothesis match one of the subgoals generated by \eapply) so you should rather use {\tt try solve [eapply yourtheorem;eauto]}, otherwise some metavariables may be incorrectly instantiated. - -\begin{coq_example} -Lemma trans : forall x y z : nat, x=y -> y=z -> x=z. -intros. -transitivity y;assumption. -Qed. - -Goal forall x y z : nat, x=y -> y=z -> x=z. -intros. -eapply trans;eauto. -Qed. - -Goal forall x y z t : nat, x=y -> x=t -> y=z -> x=z. -intros. -eapply trans;eauto. -Undo. -eapply trans. -apply H. -auto. -Qed. - -Goal forall x y z t : nat, x=y -> x=t -> y=z -> x=z. -intros. -eapply trans;eauto. -Undo. -try solve [eapply trans;eauto]. -eapply trans. -apply H. -auto. -Qed. -\end{coq_example} - -\Question{My goal is solvable by some lemma within a set of lemmas and I don't want to remember which one, how can I prove it?} - -You can use a what is called a hints' base. - -\begin{coq_example} -Require Import ZArith. -Require Ring. -Local Open Scope Z_scope. -Lemma toto1 : 1+1 = 2. -ring. -Qed. -Lemma toto2 : 2+2 = 4. -ring. -Qed. -Lemma toto3 : 2+1 = 3. -ring. -Qed. - -Hint Resolve toto1 toto2 toto3 : mybase. - -Goal 2+(1+1)=4. -auto with mybase. -Qed. -\end{coq_example} - - -\Question{My goal is one of the hypotheses, how can I prove it?} - -Use the {\assumption} tactic. - -\begin{coq_example} -Goal 1=1 -> 1=1. -intro. -assumption. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - - -\Question{My goal appears twice in the hypotheses and I want to choose which one is used, how can I do it?} - -Use the {\exact} tactic. -\begin{coq_example} -Goal 1=1 -> 1=1 -> 1=1. -intros. -exact H0. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - -\Question{What can be the difference between applying one hypothesis or another in the context of the last question?} - -From a proof point of view it is equivalent but if you want to extract -a program from your proof, the two hypotheses can lead to different -programs. - - -\Question{My goal is a propositional tautology, how can I prove it?} - -Just use the {\tauto} tactic. -\begin{coq_example} -Goal forall A B:Prop, A-> (A\/B) /\ A. -intros. -tauto. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - -\Question{My goal is a first order formula, how can I prove it?} - -Just use the semi-decision tactic: \firstorder. - -\iffalse -todo: demander un exemple à Pierre -\fi - -\Question{My goal is solvable by a sequence of rewrites, how can I prove it?} - -Just use the {\congruence} tactic. -\begin{coq_example} -Goal forall a b c d e, a=d -> b=e -> c+b=d -> c+e=a. -intros. -congruence. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - - -\Question{My goal is a disequality solvable by a sequence of rewrites, how can I prove it?} - -Just use the {\congruence} tactic. - -\begin{coq_example} -Goal forall a b c d, a<>d -> b=a -> d=c+b -> b<>c+b. -intros. -congruence. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - - -\Question{My goal is an equality on some ring (e.g. natural numbers), how can I prove it?} - -Just use the {\ring} tactic. - -\begin{coq_example} -Require Import ZArith. -Require Ring. -Local Open Scope Z_scope. -Goal forall a b : Z, (a+b)*(a+b) = a*a + 2*a*b + b*b. -intros. -ring. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - -\Question{My goal is an equality on some field (e.g. real numbers), how can I prove it?} - -Just use the {\field} tactic. - -\begin{coq_example} -Require Import Reals. -Require Ring. -Local Open Scope R_scope. -Goal forall a b : R, b*a<>0 -> (a/b) * (b/a) = 1. -intros. -field. -split ; auto with real. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - - -\Question{My goal is an inequality on integers in Presburger's arithmetic (an expression build from $+$, $-$, constants, and variables), how can I prove it?} - - -\begin{coq_example} -Require Import ZArith. -Require Omega. -Local Open Scope Z_scope. -Goal forall a : Z, a>0 -> a+a > a. -intros. -omega. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - - -\Question{My goal is an equation solvable using equational hypothesis on some ring (e.g. natural numbers), how can I prove it?} - -You need the {\gb} tactic (see Loïc Pottier's homepage). - -\subsection{Tactics usage} - -\Question{I want to state a fact that I will use later as an hypothesis, how can I do it?} - -If you want to use forward reasoning (first proving the fact and then -using it) you just need to use the {\assert} tactic. If you want to use -backward reasoning (proving your goal using an assumption and then -proving the assumption) use the {\cut} tactic. - -\begin{coq_example} -Goal forall A B C D : Prop, (A -> B) -> (B->C) -> A -> C. -intros. -assert (A->C). -intro;apply H0;apply H;assumption. -apply H2. -assumption. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - -\begin{coq_example} -Goal forall A B C D : Prop, (A -> B) -> (B->C) -> A -> C. -intros. -cut (A->C). -intro. -apply H2;assumption. -intro;apply H0;apply H;assumption. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - - - - -\Question{I want to state a fact that I will use later as an hypothesis and prove it later, how can I do it?} - -You can use {\cut} followed by {\intro} or you can use the following {\Ltac} command: -\begin{verbatim} -Ltac assert_later t := cut t;[intro|idtac]. -\end{verbatim} - -\Question{What is the difference between {\Qed} and {\Defined}?} - -These two commands perform type checking, but when {\Defined} is used the new definition is set as transparent, otherwise it is defined as opaque (see \ref{opaque}). - - -\Question{How can I know what an automation tactic does in my example?} - -You can use its {\tt info} variant: info\_auto, info\_trivial, info\_eauto. - -\Question{Why {\auto} does not work? How can I fix it?} - -You can increase the depth of the proof search or add some lemmas in the base of hints. -Perhaps you may need to use \eauto. - -\Question{What is {\eauto}?} - -This is the same tactic as \auto, but it relies on {\eapply} instead of \apply. - -\Question{How can I speed up {\auto}?} - -You can use \texttt{info\_}{\auto} to replace {\auto} by the tactics it generates. -You can split your hint bases into smaller ones. - - -\Question{What is the equivalent of {\tauto} for classical logic?} - -Currently there are no equivalent tactic for classical logic. You can use Gödel's ``not not'' translation. - - -\Question{I want to replace some term with another in the goal, how can I do it?} - -If one of your hypothesis (say {\tt H}) states that the terms are equal you can use the {\rewrite} tactic. Otherwise you can use the {\replace} {\tt with} tactic. - -\Question{I want to replace some term with another in an hypothesis, how can I do it?} - -You can use the {\rewrite} {\tt in} tactic. - -\Question{I want to replace some symbol with its definition, how can I do it?} - -You can use the {\unfold} tactic. - -\Question{How can I reduce some term?} - -You can use the {\simpl} tactic. - -\Question{How can I declare a shortcut for some term?} - -You can use the {\set} or {\pose} tactics. - -\Question{How can I perform case analysis?} - -You can use the {\case} or {\destruct} tactics. - -\Question{How can I prevent the case tactic from losing information ?} - -You may want to use the (now standard) {\tt case\_eq} tactic. See the Coq'Art page 159. - -\Question{Why should I name my intros?} - -When you use the {\intro} tactic you don't have to give a name to your -hypothesis. If you do so the name will be generated by {\Coq} but your -scripts may be less robust. If you add some hypothesis to your theorem -(or change their order), you will have to change your proof to adapt -to the new names. - -\Question{How can I automatize the naming?} - -You can use the {\tt Show Intro.} or {\tt Show Intros.} commands to generate the names and use your editor to generate a fully named {\intro} tactic. -This can be automatized within {\tt xemacs}. - -\begin{coq_example} -Goal forall A B C : Prop, A -> B -> C -> A/\B/\C. -Show Intros. -(* -A B C H H0 -H1 -*) -intros A B C H H0 H1. -repeat split;assumption. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - -\Question{I want to automatize the use of some tactic, how can I do it?} - -You need to use the {\tt proof with T} command and add {\ldots} at the -end of your sentences. - -For instance: -\begin{coq_example} -Goal forall A B C : Prop, A -> B/\C -> A/\B/\C. -Proof with assumption. -intros. -split... -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - -\Question{I want to execute the {\texttt proof with} tactic only if it solves the goal, how can I do it?} - -You need to use the {\try} and {\solve} tactics. For instance: -\begin{coq_example} -Require Import ZArith. -Require Ring. -Local Open Scope Z_scope. -Goal forall a b c : Z, a+b=b+a. -Proof with try solve [ring]. -intros... -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - -\Question{How can I do the opposite of the {\intro} tactic?} - -You can use the {\generalize} tactic. - -\begin{coq_example} -Goal forall A B : Prop, A->B-> A/\B. -intros. -generalize H. -intro. -auto. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - -\Question{One of the hypothesis is an equality between a variable and some term, I want to get rid of this variable, how can I do it?} - -You can use the {\subst} tactic. This will rewrite the equality everywhere and clear the assumption. - -\Question{What can I do if I get ``{\tt generated subgoal term has metavariables in it }''?} - -You should use the {\eapply} tactic, this will generate some goals containing metavariables. - -\Question{How can I instantiate some metavariable?} - -Just use the {\instantiate} tactic. - - -\Question{What is the use of the {\pattern} tactic?} - -The {\pattern} tactic transforms the current goal, performing -beta-expansion on all the applications featuring this tactic's -argument. For instance, if the current goal includes a subterm {\tt -phi(t)}, then {\tt pattern t} transforms the subterm into {\tt (fun -x:A => phi(x)) t}. This can be useful when {\apply} fails on matching, -to abstract the appropriate terms. - -\Question{What is the difference between assert, cut and generalize?} - -PS: Notice for people that are interested in proof rendering that \assert -and {\pose} (and \cut) are not rendered the same as {\generalize} (see the -HELM experimental rendering tool at \ahref{http://helm.cs.unibo.it/library.html}{\url{http://helm.cs.unibo.it}}, link -HELM, link COQ Online). Indeed {\generalize} builds a beta-expanded term -while \assert, {\pose} and {\cut} uses a let-in. - -\begin{verbatim} - (* Goal is T *) - generalize (H1 H2). - (* Goal is A->T *) - ... a proof of A->T ... -\end{verbatim} - -is rendered into something like -\begin{verbatim} - (h) ... the proof of A->T ... - we proved A->T - (h0) by (H1 H2) we proved A - by (h h0) we proved T -\end{verbatim} -while -\begin{verbatim} - (* Goal is T *) - assert q := (H1 H2). - (* Goal is A *) - ... a proof of A ... - (* Goal is A |- T *) - ... a proof of T ... -\end{verbatim} -is rendered into something like -\begin{verbatim} - (q) ... the proof of A ... - we proved A - ... the proof of T ... - we proved T -\end{verbatim} -Otherwise said, {\generalize} is not rendered in a forward-reasoning way, -while {\assert} is. - -\Question{What can I do if \Coq can not infer some implicit argument ?} - -You can state explicitly what this implicit argument is. See \ref{implicit}. - -\Question{How can I explicit some implicit argument ?}\label{implicit} - -Just use \texttt{A:=term} where \texttt{A} is the argument. - -For instance if you want to use the existence of ``nil'' on nat*nat lists: -\begin{verbatim} -exists (nil (A:=(nat*nat))). -\end{verbatim} - -\iffalse -\Question{Is there anyway to do pattern matching with dependent types?} - -todo -\fi - -\subsection{Proof management} - - -\Question{How can I change the order of the subgoals?} - -You can use the {\Focus} command to concentrate on some goal. When the goal is proved you will see the remaining goals. - -\Question{How can I change the order of the hypothesis?} - -You can use the {\tt Move ... after} command. - -\Question{How can I change the name of an hypothesis?} - -You can use the {\tt Rename ... into} command. - -\Question{How can I delete some hypothesis?} - -You can use the {\tt Clear} command. - -\Question{How can use a proof which is not finished?} - -You can use the {\tt Admitted} command to state your current proof as an axiom. -You can use the {\tt give\_up} tactic to omit a portion of a proof. - -\Question{How can I state a conjecture?} - -You can use the {\tt Admitted} command to state your current proof as an axiom. - -\Question{What is the difference between a lemma, a fact and a theorem?} - -From {\Coq} point of view there are no difference. But some tools can -have a different behavior when you use a lemma rather than a -theorem. For instance {\tt coqdoc} will not generate documentation for -the lemmas within your development. - -\Question{How can I organize my proofs?} - -You can organize your proofs using the section mechanism of \Coq. Have -a look at the manual for further information. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{Inductive and Co-inductive types} - -\subsection{General} - -\Question{How can I prove that two constructors are different?} - -You can use the {\discriminate} tactic. - -\begin{coq_example} -Inductive toto : Set := | C1 : toto | C2 : toto. -Goal C1 <> C2. -discriminate. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - -\Question{During an inductive proof, how to get rid of impossible cases of an inductive definition?} - -Use the {\inversion} tactic. - - -\Question{How can I prove that 2 terms in an inductive set are equal? Or different?} - -Have a look at \coqtt{decide equality} and \coqtt{discriminate} in the \ahref{http://coq.inria.fr/doc/main.html}{Reference Manual}. - -\Question{Why is the proof of \coqtt{0+n=n} on natural numbers -trivial but the proof of \coqtt{n+0=n} is not?} - - Since \coqtt{+} (\coqtt{plus}) on natural numbers is defined by analysis on its first argument - -\begin{coq_example} -Print plus. -\end{coq_example} - -{\noindent} The expression \coqtt{0+n} evaluates to \coqtt{n}. As {\Coq} reasons -modulo evaluation of expressions, \coqtt{0+n} and \coqtt{n} are -considered equal and the theorem \coqtt{0+n=n} is an instance of the -reflexivity of equality. On the other side, \coqtt{n+0} does not -evaluate to \coqtt{n} and a proof by induction on \coqtt{n} is -necessary to trigger the evaluation of \coqtt{+}. - -\Question{Why is dependent elimination in Prop not -available by default?} - - -This is just because most of the time it is not needed. To derive a -dependent elimination principle in {\tt Prop}, use the command {\tt Scheme} and -apply the elimination scheme using the \verb=using= option of -\verb=elim=, \verb=destruct= or \verb=induction=. - - -\Question{Argh! I cannot write expressions like ``~{\tt if n <= p then p else n}~'', as in any programming language} -\label{minmax} - -The short answer : You should use {\texttt le\_lt\_dec n p} instead.\\ - -The long answer: That's right, you can't. -If you type for instance the following ``definition'': -\begin{coq_eval} -Reset Initial. -\end{coq_eval} -\begin{coq_example} -Fail Definition max (n p : nat) := if n <= p then p else n. -\end{coq_example} - -As \Coq~ says, the term ``~\texttt{n <= p}~'' is a proposition, i.e. a -statement that belongs to the mathematical world. There are many ways to -prove such a proposition, either by some computation, or using some already -proven theorems. For instance, proving $3-2 \leq 2^{45503}$ is very easy, -using some theorems on arithmetical operations. If you compute both numbers -before comparing them, you risk to use a lot of time and space. - - -On the contrary, a function for computing the greatest of two natural numbers -is an algorithm which, called on two natural numbers -$n$ and $p$, determines whether $n\leq p$ or $p < n$. -Such a function is a \emph{decision procedure} for the inequality of - \texttt{nat}. The possibility of writing such a procedure comes -directly from de decidability of the order $\leq$ on natural numbers. - - -When you write a piece of code like -``~\texttt{if n <= p then \dots{} else \dots}~'' -in a -programming language like \emph{ML} or \emph{Java}, a call to such a -decision procedure is generated. The decision procedure is in general -a primitive function, written in a low-level language, in the correctness -of which you have to trust. - -The standard Library of the system \emph{Coq} contains a -(constructive) proof of decidability of the order $\leq$ on -\texttt{nat} : the function \texttt{le\_lt\_dec} of -the module \texttt{Compare\_dec} of library \texttt{Arith}. - -The following code shows how to define correctly \texttt{min} and -\texttt{max}, and prove some properties of these functions. - -\begin{coq_example} -Require Import Compare_dec. - -Definition max (n p : nat) := if le_lt_dec n p then p else n. - -Definition min (n p : nat) := if le_lt_dec n p then n else p. - -Eval compute in (min 4 7). - -Theorem min_plus_max : forall n p, min n p + max n p = n + p. -Proof. - intros n p; - unfold min, max; - case (le_lt_dec n p); - simpl; auto with arith. -Qed. - -Theorem max_equiv : forall n p, max n p = p <-> n <= p. -Proof. - unfold max; intros n p; case (le_lt_dec n p);simpl; auto. - intuition auto with arith. - split. - intro e; rewrite e; auto with arith. - intro H; absurd (p < p); eauto with arith. -Qed. -\end{coq_example} - -\Question{I wrote my own decision procedure for $\leq$, which -is much faster than yours, but proving such theorems as - \texttt{max\_equiv} seems to be quite difficult} - -Your code is probably the following one: - -\begin{coq_example} -Fixpoint my_le_lt_dec (n p :nat) {struct n}: bool := - match n, p with 0, _ => true - | S n', S p' => my_le_lt_dec n' p' - | _ , _ => false - end. - -Definition my_max (n p:nat) := if my_le_lt_dec n p then p else n. - -Definition my_min (n p:nat) := if my_le_lt_dec n p then n else p. -\end{coq_example} - - -For instance, the computation of \texttt{my\_max 567 321} is almost -immediate, whereas one can't wait for the result of -\texttt{max 56 32}, using \emph{Coq's} \texttt{le\_lt\_dec}. - -This is normal. Your definition is a simple recursive function which -returns a boolean value. Coq's \texttt{le\_lt\_dec} is a \emph{certified -function}, i.e. a complex object, able not only to tell whether $n\leq p$ -or $p<n$, but also of building a complete proof of the correct inequality. -What make \texttt{le\_lt\_dec} inefficient for computing \texttt{min} -and \texttt{max} is the building of a huge proof term. - -Nevertheless, \texttt{le\_lt\_dec} is very useful. Its type -is a strong specification, using the -\texttt{sumbool} type (look at the reference manual or chapter 9 of -\cite{coqart}). Eliminations of the form -``~\texttt{case (le\_lt\_dec n p)}~'' provide proofs of -either $n \leq p$ or $p < n$, allowing easy proofs of some theorems as in -question~\ref{minmax}. Unfortunately, this not the case of your -\texttt{my\_le\_lt\_dec}, which returns a quite non-informative boolean -value. - - -\begin{coq_example} -Check le_lt_dec. -\end{coq_example} - -You should keep in mind that \texttt{le\_lt\_dec} is useful to build -certified programs which need to compare natural numbers, and is not -designed to compare quickly two numbers. - -Nevertheless, the \emph{extraction} of \texttt{le\_lt\_dec} towards -\emph{OCaml} or \emph{Haskell}, is a reasonable program for comparing two -natural numbers in Peano form in linear time. - -It is also possible to keep your boolean function as a decision procedure, -but you have to establish yourself the relationship between \texttt{my\_le\_lt\_dec} and the propositions $n\leq p$ and $p<n$: - -\begin{coq_example*} -Theorem my_le_lt_dec_true : - forall n p, my_le_lt_dec n p = true <-> n <= p. - -Theorem my_le_lt_dec_false : - forall n p, my_le_lt_dec n p = false <-> p < n. -\end{coq_example*} - - -\subsection{Recursion} - -\Question{Why can't I define a non terminating program?} - - Because otherwise the decidability of the type-checking -algorithm (which involves evaluation of programs) is not ensured. On -another side, if non terminating proofs were allowed, we could get a -proof of {\tt False}: - -\begin{coq_example*} -(* This is fortunately not allowed! *) -Fixpoint InfiniteProof (n:nat) : False := InfiniteProof n. -Theorem Paradox : False. -Proof (InfiniteProof O). -\end{coq_example*} - - -\Question{Why only structurally well-founded loops are allowed?} - - The structural order on inductive types is a simple and -powerful notion of termination. The consistency of the Calculus of -Inductive Constructions relies on it and another consistency proof -would have to be made for stronger termination arguments (such -as the termination of the evaluation of CIC programs themselves!). - -In spite of this, all non-pathological termination orders can be mapped -to a structural order. Tools to do this are provided in the file -\vfile{\InitWf}{Wf} of the standard library of {\Coq}. - -\Question{How to define loops based on non structurally smaller -recursive calls?} - - The procedure is as follows (we consider the definition of {\tt -mergesort} as an example). - -\begin{itemize} - -\item Define the termination order, say {\tt R} on the type {\tt A} of -the arguments of the loop. - -\begin{coq_eval} -Reset Initial. -Require Import List. -\end{coq_eval} - -\begin{coq_example*} -Definition R (a b:list nat) := length a < length b. -\end{coq_example*} - -\item Prove that this order is well-founded (in fact that all elements in {\tt A} are accessible along {\tt R}). - -\begin{coq_example*} -Lemma Rwf : well_founded R. -\end{coq_example*} -\begin{coq_eval} -Admitted. -\end{coq_eval} - -\item Define the step function (which needs proofs that recursive -calls are on smaller arguments). - -\begin{coq_example*} -Definition split (l : list nat) - : {l1: list nat | R l1 l} * {l2 : list nat | R l2 l}. -Admitted. -Definition concat (l1 l2 : list nat) : list nat. -Admitted. -Definition merge_step (l : list nat) (f: forall l':list nat, R l' l -> list nat) := - let (lH1,lH2) := (split l) in - let (l1,H1) := lH1 in - let (l2,H2) := lH2 in - concat (f l1 H1) (f l2 H2). -\end{coq_example*} - -\item Define the recursive function by fixpoint on the step function. - -\begin{coq_example*} -Definition merge := Fix Rwf (fun _ => list nat) merge_step. -\end{coq_example*} - -\end{itemize} - -\Question{What is behind the accessibility and well-foundedness proofs?} - - Well-foundedness of some relation {\tt R} on some type {\tt A} -is defined as the accessibility of all elements of {\tt A} along {\tt R}. - -\begin{coq_example} -Print well_founded. -Print Acc. -\end{coq_example} - -The structure of the accessibility predicate is a well-founded tree -branching at each node {\tt x} in {\tt A} along all the nodes {\tt x'} -less than {\tt x} along {\tt R}. Any sequence of elements of {\tt A} -decreasing along the order {\tt R} are branches in the accessibility -tree. Hence any decreasing along {\tt R} is mapped into a structural -decreasing in the accessibility tree of {\tt R}. This is emphasised in -the definition of {\tt fix} which recurs not on its argument {\tt x:A} -but on the accessibility of this argument along {\tt R}. - -See file \vfile{\InitWf}{Wf}. - -\Question{How to perform simultaneous double induction?} - - In general a (simultaneous) double induction is simply solved by an -induction on the first hypothesis followed by an inversion over the -second hypothesis. Here is an example - -\begin{coq_eval} -Reset Initial. -\end{coq_eval} - -\begin{coq_example} -Inductive even : nat -> Prop := - | even_O : even 0 - | even_S : forall n:nat, even n -> even (S (S n)). - -Inductive odd : nat -> Prop := - | odd_SO : odd 1 - | odd_S : forall n:nat, odd n -> odd (S (S n)). - -Lemma not_even_and_odd : forall n:nat, even n -> odd n -> False. -induction 1. - inversion 1. - inversion 1. apply IHeven; trivial. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - -In case the type of the second induction hypothesis is not -dependent, {\tt inversion} can just be replaced by {\tt destruct}. - -\Question{How to define a function by simultaneous double recursion?} - - The same trick applies, you can even use the pattern-matching -compilation algorithm to do the work for you. Here is an example: - -\begin{coq_example} -Fixpoint minus (n m:nat) {struct n} : nat := - match n, m with - | O, _ => 0 - | S k, O => S k - | S k, S l => minus k l - end. -Print minus. -\end{coq_example} - -In case of dependencies in the type of the induction objects -$t_1$ and $t_2$, an extra argument stating $t_1=t_2$ must be given to -the fixpoint definition - -\Question{How to perform nested and double induction?} - - To reason by nested (i.e. lexicographic) induction, just reason by -induction on the successive components. - -\smallskip - -Double induction (or induction on pairs) is a restriction of the -lexicographic induction. Here is an example of double induction. - -\begin{coq_example} -Lemma nat_double_ind : -forall P : nat -> nat -> Prop, P 0 0 -> - (forall m n, P m n -> P m (S n)) -> - (forall m n, P m n -> P (S m) n) -> - forall m n, P m n. -intros P H00 HmS HSn; induction m. -(* case 0 *) -induction n; [assumption | apply HmS; apply IHn]. -(* case Sm *) -intro n; apply HSn; apply IHm. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - -\Question{How to define a function by nested recursion?} - - The same trick applies. Here is the example of Ackermann -function. - -\begin{coq_example} -Fixpoint ack (n:nat) : nat -> nat := - match n with - | O => S - | S n' => - (fix ack' (m:nat) : nat := - match m with - | O => ack n' 1 - | S m' => ack n' (ack' m') - end) - end. -\end{coq_example} - - -\subsection{Co-inductive types} - -\Question{I have a cofixpoint $t:=F(t)$ and I want to prove $t=F(t)$. How to do it?} - -Just case-expand $F({\tt t})$ then complete by a trivial case analysis. -Here is what it gives on e.g. the type of streams on naturals - -\begin{coq_eval} -Set Implicit Arguments. -\end{coq_eval} -\begin{coq_example} -CoInductive Stream (A:Set) : Set := - Cons : A -> Stream A -> Stream A. -CoFixpoint nats (n:nat) : Stream nat := Cons n (nats (S n)). -Lemma Stream_unfold : - forall n:nat, nats n = Cons n (nats (S n)). -Proof. - intro; - change (nats n = match nats n with - | Cons x s => Cons x s - end). - case (nats n); reflexivity. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - - - -\section{Syntax and notations} - -\Question{I do not want to type ``forall'' because it is too long, what can I do?} - -You can define your own notation for forall: -\begin{verbatim} -Notation "fa x : t, P" := (forall x:t, P) (at level 200, x ident). -\end{verbatim} -or if your are using {\CoqIde} you can define a pretty symbol for for all and an input method (see \ref{forallcoqide}). - - - -\Question{How can I define a notation for square?} - -You can use for instance: -\begin{verbatim} -Notation "x ^2" := (Rmult x x) (at level 20). -\end{verbatim} -Note that you can not use: -\begin{tt} -Notation "x $^2$" := (Rmult x x) (at level 20). -\end{tt} -because ``$^2$'' is an iso-latin character. If you really want this kind of notation you should use UTF-8. - - -\Question{Why ``no associativity'' and ``left associativity'' at the same level does not work?} - -Because we relie on Camlp4 for syntactical analysis and Camlp4 does not really -implement no associativity. By default, non associative operators are defined -as right associative. - - - -\Question{How can I know the associativity associated with a level?} - -You can do ``Print Grammar constr'', and decode the output from Camlp4, good luck ! - -\section{Modules} - - - - -%%%%%%% -\section{\Ltac} - -\Question{What is {\Ltac}?} - -{\Ltac} is the tactic language for \Coq. It provides the user with a -high-level ``toolbox'' for tactic creation. - -\Question{Is there any printing command in {\Ltac}?} - -You can use the {\idtac} tactic with a string argument. This string -will be printed out. The same applies to the {\fail} tactic - -\Question{What is the syntax for let in {\Ltac}?} - -If $x_i$ are identifiers and $e_i$ and $expr$ are tactic expressions, then let reads: -\begin{center} -{\tt let $x_1$:=$e_1$ with $x_2$:=$e_2$\ldots with $x_n$:=$e_n$ in -$expr$}. -\end{center} -Beware that if $expr$ is complex (i.e. features at least a sequence) parenthesis -should be added around it. For example: -\begin{coq_example} -Ltac twoIntro := let x:=intro in (x;x). -\end{coq_example} - -\Question{What is the syntax for pattern matching in {\Ltac}?} - -Pattern matching on a term $expr$ (non-linear first order unification) -with patterns $p_i$ and tactic expressions $e_i$ reads: -\begin{center} -\hspace{10ex} -{\tt match $expr$ with -\hspace*{2ex}$p_1$ => $e_1$ -\hspace*{1ex}\textbar$p_2$ => $e_2$ -\hspace*{1ex}\ldots -\hspace*{1ex}\textbar$p_n$ => $e_n$ -\hspace*{1ex}\textbar\ \textunderscore\ => $e_{n+1}$ -end. -} -\end{center} -Underscore matches all terms. - -\Question{What is the semantics for ``match goal''?} - -The semantics of {\tt match goal} depends on whether it returns -tactics or not. The {\tt match goal} expression matches the current -goal against a series of patterns: {$hyp_1 {\ldots} hyp_n$ \textbar- -$ccl$}. It uses a first-order unification algorithm and in case of -success, if the right-hand-side is an expression, it tries to type it -while if the right-hand-side is a tactic, it tries to apply it. If the -typing or the tactic application fails, the {\tt match goal} tries all -the possible combinations of $hyp_i$ before dropping the branch and -moving to the next one. Underscore matches all terms. - -\Question{Why can't I use a ``match goal'' returning a tactic in a non -tail-recursive position?} - -This is precisely because the semantics of {\tt match goal} is to -apply the tactic on the right as soon as a pattern unifies what is -meaningful only in tail-recursive uses. - -The semantics in non tail-recursive call could have been the one used -for terms (i.e. fail if the tactic expression is not typable, but -don't try to apply it). For uniformity of semantics though, this has -been rejected. - -\Question{How can I generate a new name?} - -You can use the following syntax: -{\tt let id:=fresh in \ldots}\\ -For example: -\begin{coq_example} -Ltac introIdGen := let id:=fresh in intro id. -\end{coq_example} - - -\iffalse -\Question{How can I access the type of a term?} - -You can use typeof. -todo -\fi - -\iffalse -\Question{How can I define static and dynamic code?} -\fi - -\section{Tactics written in OCaml} - -\Question{Can you show me an example of a tactic written in OCaml?} - -Have a look at the skeleton ``Hello World'' tactic from the next question. -You also have some examples of tactics written in OCaml in the ``plugins'' directory of {\Coq} sources. - -\Question{Is there a skeleton of OCaml tactic I can reuse somewhere?} - -The following steps describe how to write a simplistic ``Hello world'' OCaml -tactic. This takes the form of a dynamically loadable OCaml module, which will -be invoked from the Coq toplevel. -\begin{enumerate} -\item In the \verb+plugins+ directory of the Coq source location, create a -directory \verb+hello+. Proceed to create a grammar and OCaml file, respectively -\verb+plugins/hello/g_hello.ml4+ and \verb+plugins/hello/coq_hello.ml+, -containing: - \begin{itemize} - \item in \verb+g_hello.ml4+: -\begin{verbatim} -(*i camlp4deps: "grammar/grammar.cma" i*) -TACTIC EXTEND Hello -| [ "hello" ] -> [ Coq_hello.printHello ] -END -\end{verbatim} - \item in \verb+coq_hello.ml+: -\begin{verbatim} -let printHello gl = -Tacticals.tclIDTAC_MESSAGE (Pp.str "Hello world") gl - \end{verbatim} - \end{itemize} -\item Create a file \verb+plugins/hello/hello_plugin.mllib+, containing the -names of the OCaml modules bundled in the dynamic library: -\begin{verbatim} -Coq_hello -G_hello -\end{verbatim} -\item Append the following lines in \verb+plugins/plugins{byte,opt}.itarget+: -\begin{itemize} - \item in \verb+pluginsopt.itarget+: -\begin{verbatim} -hello/hello_plugin.cmxa -\end{verbatim} - \item in \verb+pluginsbyte.itarget+: -\begin{verbatim} -hello/hello_plugin.cma -\end{verbatim} -\end{itemize} -\item In the root directory of the Coq source location, modify the file -\verb+Makefile.common+: - \begin{itemize} - \item add \verb+hello+ to the \verb+SRCDIR+ definition (second argument of the - \verb+addprefix+ function); - \item in the section ``Object and Source files'', add \verb+HELLOCMA:=plugins/hello/hello_plugin.cma+; - \item add \verb+$(HELLOCMA)+ to the \verb+PLUGINSCMA+ definition. - \end{itemize} -\item Modify the file \verb+Makefile.build+, adding in section ``3) plugins'' the -line: -\begin{verbatim} -hello: $(HELLOCMA) -\end{verbatim} -\item From the command line, run \verb+make hello+, then \verb+make plugins/hello/hello_plugin.cmxs+. -\end{enumerate} -The call to the tactic \verb+hello+ from a Coq script has to be preceded by -\verb+Declare ML Module "hello_plugin"+, which will load the dynamic object -\verb+hello_plugin.cmxs+. For instance: -\begin{verbatim} -Declare ML Module "hello_plugin". -Variable A:Prop. -Goal A-> A. -Proof. -hello. -auto. -Qed. -\end{verbatim} - - -\section{Case studies} - -\iffalse -\Question{How can I define vectors or lists of size n?} -\fi - - -\Question{How to prove that 2 sets are different?} - - You need to find a property true on one set and false on the -other one. As an example we show how to prove that {\tt bool} and {\tt -nat} are discriminable. As discrimination property we take the -property to have no more than 2 elements. - -\begin{coq_example*} -Theorem nat_bool_discr : bool <> nat. -Proof. - pose (discr := - fun X:Set => - ~ (forall a b:X, ~ (forall x:X, x <> a -> x <> b -> False))). - intro Heq; assert (H: discr bool). - intro H; apply (H true false); destruct x; auto. - rewrite Heq in H; apply H; clear H. - destruct a; destruct b as [|n]; intro H0; eauto. - destruct n; [ apply (H0 2); discriminate | eauto ]. -Qed. -\end{coq_example*} - -\Question{Is there an axiom-free proof of Streicher's axiom $K$ for -the equality on {\tt nat}?} -\label{K-nat} - -Yes, because equality is decidable on {\tt nat}. Here is the proof. - -\begin{coq_example*} -Require Import Eqdep_dec. -Require Import Peano_dec. -Theorem K_nat : - forall (x:nat) (P:x = x -> Prop), P (eq_refl x) -> forall p:x = x, P p. -Proof. -intros; apply K_dec_set with (p := p). -apply eq_nat_dec. -assumption. -Qed. -\end{coq_example*} - -Similarly, we have - -\begin{coq_example*} -Theorem eq_rect_eq_nat : - forall (p:nat) (Q:nat->Type) (x:Q p) (h:p=p), x = eq_rect p Q x p h. -Proof. -intros; apply K_nat with (p := h); reflexivity. -Qed. -\end{coq_example*} - -\Question{How to prove that two proofs of {\tt n<=m} on {\tt nat} are equal?} -\label{le-uniqueness} - -This is provable without requiring any axiom because axiom $K$ -directly holds on {\tt nat}. Here is a proof using question \ref{K-nat}. - -\begin{coq_example*} -Require Import Arith. -Scheme le_ind' := Induction for le Sort Prop. -Theorem le_uniqueness_proof : forall (n m : nat) (p q : n <= m), p = q. -Proof. -induction p using le_ind'; intro q. - replace (le_n n) with - (eq_rect _ (fun n0 => n <= n0) (le_n n) _ eq_refl). - 2:reflexivity. - generalize (eq_refl n). - pattern n at 2 4 6 10, q; case q; [intro | intros m l e]. - rewrite <- eq_rect_eq_nat; trivial. - contradiction (le_Sn_n m); rewrite <- e; assumption. - replace (le_S n m p) with - (eq_rect _ (fun n0 => n <= n0) (le_S n m p) _ eq_refl). - 2:reflexivity. - generalize (eq_refl (S m)). - pattern (S m) at 1 3 4 6, q; case q; [intro Heq | intros m0 l HeqS]. - contradiction (le_Sn_n m); rewrite Heq; assumption. - injection HeqS; intro Heq; generalize l HeqS. - rewrite <- Heq; intros; rewrite <- eq_rect_eq_nat. - rewrite (IHp l0); reflexivity. -Qed. -\end{coq_example*} - -\Question{How to exploit equalities on sets} - -To extract information from an equality on sets, you need to -find a predicate of sets satisfied by the elements of the sets. As an -example, let's consider the following theorem. - -\begin{coq_example*} -Theorem interval_discr : - forall m n:nat, - {x : nat | x <= m} = {x : nat | x <= n} -> m = n. -\end{coq_example*} - -We have a proof requiring the axiom of proof-irrelevance. We -conjecture that proof-irrelevance can be circumvented by introducing a -primitive definition of discrimination of the proofs of -\verb!{x : nat | x <= m}!. - -\begin{latexonly}% -The proof can be found in file {\tt interval$\_$discr.v} in this directory. -%Here is the proof -%\begin{small} -%\begin{flushleft} -%\begin{texttt} -%\def_{\ifmmode\sb\else\subscr\fi} -%\include{interval_discr.v} -%%% WARNING semantics of \_ has changed ! -%\end{texttt} -%$a\_b\_c$ -%\end{flushleft} -%\end{small} -\end{latexonly}% -\begin{htmlonly}% -\ahref{./interval_discr.v}{Here} is the proof. -\end{htmlonly} - -\Question{I have a problem of dependent elimination on -proofs, how to solve it?} - -\begin{coq_eval} -Reset Initial. -\end{coq_eval} - -\begin{coq_example*} -Inductive Def1 : Set := c1 : Def1. -Inductive DefProp : Def1 -> Prop := - c2 : forall d:Def1, DefProp d. -Inductive Comb : Set := - c3 : forall d:Def1, DefProp d -> Comb. -Lemma eq_comb : - forall (d1 d1':Def1) (d2:DefProp d1) (d2':DefProp d1'), - d1 = d1' -> c3 d1 d2 = c3 d1' d2'. -\end{coq_example*} - - You need to derive the dependent elimination -scheme for DefProp by hand using {\coqtt Scheme}. - -\begin{coq_eval} -Abort. -\end{coq_eval} - -\begin{coq_example*} -Scheme DefProp_elim := Induction for DefProp Sort Prop. -Lemma eq_comb : - forall d1 d1':Def1, - d1 = d1' -> - forall (d2:DefProp d1) (d2':DefProp d1'), c3 d1 d2 = c3 d1' d2'. -intros. -destruct H. -destruct d2 using DefProp_elim. -destruct d2' using DefProp_elim. -reflexivity. -Qed. -\end{coq_example*} - - -\Question{And what if I want to prove the following?} - -\begin{coq_example*} -Inductive natProp : nat -> Prop := - | p0 : natProp 0 - | pS : forall n:nat, natProp n -> natProp (S n). -Inductive package : Set := - pack : forall n:nat, natProp n -> package. -Lemma eq_pack : - forall n n':nat, - n = n' -> - forall (np:natProp n) (np':natProp n'), pack n np = pack n' np'. -\end{coq_example*} - - - -\begin{coq_eval} -Abort. -\end{coq_eval} -\begin{coq_example*} -Scheme natProp_elim := Induction for natProp Sort Prop. -Definition pack_S : package -> package. -destruct 1. -apply (pack (S n)). -apply pS; assumption. -Defined. -Lemma eq_pack : - forall n n':nat, - n = n' -> - forall (np:natProp n) (np':natProp n'), pack n np = pack n' np'. -intros n n' Heq np np'. -generalize dependent n'. -induction np using natProp_elim. -induction np' using natProp_elim; intros; auto. - discriminate Heq. -induction np' using natProp_elim; intros; auto. - discriminate Heq. -change (pack_S (pack n np) = pack_S (pack n0 np')). -apply (f_equal (A:=package)). -apply IHnp. -auto. -Qed. -\end{coq_example*} - - - - - - - -\section{Publishing tools} - -\Question{How can I generate some latex from my development?} - -You can use {\tt coqdoc}. - -\Question{How can I generate some HTML from my development?} - -You can use {\tt coqdoc}. - -\Question{How can I generate some dependency graph from my development?} - -You can use the tool \verb|coqgraph| developed by Philippe Audebaud in 2002. -This tool transforms dependencies generated by \verb|coqdep| into 'dot' files which can be visualized using the Graphviz software (http://www.graphviz.org/). - -\Question{How can I cite some {\Coq} in my latex document?} - -You can use {\tt coq\_tex}. - -\Question{How can I cite the {\Coq} reference manual?} - -You can use this bibtex entry (to adapt to the appropriate version): -\begin{verbatim} -@manual{Coq:manual, - author = {{Coq} {Development} {Team}, The}, - title = {The {Coq} Proof Assistant Reference Manual, version 8.7}, - month = Oct, - year = {2017}, - url = {http://coq.inria.fr} -} -\end{verbatim} - -\Question{Where can I publish my developments in {\Coq}?} - -You can submit your developments as a user contribution to the {\Coq} -development team. This ensures its liveness along the evolution and -possible changes of {\Coq}. - -You can also submit your developments to the HELM/MoWGLI repository at -the University of Bologna (see -\ahref{http://mowgli.cs.unibo.it}{\url{http://mowgli.cs.unibo.it}}). For -developments submitted in this database, it is possible to visualize -the developments in natural language and execute various retrieving -requests. - -\Question{How can I read my proof in natural language?} - -You can submit your proof to the HELM/MoWGLI repository and use the -rendering tool provided by the server (see -\ahref{http://mowgli.cs.unibo.it}{\url{http://mowgli.cs.unibo.it}}). - -\section{\CoqIde} - -\Question{What is {\CoqIde}?} - -{\CoqIde} is a gtk based GUI for \Coq. - -\Question{How to enable Emacs keybindings?} - -If in Gnome, run the gnome configuration editor (\texttt{gconf-editor}) -and set key \texttt{gtk-key-theme} to \texttt{Emacs} in the category -\texttt{desktop/gnome/interface}. - -Otherwise, you need to find where the \verb#gtk-key-theme-name# option is located in -your configuration, and set it to \texttt{Emacs}. Usually, it is in the -\verb#$(HOME)/.gtkrc-2.0# file. - - -%$ juste pour que la coloration emacs marche - -\Question{How to enable antialiased fonts?} - - Set the \verb#GDK_USE_XFT# variable to \verb#1#. This is by default - with \verb#Gtk >= 2.2#. If some of your fonts are not available, - set \verb#GDK_USE_XFT# to \verb#0#. - -\Question{How to use those Forall and Exists pretty symbols?}\label{forallcoqide} - Thanks to the notation features in \Coq, you just need to insert these -lines in your {\Coq} buffer:\\ -\begin{tt} -Notation "$\forall$ x : t, P" := (forall x:t, P) (at level 200, x ident). -\end{tt}\\ -\begin{tt} -Notation "$\exists$ x : t, P" := (exists x:t, P) (at level 200, x ident). -\end{tt} - -Copy/Paste of these lines from this file will not work outside of \CoqIde. -You need to load a file containing these lines or to enter the $\forall$ -using an input method (see \ref{inputmeth}). To try it just use \verb#Require Import utf8# from inside -\CoqIde. -To enable these notations automatically start coqide with -\begin{verbatim} - coqide -l utf8 -\end{verbatim} -In the ide subdir of {\Coq} library, you will find a sample utf8.v with some -pretty simple notations. - -\Question{How to define an input method for non ASCII symbols?}\label{inputmeth} - -\begin{itemize} -\item First solution: type \verb#<CONTROL><SHIFT>2200# to enter a forall in the script widow. - 2200 is the hexadecimal code for forall in unicode charts and is encoded as - in UTF-8. - 2203 is for exists. See \ahref{http://www.unicode.org}{\url{http://www.unicode.org}} for more codes. -\item Second solution: rebind \verb#<AltGr>a# to forall and \verb#<AltGr>e# to exists. - - Under X11, one can add those lines in the file ~/.xmodmaprc : - -\begin{verbatim} -! forall -keycode 24 = a A a A U2200 NoSymbol U2200 NoSymbol -! exists -keycode 26 = e E e E U2203 NoSymbol U2203 NoSymbol -\end{verbatim} -and then run xmodmap ~/.xmodmaprc. -\end{itemize} - - Alternatively, you may use an input method editor such as SCIM or iBus. -The latter offers a \LaTeX-like input method. - -\Question{How to customize the shortcuts for menus?} - Two solutions are offered: -\begin{itemize} -\item Edit \verb+$XDG_CONFIG_HOME/coq/coqide.keys+ (which is usually \verb+$HOME/.config/coq/coqide.keys+) by hand or -\item If your system supports it, from \CoqIde, you may select a menu entry and press the desired - shortcut. -\end{itemize} - -\Question{What encoding should I use? What is this $\backslash$x\{iiii\} in my file?} - The encoding option is related to the way files are saved. - Keep it as UTF-8 until it becomes important for you to exchange files - with non UTF-8 aware applications. - If you choose something else than UTF-8, then missing characters will - be encoded by $\backslash$x\{....\} or $\backslash$x\{........\} - where each dot is an hex. digit. - The number between braces is the hexadecimal UNICODE index for the - missing character. - -\Question{How to get rid of annoying unwanted automatic templates?} - -Some users may experiment problems with unwanted automatic -templates while using Coqide. This is due to a change in the -modifiers keys available through GTK. The straightest way to get -rid of the problem is to edit by hand your coqiderc (either -\verb|/home/<user>/.config/coq/coqiderc| under Linux, or \\ -\verb|C:\Documents and Settings\<user>\.config\coq\coqiderc| under Windows) -and replace any occurrence of \texttt{MOD4} by \texttt{MOD1}. - - - -\section{Extraction} - -\Question{What is program extraction?} - -Program extraction consist in generating a program from a constructive proof. - -\Question{Which language can I extract to?} - -You can extract your programs to Objective Caml and Haskell. - -\Question{How can I extract an incomplete proof?} - -You can provide programs for your axioms. - - - -%%%%%%% -\section{Glossary} - -\Question{Can you explain me what an evaluable constant is?} - -An evaluable constant is a constant which is unfoldable. - -\Question{What is a goal?} - -The goal is the statement to be proved. - -\Question{What is a meta variable?} - -A meta variable in {\Coq} represents a ``hole'', i.e. a part of a proof -that is still unknown. - -\Question{What is Gallina?} - -Gallina is the specification language of \Coq. Complete documentation -of this language can be found in the Reference Manual. - -\Question{What is The Vernacular?} - -It is the language of commands of Gallina i.e. definitions, lemmas, {\ldots} - - -\Question{What is a dependent type?} - -A dependent type is a type which depends on some term. For instance -``vector of size n'' is a dependent type representing all the vectors -of size $n$. Its type depends on $n$ - -\Question{What is a proof by reflection?} - -This is a proof generated by some computation which is done using the -internal reduction of {\Coq} (not using the tactic language of {\Coq} -(\Ltac) nor the implementation language for \Coq). An example of -tactic using the reflection mechanism is the {\ring} tactic. The -reflection method consist in reflecting a subset of {\Coq} language (for -example the arithmetical expressions) into an object of the {\Coq} -language itself (in this case an inductive type denoting arithmetical -expressions). For more information see~\cite{howe,harrison,boutin} -and the last chapter of the Coq'Art. - -\Question{What is intuitionistic logic?} - -This is any logic which does not assume that ``A or not A''. - - -\Question{What is proof-irrelevance?} - -See question \ref{proof-irrelevance} - - -\Question{What is the difference between opaque and transparent?}{\label{opaque}} - -Opaque definitions can not be unfolded but transparent ones can. - - -\section{Troubleshooting} - -\Question{What can I do when {\tt Qed.} is slow?} - -Sometime you can use the {\abstracttac} tactic, which makes as if you had -stated some local lemma, this speeds up the typing process. - -\Question{Why \texttt{Reset Initial.} does not work when using \texttt{coqc}?} - -The initial state corresponds to the state of \texttt{coqtop} when the interactive -session began. It does not make sense in files to compile. - - -\Question{What can I do if I get ``No more subgoals but non-instantiated existential variables''?} - -This means that {\eauto} or {\eapply} didn't instantiate an -existential variable which eventually got erased by some computation. -You may backtrack to the faulty occurrence of {\eauto} or {\eapply} -and give the missing argument an explicit value. Alternatively, you -can use the commands \texttt{Show Existentials.} and -\texttt{Existential.} to display and instantiate the remaining -existential variables. - - -\begin{coq_example} -Lemma example_show_existentials : forall a b c:nat, a=b -> b=c -> a=c. -Proof. -intros. -eapply eq_trans. -Show Existentials. -eassumption. -assumption. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - - -\Question{What can I do if I get ``Cannot solve a second-order unification problem''?} - -You can help {\Coq} using the {\pattern} tactic. - - -\Question{I copy-paste a term and {\Coq} says it is not convertible - to the original term. Sometimes it even says the copied term is not -well-typed.} - - This is probably due to invisible implicit information (implicit -arguments, coercions and Cases annotations) in the printed term, which -is not re-synthesised from the copied-pasted term in the same way as -it is in the original term. - - Consider for instance {\tt (@eq Type True True)}. This term is -printed as {\tt True=True} and re-parsed as {\tt (@eq Prop True -True)}. The two terms are not convertible (hence they fool tactics -like {\tt pattern}). - - There is currently no satisfactory answer to the problem. However, -the command {\tt Set Printing All} is useful for diagnosing the -problem. - - Due to coercions, one may even face type-checking errors. In some -rare cases, the criterion to hide coercions is a bit too loose, which -may result in a typing error message if the parser is not able to find -again the missing coercion. - - - -\section{Conclusion and Farewell.} -\label{ccl} - -\Question{What if my question isn't answered here?} -\label{lastquestion} - -Don't panic \verb+:-)+. You can try the {\Coq} manual~\cite{Coq:manual} for a technical -description of the prover. The Coq'Art~\cite{Coq:coqart} is the first -book written on {\Coq} and provides a comprehensive review of the -theorem prover as well as a number of example and exercises. Finally, -the tutorial~\cite{Coq:Tutorial} provides a smooth introduction to -theorem proving in \Coq. - - -%%%%%%% -\newpage -\nocite{LaTeX:intro} -\nocite{LaTeX:symb} -\bibliography{fk} - -%%%%%%% -\typeout{*********************************************} -\typeout{********* That makes {\thequestion} questions **********} -\typeout{*********************************************} - -\end{document} diff --git a/doc/faq/axioms.fig b/doc/faq/axioms.fig deleted file mode 100644 index 9631785030..0000000000 --- a/doc/faq/axioms.fig +++ /dev/null @@ -1,131 +0,0 @@ -#FIG 3.2 Produced by xfig version 3.2.5c -Landscape -Center -Inches -Letter -100.00 -Single --2 -1200 2 -5 1 0 1 0 7 50 -1 -1 0.000 0 1 1 0 14032.500 7222.500 4725 3825 4425 4800 4200 6000 - 1 1 1.00 60.00 120.00 -5 1 0 1 0 7 50 -1 -1 0.000 0 0 0 1 3600.000 8925.000 3600 9075 3450 8925 3600 8775 - 1 1 1.00 60.00 120.00 -5 1 0 1 0 7 50 -1 -1 0.000 0 0 0 1 3600.000 8625.000 3600 8775 3450 8625 3600 8475 - 1 1 1.00 60.00 120.00 -5 1 0 1 0 7 50 -1 -1 0.000 0 0 1 1 3600.000 8325.000 3600 8475 3450 8325 3600 8175 - 1 1 1.00 60.00 120.00 - 1 1 1.00 60.00 120.00 -5 1 0 1 0 7 50 -1 -1 0.000 0 0 1 1 3600.000 8625.000 3600 8775 3450 8625 3600 8475 - 1 1 1.00 60.00 120.00 - 1 1 1.00 60.00 120.00 -5 1 0 1 0 7 50 -1 -1 0.000 0 0 1 1 3600.000 8925.000 3600 9075 3450 8925 3600 8775 - 1 1 1.00 60.00 120.00 - 1 1 1.00 60.00 120.00 -5 1 0 1 0 7 50 -1 -1 0.000 0 0 1 1 3600.000 9225.000 3600 9375 3450 9225 3600 9075 - 1 1 1.00 60.00 120.00 - 1 1 1.00 60.00 120.00 -5 1 0 1 0 7 50 -1 -1 0.000 0 1 1 0 6309.515 5767.724 4200 3825 3450 5550 3825 7200 - 1 1 1.00 60.00 120.00 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 - 1 1 1.00 60.00 120.00 - 7725 3900 7200 6000 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 - 1 1 1.00 60.00 120.00 - 7200 6225 7200 7050 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2 - 1 1 1.00 60.00 120.00 - 1 1 1.00 60.00 120.00 - 5550 5625 5550 6000 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2 - 1 1 1.00 60.00 120.00 - 1 1 1.00 60.00 120.00 - 3375 3225 3375 3600 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 - 1 1 1.00 60.00 120.00 - 3373 1950 3376 2250 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2 - 1 1 1.00 60.00 120.00 - 1 1 1.00 60.00 120.00 - 3375 2625 3375 3000 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 - 2175 3600 3750 3600 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 - 1 1 1.00 60.00 120.00 - 3075 2475 2475 2475 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 - 1 1 1.00 60.00 120.00 - 3374 1125 3377 1425 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 - 1 1 1.00 60.00 120.00 - 3075 975 1575 975 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 - 1 1 1.00 60.00 120.00 - 3075 1725 2025 1725 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 4 - 8025 5925 8250 5925 9000 4950 9150 4950 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 - 1 1 1.00 60.00 120.00 - 8625 5400 8250 3900 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 - 1 1 1.00 60.00 120.00 - 7050 7350 4575 7950 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 - 1 1 1.00 60.00 120.00 - 4200 7500 4200 7950 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 2 - 1 1 1.00 60.00 120.00 - 1 1 1.00 60.00 120.00 - 1139 2771 1364 3521 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 - 4425 4875 7350 3825 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 - 1 1 1.00 60.00 120.00 - 1048 1125 1051 1425 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 - 1 1 1.00 60.00 120.00 - 1049 1950 1052 2250 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 - 1 1 1.00 60.00 120.00 - 1500 3900 2175 6000 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 2 - 4575 6000 6450 6000 -2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 - 1 1 1.00 60.00 120.00 - 4714 6255 7039 7080 -2 1 0 1 -1 7 50 -1 -1 0.000 0 0 -1 1 0 2 - 1 1 1.00 60.00 120.00 - 4200 6225 4200 7200 -3 0 0 1 0 7 50 -1 -1 0.000 0 0 0 4 - 6450 7050 4050 6675 3750 6825 3750 7050 - 0.000 1.000 1.000 0.000 -4 0 -1 50 -1 2 12 0.0000 2 135 1440 3675 6225 Excluded-middle\001 -4 0 -1 50 -1 0 12 0.0000 2 180 1065 450 1050 Operator iota\001 -4 0 -1 50 -1 0 12 0.0000 2 180 2850 3150 2400 Constructive indefinite description\001 -4 0 -1 50 -1 0 12 0.0000 2 180 1965 3150 2625 in propositional context\001 -4 0 -1 50 -1 0 12 0.0000 2 135 2235 450 2400 Constructive definite descr.\001 -4 0 -1 50 -1 0 12 0.0000 2 180 1965 450 2625 in propositional context\001 -4 0 -1 50 -1 0 12 0.0000 2 135 1995 3825 3750 Relational choice axiom\001 -4 0 -1 50 -1 0 12 0.0000 2 180 1965 6900 3750 Predicate extensionality\001 -4 0 -1 50 -1 0 12 0.0000 2 180 1710 1275 5025 (if Set impredicative)\001 -4 0 -1 50 -1 0 12 0.0000 2 165 1065 3750 5250 (Diaconescu)\001 -4 0 -1 50 -1 0 12 0.0000 2 180 2070 4950 5550 Propositional degeneracy\001 -4 0 -1 50 -1 0 12 0.0000 2 180 2310 6150 6150 Propositional extensionality\001 -4 0 -1 50 -1 0 12 0.0000 2 180 2325 4950 6525 (needs Prop-impredicativity)\001 -4 0 -1 50 -1 0 12 0.0000 2 165 720 6000 6750 (Berardi)\001 -4 0 -1 50 -1 0 12 0.0000 2 135 1725 1575 6225 Not excluded-middle\001 -4 0 -1 50 -1 0 12 0.0000 2 180 2730 3375 7425 Decidability of equality on any A\001 -4 0 -1 50 -1 0 12 0.0000 2 135 1170 3600 8175 Axiom K on A\001 -4 0 -1 50 -1 0 12 0.0000 2 180 4035 3600 8475 Uniqueness of reflexivity proofs for equality on A\001 -4 0 -1 50 -1 0 12 0.0000 2 180 2865 3600 8775 Uniqueness of equality proofs on A\001 -4 0 -1 50 -1 0 12 0.0000 2 180 5220 3600 9375 Invariance by substitution of reflexivity proofs for equality on A\001 -4 0 -1 50 -1 2 12 0.0000 2 180 2145 9000 5175 Functional extensionality\001 -4 0 -1 50 -1 2 12 0.0000 2 180 3585 3600 9075 Injectivity of equality on Sigma-types on A\001 -4 0 -1 50 -1 2 12 0.0000 2 135 1515 6450 7275 Proof-irrelevance\001 -4 0 -1 50 -1 2 12 0.0000 2 180 1440 3150 1050 Operator epsilon\001 -4 0 -1 50 -1 2 12 0.0000 2 135 1080 3150 1650 Constructive\001 -4 0 -1 50 -1 2 12 0.0000 2 180 1785 3150 1875 indefinite description\001 -4 0 -1 50 -1 2 12 0.0000 2 135 2085 3150 3150 Functional choice axiom\001 -4 0 -1 50 -1 2 12 0.0000 2 135 1080 450 1650 Constructive\001 -4 0 -1 50 -1 2 12 0.0000 2 180 1620 450 1875 definite description\001 -4 0 -1 50 -1 2 12 0.0000 2 180 1980 450 3750 Axiom of unique choice\001 diff --git a/doc/faq/fk.bib b/doc/faq/fk.bib deleted file mode 100644 index 3410427dee..0000000000 --- a/doc/faq/fk.bib +++ /dev/null @@ -1,2221 +0,0 @@ -%%%%%%% FAQ %%%%%%% - -@book{ProofsTypes, - Author="Girard, Jean-Yves and Yves Lafont and Paul Taylor", - Title="Proofs and Types", - Publisher="Cambrige Tracts in Theoretical Computer Science, Cambridge University Press", - Year="1989" -} - -@misc{Types:Dowek, - author = "Gilles Dowek", - title = "Th{\'e}orie des types", - year = 2002, - howpublished = "Lecture notes", - url= "http://www.lix.polytechnique.fr/~dowek/Cours/theories_des_types.ps.gz" -} - -@PHDTHESIS{EGThese, - author = {Eduardo Giménez}, - title = {Un Calcul de Constructions Infinies et son application -a la vérification de systèmes communicants}, - type = {thèse d'Université}, - school = {Ecole Normale Supérieure de Lyon}, - month = {December}, - year = {1996}, -} - - -%%%%%%% Semantique %%%%%%% - -@misc{Sem:cours, - author = "François Pottier", - title = "{Typage et Programmation}", - year = "2002", - howpublished = "Lecture notes", - note = "DEA PSPL" -} - -@inproceedings{Sem:Dubois, - author = {Catherine Dubois}, - editor = {Mark Aagaard and - John Harrison}, - title = "{Proving ML Type Soundness Within Coq}", - pages = {126-144}, - booktitle = {TPHOLs}, - publisher = {Springer}, - series = {Lecture Notes in Computer Science}, - volume = {1869}, - year = {2000}, - isbn = {3-540-67863-8}, - bibsource = {DBLP, http://dblp.uni-trier.de} -} - -@techreport{Sem:Plotkin, -author = {Gordon D. Plotkin}, -institution = {Aarhus University}, -number = {{DAIMI FN-19}}, -title = {{A structural approach to operational semantics}}, -year = {1981} -} - -@article{Sem:RemyV98, - author = "Didier R{\'e}my and J{\'e}r{\^o}me Vouillon", - title = "Objective {ML}: - An effective object-oriented extension to {ML}", - journal = "Theory And Practice of Object Systems", - year = 1998, - volume = "4", - number = "1", - pages = "27--50", - note = {A preliminary version appeared in the proceedings - of the 24th ACM Conference on Principles - of Programming Languages, 1997} -} - -@book{Sem:Winskel, - AUTHOR = {Winskel, Glynn}, - TITLE = {The Formal Semantics of Programming Languages}, - NOTE = {WIN g2 93:1 P-Ex}, - YEAR = {1993}, - PUBLISHER = {The MIT Press}, - SERIES = {Foundations of Computing}, - } - -@Article{Sem:WrightFelleisen, - refkey = "C1210", - title = "A Syntactic Approach to Type Soundness", - author = "Andrew K. Wright and Matthias Felleisen", - pages = "38--94", - journal = "Information and Computation", - month = "15~" # nov, - year = "1994", - volume = "115", - number = "1" -} - -@inproceedings{Sem:Nipkow-MOD, - author={Tobias Nipkow}, - title={Jinja: Towards a Comprehensive Formal Semantics for a - {J}ava-like Language}, - booktitle={Proc.\ Marktobderdorf Summer School 2003}, - publisher={IOS Press},editor={H. Schwichtenberg and K. Spies}, - year=2003, - note={To appear} -} - -%%%%%%% Coq %%%%%%% - -@book{Coq:coqart, - title = "Interactive Theorem Proving and Program Development, - Coq'Art: The Calculus of Inductive Constructions", - author = "Yves Bertot and Pierre Castéran", - publisher = "Springer Verlag", - series = "Texts in Theoretical Computer Science. An - EATCS series", - year = 2004 -} - -@phdthesis{Coq:Del01, - AUTHOR = "David Delahaye", - TITLE = "Conception de langages pour décrire les preuves et les - automatisations dans les outils d'aide à la preuve", - SCHOOL = {Universit\'e Paris~6}, - YEAR = "2001", - Type = {Th\`ese de Doctorat} -} - -@techreport{Coq:gimenez-tut, - author = "Eduardo Gim\'enez", - title = "A Tutorial on Recursive Types in Coq", - number = "RT-0221", - pages = "42 p.", - url = "citeseer.nj.nec.com/gimenez98tutorial.html" } - -@phdthesis{Coq:Mun97, - AUTHOR = "César Mu{\~{n}}oz", - TITLE = "Un calcul de substitutions pour la repr\'esentation - de preuves partielles en th\'eorie de types", - SCHOOL = {Universit\'e Paris~7}, - Number = {Unit\'e de recherche INRIA-Rocquencourt, TU-0488}, - YEAR = "1997", - Note = {English version available as INRIA research report RR-3309}, - Type = {Th\`ese de Doctorat} -} - -@PHDTHESIS{Coq:Filliatre99, - AUTHOR = {J.-C. Filli\^atre}, - TITLE = {{Preuve de programmes imp\'eratifs en th\'eorie des types}}, - TYPE = {Th{\`e}se de Doctorat}, - SCHOOL = {Universit\'e Paris-Sud}, - YEAR = 1999, - MONTH = {July}, -} - -@manual{Coq:Tutorial, - AUTHOR = {G\'erard Huet and Gilles Kahn and Christine Paulin-Mohring}, - TITLE = {{The Coq Proof Assistant A Tutorial}}, - YEAR = 2004 -} - -%%%%%%% PVS %%%%%%% - -@manual{PVS:prover, - title = "{PVS} Prover Guide", - author = "N. Shankar and S. Owre and J. M. Rushby and D. W. J. - Stringer-Calvert", - month = sep, - year = "1999", - organization = "Computer Science Laboratory, SRI International", - address = "Menlo Park, CA", -} - -@techreport{PVS-Semantics:TR, - TITLE = {The Formal Semantics of {PVS}}, - AUTHOR = {Sam Owre and Natarajan Shankar}, - NUMBER = {CR-1999-209321}, - INSTITUTION = {Computer Science Laboratory, SRI International}, - ADDRESS = {Menlo Park, CA}, - MONTH = may, - YEAR = 1999, -} - -@techreport{PVS-Tactics:DiVito, - TITLE = {A {PVS} Prover Strategy Package for Common Manipulations}, - AUTHOR = {Ben L. Di Vito}, - NUMBER = {TM-2002-211647}, - INSTITUTION = {Langley Research Center}, - ADDRESS = {Hampton, VA}, - MONTH = apr, - YEAR = 2002, -} - -@misc{PVS-Tactics:cours, - author = "César Muñoz", - title = "Strategies in {PVS}", - howpublished = "Lecture notes", - note = "National Institute of Aerospace", - year = 2002 -} - -@techreport{PVS-Tactics:field, - author = "C. Mu{\~n}oz and M. Mayero", - title = "Real Automation in the Field", - institution = "ICASE-NASA Langley", - number = "NASA/CR-2001-211271 Interim ICASE Report No. 39", - month = "dec", - year = "2001" -} - -%%%%%%% Autres Prouveurs %%%%%%% - -@misc{ACL2:repNuPrl, - author = "James L. Caldwell and John Cowles", - title = "{Representing Nuprl Proof Objects in ACL2: toward a proof checker for Nuprl}", - url = "http://www.cs.uwyo.edu/~jlc/papers/proof_checking.ps" } - -@inproceedings{Elan:ckl-strat, - author = {H. Cirstea and C. Kirchner and L. Liquori}, - title = "{Rewrite Strategies in the Rewriting Calculus}", - booktitle = {WRLA'02}, - publisher = "{Elsevier Science B.V.}", - series = {Electronic Notes in Theoretical Computer Science}, - volume = {71}, - year = {2003}, -} - -@book{LCF:GMW, - author = {M. Gordon and R. Milner and C. Wadsworth}, - publisher = {sv}, - series = {lncs}, - volume = 78, - title = {Edinburgh {LCF}: A Mechanized Logic of Computation}, - year = 1979 -} - -%%%%%%% LaTeX %%%%%%% - -@manual{LaTeX:symb, - title = "The Great, Big List of \LaTeX\ Symbols", - author = "David Carlisle and Scott Pakin and Alexander Holt", - month = feb, - year = 2001, -} - -@manual{LaTeX:intro, - title = "The Not So Short Introduction to \LaTeX2e", - author = "Tobias Oetiker", - month = jan, - year = 1999, -} - -@MANUAL{CoqManualV7, - AUTHOR = {{The {Coq} Development Team}}, - TITLE = {{The Coq Proof Assistant Reference Manual -- Version - V7.1}}, - YEAR = {2001}, - MONTH = OCT, - NOTE = {http://coq.inria.fr} -} - -@MANUAL{CoqManual96, - TITLE = {The {Coq Proof Assistant Reference Manual} Version 6.1}, - AUTHOR = {B. Barras and S. Boutin and C. Cornes and J. Courant and - J.-C. Filli\^atre and - H. Herbelin and G. Huet and P. Manoury and C. Mu{\~{n}}oz and - C. Murthy and C. Parent and C. Paulin-Mohring and - A. Sa{\"\i}bi and B. Werner}, - ORGANIZATION = {{INRIA-Rocquencourt}-{CNRS-ENS Lyon}}, - URL = {ftp://ftp.inria.fr/INRIA/coq/V6.1/doc/Reference-Manual.dvi.gz}, - YEAR = 1996, - MONTH = DEC -} - -@MANUAL{CoqTutorial99, - AUTHOR = {G.~Huet and G.~Kahn and Ch.~Paulin-Mohring}, - TITLE = {The {\sf Coq} Proof Assistant - A tutorial - Version 6.3}, - MONTH = JUL, - YEAR = {1999}, - ABSTRACT = {http://coq.inria.fr/doc/tutorial.html} -} - -@MANUAL{CoqTutorialV7, - AUTHOR = {G.~Huet and G.~Kahn and Ch.~Paulin-Mohring}, - TITLE = {The {\sf Coq} Proof Assistant - A tutorial - Version 7.1}, - MONTH = OCT, - YEAR = {2001}, - NOTE = {http://coq.inria.fr} -} - -@TECHREPORT{modelpa2000, - AUTHOR = {B. Bérard and P. Castéran and E. Fleury and L. Fribourg - and J.-F. Monin and C. Paulin and A. Petit and D. Rouillard}, - TITLE = {Automates temporisés CALIFE}, - INSTITUTION = {Calife}, - YEAR = 2000, - URL = {http://www.loria.fr/projets/calife/WebCalifePublic/FOURNITURES/F1.1.ps.gz}, - TYPE = {Fourniture {F1.1}} -} - -@TECHREPORT{CaFrPaRo2000, - AUTHOR = {P. Castéran and E. Freund and C. Paulin and D. Rouillard}, - TITLE = {Bibliothèques Coq et Isabelle-HOL pour les systèmes de transitions et les p-automates}, - INSTITUTION = {Calife}, - YEAR = 2000, - URL = {http://www.loria.fr/projets/calife/WebCalifePublic/FOURNITURES/F5.4.ps.gz}, - TYPE = {Fourniture {F5.4}} -} - -@PROCEEDINGS{TPHOLs99, - TITLE = {International Conference on - Theorem Proving in Higher Order Logics (TPHOLs'99)}, - YEAR = 1999, - EDITOR = {Y. Bertot and G. Dowek and C. Paulin-Mohring and L. Th{\'e}ry}, - SERIES = {Lecture Notes in Computer Science}, - MONTH = SEP, - PUBLISHER = {{Sprin\-ger-Verlag}}, - ADDRESS = {Nice}, - TYPE_PUBLI = {editeur} -} - -@INPROCEEDINGS{Pau01, - AUTHOR = {Christine Paulin-Mohring}, - TITLE = {Modelisation of Timed Automata in {Coq}}, - BOOKTITLE = {Theoretical Aspects of Computer Software (TACS'2001)}, - PAGES = {298--315}, - YEAR = 2001, - EDITOR = {N. Kobayashi and B. Pierce}, - VOLUME = 2215, - SERIES = {Lecture Notes in Computer Science}, - PUBLISHER = {Springer-Verlag} -} - -@PHDTHESIS{Moh89b, - AUTHOR = {C. Paulin-Mohring}, - MONTH = JAN, - SCHOOL = {{Paris 7}}, - TITLE = {Extraction de programmes dans le {Calcul des Constructions}}, - TYPE = {Thèse d'université}, - YEAR = {1989}, - URL = {http://www.lri.fr/~paulin/these.ps.gz} -} - -@ARTICLE{HuMo92, - AUTHOR = {G. Huet and C. Paulin-Mohring}, - EDITION = {INRIA}, - JOURNAL = {Courrier du CNRS - Informatique}, - TITLE = {Preuves et Construction de Programmes}, - YEAR = {1992}, - CATEGORY = {national} -} - -@INPROCEEDINGS{LePa94, - AUTHOR = {F. Leclerc and C. Paulin-Mohring}, - TITLE = {Programming with Streams in {Coq}. A case study : The Sieve of Eratosthenes}, - EDITOR = {H. Barendregt and T. Nipkow}, - VOLUME = 806, - SERIES = {Lecture Notes in Computer Science}, - BOOKTITLE = {{Types for Proofs and Programs, Types' 93}}, - YEAR = 1994, - PUBLISHER = {Springer-Verlag} -} - -@INPROCEEDINGS{Moh86, - AUTHOR = {C. Mohring}, - ADDRESS = {Cambridge, MA}, - BOOKTITLE = {Symposium on Logic in Computer Science}, - PUBLISHER = {IEEE Computer Society Press}, - TITLE = {Algorithm Development in the {Calculus of Constructions}}, - YEAR = {1986} -} - -@INPROCEEDINGS{Moh89a, - AUTHOR = {C. Paulin-Mohring}, - ADDRESS = {Austin}, - BOOKTITLE = {Sixteenth Annual ACM Symposium on Principles of Programming Languages}, - MONTH = JAN, - PUBLISHER = {ACM}, - TITLE = {Extracting ${F}_{\omega}$'s programs from proofs in the {Calculus of Constructions}}, - YEAR = {1989} -} - -@INCOLLECTION{Moh89c, - AUTHOR = {C. Paulin-Mohring}, - TITLE = {{R\'ealisabilit\'e et extraction de programmes}}, - BOOKTITLE = {Logique et Informatique : une introduction}, - PUBLISHER = {INRIA}, - YEAR = 1991, - EDITOR = {B. Courcelle}, - VOLUME = 8, - SERIES = {Collection Didactique}, - PAGES = {163-180}, - CATEGORY = {national} -} - -@INPROCEEDINGS{Moh93, - AUTHOR = {C. Paulin-Mohring}, - BOOKTITLE = {Proceedings of the conference Typed Lambda Calculi a -nd Applications}, - EDITOR = {M. Bezem and J.-F. Groote}, - INSTITUTION = {LIP-ENS Lyon}, - NOTE = {LIP research report 92-49}, - NUMBER = 664, - SERIES = {Lecture Notes in Computer Science}, - TITLE = {{Inductive Definitions in the System {Coq} - Rules and Properties}}, - TYPE = {research report}, - YEAR = 1993 -} - -@ARTICLE{PaWe92, - AUTHOR = {C. Paulin-Mohring and B. Werner}, - JOURNAL = {Journal of Symbolic Computation}, - TITLE = {{Synthesis of ML programs in the system Coq}}, - VOLUME = {15}, - YEAR = {1993}, - PAGES = {607--640} -} - -@INPROCEEDINGS{Pau96, - AUTHOR = {C. Paulin-Mohring}, - TITLE = {Circuits as streams in {Coq} : Verification of a sequential multiplier}, - BOOKTITLE = {Types for Proofs and Programs, TYPES'95}, - EDITOR = {S. Berardi and M. Coppo}, - SERIES = {Lecture Notes in Computer Science}, - YEAR = 1996, - VOLUME = 1158 -} - -@PHDTHESIS{Pau96b, - AUTHOR = {Christine Paulin-Mohring}, - TITLE = {Définitions Inductives en Théorie des Types d'Ordre Supérieur}, - SCHOOL = {Université Claude Bernard Lyon I}, - YEAR = 1996, - MONTH = DEC, - TYPE = {Habilitation à diriger les recherches}, - URL = {http://www.lri.fr/~paulin/habilitation.ps.gz} -} - -@INPROCEEDINGS{PfPa89, - AUTHOR = {F. Pfenning and C. Paulin-Mohring}, - BOOKTITLE = {Proceedings of Mathematical Foundations of Programming Semantics}, - NOTE = {technical report CMU-CS-89-209}, - PUBLISHER = {Springer-Verlag}, - SERIES = {Lecture Notes in Computer Science}, - VOLUME = 442, - TITLE = {Inductively defined types in the {Calculus of Constructions}}, - YEAR = {1990} -} - -@MISC{krakatoa02, - AUTHOR = {Claude March\'e and Christine Paulin and Xavier Urbain}, - TITLE = {The \textsc{Krakatoa} proof tool}, - YEAR = 2002, - NOTE = {\url{http://krakatoa.lri.fr/}} -} - -@ARTICLE{marche03jlap, - AUTHOR = {Claude March{\'e} and Christine Paulin-Mohring and Xavier Urbain}, - TITLE = {The \textsc{Krakatoa} Tool for Certification of \textsc{Java/JavaCard} Programs annotated in \textsc{JML}}, - JOURNAL = {Journal of Logic and Algebraic Programming}, - YEAR = 2003, - NOTE = {To appear}, - URL = {http://krakatoa.lri.fr}, - TOPICS = {team} -} -@ARTICLE{marche04jlap, - AUTHOR = {Claude March{\'e} and Christine Paulin-Mohring and Xavier Urbain}, - TITLE = {The \textsc{Krakatoa} Tool for Certification of \textsc{Java/JavaCard} Programs annotated in \textsc{JML}}, - JOURNAL = {Journal of Logic and Algebraic Programming}, - YEAR = 2004, - VOLUME = 58, - NUMBER = {1--2}, - PAGES = {89--106}, - URL = {http://krakatoa.lri.fr}, - TOPICS = {team} -} - -@TECHREPORT{catano03deliv, - AUTHOR = {N{\'e}stor Cata{\~n}o and Marek Gawkowski and -Marieke Huisman and Bart Jacobs and Claude March{\'e} and Christine Paulin -and Erik Poll and Nicole Rauch and Xavier Urbain}, - TITLE = {Logical Techniques for Applet Verification}, - INSTITUTION = {VerifiCard Project}, - YEAR = 2003, - TYPE = {Deliverable}, - NUMBER = {5.2}, - TOPICS = {team}, - NOTE = {Available from \url{http://www.verificard.org}} -} - -@TECHREPORT{kmu2002rr, - AUTHOR = {Keiichirou Kusakari and Claude Marché and Xavier Urbain}, - TITLE = {Termination of Associative-Commutative Rewriting using Dependency Pairs Criteria}, - INSTITUTION = {LRI}, - YEAR = 2002, - TYPE = {Research Report}, - NUMBER = 1304, - TYPE_PUBLI = {interne}, - TOPICS = {team}, - NOTE = {\url{http://www.lri.fr/~urbain/textes/rr1304.ps.gz}}, - URL = {http://www.lri.fr/~urbain/textes/rr1304.ps.gz} -} - -@ARTICLE{marche2004jsc, - AUTHOR = {Claude March\'e and Xavier Urbain}, - TITLE = {Modular {\&} Incremental Proofs of {AC}-Termination}, - JOURNAL = {Journal of Symbolic Computation}, - YEAR = 2004, - TOPICS = {team} -} - -@INPROCEEDINGS{contejean03wst, - AUTHOR = {Evelyne Contejean and Claude Marché and Benjamin Monate and Xavier Urbain}, - TITLE = {{Proving Termination of Rewriting with {\sc C\textit{i}ME}}}, - CROSSREF = {wst03}, - PAGES = {71--73}, - NOTE = {\url{http://cime.lri.fr/}}, - URL = {http://cime.lri.fr/}, - YEAR = 2003, - TYPE_PUBLI = {icolcomlec}, - TOPICS = {team} -} - -@TECHREPORT{contejean04rr, - AUTHOR = {Evelyne Contejean and Claude March{\'e} and Ana-Paula Tom{\'a}s and Xavier Urbain}, - TITLE = {Mechanically proving termination using polynomial interpretations}, - INSTITUTION = {LRI}, - YEAR = {2004}, - TYPE = {Research Report}, - NUMBER = {1382}, - TYPE_PUBLI = {interne}, - TOPICS = {team}, - URL = {http://www.lri.fr/~urbain/textes/rr1382.ps.gz} -} - -@UNPUBLISHED{duran_sub, - AUTHOR = {Francisco Duran and Salvador Lucas and - Claude {March\'e} and {Jos\'e} Meseguer and Xavier Urbain}, - TITLE = {Termination of Membership Equational Programs}, - NOTE = {Submitted} -} - -@PROCEEDINGS{comon95lncs, - TITLE = {Term Rewriting}, - BOOKTITLE = {Term Rewriting}, - TOPICS = {team, cclserver}, - YEAR = 1995, - EDITOR = {Hubert Comon and Jean-Pierre Jouannaud}, - SERIES = {Lecture Notes in Computer Science}, - VOLUME = {909}, - PUBLISHER = {{Sprin\-ger-Verlag}}, - ORGANIZATION = {French Spring School of Theoretical Computer - Science}, - TYPE_PUBLI = {editeur}, - CLEF_LABO = {CJ95} -} - -@PROCEEDINGS{lics94, - TITLE = {Proceedings of the Ninth Annual IEEE Symposium on Logic - in Computer Science}, - BOOKTITLE = {Proceedings of the Ninth Annual IEEE Symposium on Logic - in Computer Science}, - YEAR = 1994, - MONTH = JUL, - ADDRESS = {Paris, France}, - ORGANIZATION = {{IEEE} Comp. Soc. Press} -} - -@PROCEEDINGS{rta91, - TITLE = {4th International Conference on Rewriting Techniques and - Applications}, - BOOKTITLE = {4th International Conference on Rewriting Techniques and - Applications}, - EDITOR = {Ronald. V. Book}, - YEAR = 1991, - MONTH = APR, - ADDRESS = {Como, Italy}, - PUBLISHER = {{Sprin\-ger-Verlag}}, - SERIES = {Lecture Notes in Computer Science}, - VOLUME = 488 -} - -@PROCEEDINGS{rta96, - TITLE = {7th International Conference on Rewriting Techniques and - Applications}, - BOOKTITLE = {7th International Conference on Rewriting Techniques and - Applications}, - EDITOR = {Harald Ganzinger}, - PUBLISHER = {{Sprin\-ger-Verlag}}, - YEAR = 1996, - MONTH = JUL, - ADDRESS = {New Brunswick, NJ, USA}, - SERIES = {Lecture Notes in Computer Science}, - VOLUME = 1103 -} - -@PROCEEDINGS{rta97, - TITLE = {8th International Conference on Rewriting Techniques and - Applications}, - BOOKTITLE = {8th International Conference on Rewriting Techniques and - Applications}, - EDITOR = {Hubert Comon}, - PUBLISHER = {{Sprin\-ger-Verlag}}, - YEAR = 1997, - MONTH = JUN, - ADDRESS = {Barcelona, Spain}, - SERIES = {Lecture Notes in Computer Science}, - VOLUME = {1232} -} - -@PROCEEDINGS{rta98, - TITLE = {9th International Conference on Rewriting Techniques and - Applications}, - BOOKTITLE = {9th International Conference on Rewriting Techniques and - Applications}, - EDITOR = {Tobias Nipkow}, - PUBLISHER = {{Sprin\-ger-Verlag}}, - YEAR = 1998, - MONTH = APR, - ADDRESS = {Tsukuba, Japan}, - SERIES = {Lecture Notes in Computer Science}, - VOLUME = {1379} -} - -@PROCEEDINGS{rta00, - TITLE = {11th International Conference on Rewriting Techniques and Applications}, - BOOKTITLE = {11th International Conference on Rewriting Techniques and Applications}, - EDITOR = {Leo Bachmair}, - PUBLISHER = {{Sprin\-ger-Verlag}}, - SERIES = {Lecture Notes in Computer Science}, - VOLUME = 1833, - MONTH = JUL, - YEAR = 2000, - ADDRESS = {Norwich, UK} -} - -@PROCEEDINGS{srt95, - TITLE = {Proceedings of the Conference on Symbolic Rewriting - Techniques}, - BOOKTITLE = {Proceedings of the Conference on Symbolic Rewriting - Techniques}, - YEAR = 1995, - EDITOR = {Manuel Bronstein and Volker Weispfenning}, - ADDRESS = {Monte Verita, Switzerland} -} - -@BOOK{comon01cclbook, - BOOKTITLE = {Constraints in Computational Logics}, - TITLE = {Constraints in Computational Logics}, - EDITOR = {Hubert Comon and Claude March{\'e} and Ralf Treinen}, - YEAR = 2001, - PUBLISHER = {{Sprin\-ger-Verlag}}, - SERIES = {Lecture Notes in Computer Science}, - VOLUME = 2002, - TOPICS = {team}, - TYPE_PUBLI = {editeur} -} - -@PROCEEDINGS{wst03, - BOOKTITLE = {{Extended Abstracts of the 6th International Workshop on Termination, WST'03}}, - TITLE = {{Extended Abstracts of the 6th International Workshop on Termination, WST'03}}, - YEAR = {2003}, - EDITOR = {Albert Rubio}, - MONTH = JUN, - NOTE = {Technical Report DSIC II/15/03, Universidad Politécnica de Valencia, Spain} -} - -@INPROCEEDINGS{FilliatreLetouzey03, - AUTHOR = {J.-C. Filli\^atre and P. Letouzey}, - TITLE = {{Functors for Proofs and Programs}}, - BOOKTITLE = {Proceedings of The European Symposium on Programming}, - YEAR = 2004, - ADDRESS = {Barcelona, Spain}, - MONTH = {March 29-April 2}, - NOTE = {To appear}, - URL = {http://www.lri.fr/~filliatr/ftp/publis/fpp.ps.gz} -} - -@TECHREPORT{Filliatre03, - AUTHOR = {J.-C. Filli\^atre}, - TITLE = {{Why: a multi-language multi-prover verification tool}}, - INSTITUTION = {{LRI, Universit\'e Paris Sud}}, - TYPE = {{Research Report}}, - NUMBER = {1366}, - MONTH = {March}, - YEAR = 2003, - URL = {http://www.lri.fr/~filliatr/ftp/publis/why-tool.ps.gz} -} - -@ARTICLE{FilliatrePottier02, - AUTHOR = {J.-C. Filli{\^a}tre and F. Pottier}, - TITLE = {{Producing All Ideals of a Forest, Functionally}}, - JOURNAL = {Journal of Functional Programming}, - VOLUME = 13, - NUMBER = 5, - PAGES = {945--956}, - MONTH = {September}, - YEAR = 2003, - URL = {http://www.lri.fr/~filliatr/ftp/publis/kr-fp.ps.gz}, - ABSTRACT = { - We present a functional implementation of Koda and Ruskey's - algorithm for generating all ideals of a forest poset as a Gray - code. Using a continuation-based approach, we give an extremely - concise formulation of the algorithm's core. Then, in a number of - steps, we derive a first-order version whose efficiency is - comparable to a C implementation given by Knuth.} -} - -@UNPUBLISHED{FORS01, - AUTHOR = {J.-C. Filli{\^a}tre and S. Owre and H. Rue{\ss} and N. Shankar}, - TITLE = {Deciding Propositional Combinations of Equalities and Inequalities}, - NOTE = {Unpublished}, - MONTH = OCT, - YEAR = 2001, - URL = {http://www.lri.fr/~filliatr/ftp/publis/ics.ps}, - ABSTRACT = { - We address the problem of combining individual decision procedures - into a single decision procedure. Our combination approach is based - on using the canonizer obtained from Shostak's combination algorithm - for equality. We illustrate our approach with a combination - algorithm for equality, disequality, arithmetic inequality, and - propositional logic. Unlike the Nelson--Oppen combination where the - processing of equalities is distributed across different closed - decision procedures, our combination involves the centralized - processing of equalities in a single procedure. The termination - argument for the combination is based on that for Shostak's - algorithm. We also give soundness and completeness arguments.} -} - -@INPROCEEDINGS{ICS, - AUTHOR = {J.-C. Filli{\^a}tre and S. Owre and H. Rue{\ss} and N. Shankar}, - TITLE = {{ICS: Integrated Canonization and Solving (Tool presentation)}}, - BOOKTITLE = {Proceedings of CAV'2001}, - EDITOR = {G. Berry and H. Comon and A. Finkel}, - PUBLISHER = {Springer-Verlag}, - SERIES = {Lecture Notes in Computer Science}, - VOLUME = 2102, - PAGES = {246--249}, - YEAR = 2001 -} - -@INPROCEEDINGS{Filliatre01a, - AUTHOR = {J.-C. Filli\^atre}, - TITLE = {La supériorité de l'ordre supérieur}, - BOOKTITLE = {Journées Francophones des Langages Applicatifs}, - PAGES = {15--26}, - MONTH = {Janvier}, - YEAR = 2002, - ADDRESS = {Anglet, France}, - URL = {http://www.lri.fr/~filliatr/ftp/publis/sos.ps.gz}, - CODE = {http://www.lri.fr/~filliatr/ftp/ocaml/misc/koda-ruskey.ps}, - ABSTRACT = { - Nous présentons ici une écriture fonctionnelle de l'algorithme de - Koda-Ruskey, un algorithme pour engendrer une large famille - de codes de Gray. En s'inspirant de techniques de programmation par - continuation, nous aboutissons à un code de neuf lignes seulement, - bien plus élégant que les implantations purement impératives - proposées jusqu'ici, notamment par Knuth. Dans un second temps, - nous montrons comment notre code peut être légèrement modifié pour - aboutir à une version de complexité optimale. - Notre implantation en Objective Caml rivalise d'efficacité avec les - meilleurs codes C. Nous détaillons les calculs de complexité, - un exercice intéressant en présence d'ordre supérieur et d'effets de - bord combinés.} -} - -@TECHREPORT{Filliatre00c, - AUTHOR = {J.-C. Filli\^atre}, - TITLE = {{Design of a proof assistant: Coq version 7}}, - INSTITUTION = {{LRI, Universit\'e Paris Sud}}, - TYPE = {{Research Report}}, - NUMBER = {1369}, - MONTH = {October}, - YEAR = 2000, - URL = {http://www.lri.fr/~filliatr/ftp/publis/coqv7.ps.gz}, - ABSTRACT = { - We present the design and implementation of the new version of the - Coq proof assistant. The main novelty is the isolation of the - critical part of the system, which consists in a type checker for - the Calculus of Inductive Constructions. This kernel is now - completely independent of the rest of the system and has been - rewritten in a purely functional way. This leads to greater clarity - and safety, without compromising efficiency. It also opens the way to - the ``bootstrap'' of the Coq system, where the kernel will be - certified using Coq itself.} -} - -@TECHREPORT{Filliatre00b, - AUTHOR = {J.-C. Filli\^atre}, - TITLE = {{Hash consing in an ML framework}}, - INSTITUTION = {{LRI, Universit\'e Paris Sud}}, - TYPE = {{Research Report}}, - NUMBER = {1368}, - MONTH = {September}, - YEAR = 2000, - URL = {http://www.lri.fr/~filliatr/ftp/publis/hash-consing.ps.gz}, - ABSTRACT = { - Hash consing is a technique to share values that are structurally - equal. Beyond the obvious advantage of saving memory blocks, hash - consing may also be used to gain speed in several operations (like - equality test) and data structures (like sets or maps) when sharing is - maximal. However, physical adresses cannot be used directly for this - purpose when the garbage collector is likely to move blocks - underneath. We present an easy solution in such a framework, with - many practical benefits.} -} - -@MISC{ocamlweb, - AUTHOR = {J.-C. Filli\^atre and C. March\'e}, - TITLE = {{ocamlweb, a literate programming tool for Objective Caml}}, - NOTE = {Available at \url{http://www.lri.fr/~filliatr/ocamlweb/}}, - URL = {http://www.lri.fr/~filliatr/ocamlweb/} -} - -@ARTICLE{Filliatre00a, - AUTHOR = {J.-C. Filli\^atre}, - TITLE = {{Verification of Non-Functional Programs - using Interpretations in Type Theory}}, - JOURNAL = {Journal of Functional Programming}, - VOLUME = 13, - NUMBER = 4, - PAGES = {709--745}, - MONTH = {July}, - YEAR = 2003, - NOTE = {English translation of~\cite{Filliatre99}.}, - URL = {http://www.lri.fr/~filliatr/ftp/publis/jphd.ps.gz}, - ABSTRACT = {We study the problem of certifying programs combining imperative and - functional features within the general framework of type theory. - - Type theory constitutes a powerful specification language, which is - naturally suited for the proof of purely functional programs. To - deal with imperative programs, we propose a logical interpretation - of an annotated program as a partial proof of its specification. The - construction of the corresponding partial proof term is based on a - static analysis of the effects of the program, and on the use of - monads. The usual notion of monads is refined in order to account - for the notion of effect. The missing subterms in the partial proof - term are seen as proof obligations, whose actual proofs are left to - the user. We show that the validity of those proof obligations - implies the total correctness of the program. - We also establish a result of partial completeness. - - This work has been implemented in the Coq proof assistant. - It appears as a tactic taking an annotated program as argument and - generating a set of proof obligations. Several nontrivial - algorithms have been certified using this tactic.} -} - -@ARTICLE{Filliatre99c, - AUTHOR = {J.-C. Filli\^atre}, - TITLE = {{Formal Proof of a Program: Find}}, - JOURNAL = {Science of Computer Programming}, - YEAR = 2001, - NOTE = {To appear}, - URL = {http://www.lri.fr/~filliatr/ftp/publis/find.ps.gz}, - ABSTRACT = {In 1971, C.~A.~R.~Hoare gave the proof of correctness and termination of a - rather complex algorithm, in a paper entitled \emph{Proof of a - program: Find}. It is a hand-made proof, where the - program is given together with its formal specification and where - each step is fully - justified by a mathematical reasoning. We present here a formal - proof of the same program in the system Coq, using the - recent tactic of the system developed to establishing the total - correctness of - imperative programs. We follow Hoare's paper as close as - possible, keeping the same program and the same specification. We - show that we get exactly the same proof obligations, which are - proved in a straightforward way, following the original paper. - We also explain how more informal reasonings of Hoare's proof are - formalized in the system Coq. - This demonstrates the adequacy of the system Coq in the - process of certifying imperative programs.} -} - -@TECHREPORT{Filliatre99b, - AUTHOR = {J.-C. Filli\^atre}, - TITLE = {{A theory of monads parameterized by effects}}, - INSTITUTION = {{LRI, Universit\'e Paris Sud}}, - TYPE = {{Research Report}}, - NUMBER = {1367}, - MONTH = {November}, - YEAR = 1999, - URL = {http://www.lri.fr/~filliatr/ftp/publis/monads.ps.gz}, - ABSTRACT = {Monads were introduced in computer science to express the semantics - of programs with computational effects, while type and effect - inference was introduced to mark out those effects. - In this article, we propose a combination of the notions of effects - and monads, where the monadic operators are parameterized by effects. - We establish some relationships between those generalized monads and - the classical ones. - Then we use a generalized monad to translate imperative programs - into purely functional ones. We establish the correctness of that - translation. This work has been put into practice in the Coq proof - assistant to establish the correctness of imperative programs.} -} - -@PHDTHESIS{Filliatre99, - AUTHOR = {J.-C. Filli\^atre}, - TITLE = {{Preuve de programmes imp\'eratifs en th\'eorie des types}}, - TYPE = {Th{\`e}se de Doctorat}, - SCHOOL = {Universit\'e Paris-Sud}, - YEAR = 1999, - MONTH = {July}, - URL = {http://www.lri.fr/~filliatr/ftp/publis/these.ps.gz}, - ABSTRACT = {Nous étudions le problème de la certification de programmes mêlant - traits impératifs et fonctionnels dans le cadre de la théorie des - types. - - La théorie des types constitue un puissant langage de spécification, - naturellement adapté à la preuve de programmes purement - fonctionnels. Pour y certifier également des programmes impératifs, - nous commençons par exprimer leur sémantique de manière purement - fonctionnelle. Cette traduction repose sur une analyse statique des - effets de bord des programmes, et sur l'utilisation de la notion de - monade, notion que nous raffinons en l'associant à la notion d'effet - de manière générale. Nous montrons que cette traduction est - sémantiquement correcte. - - Puis, à partir d'un programme annoté, nous construisons une preuve - de sa spécification, traduite de manière fonctionnelle. Cette preuve - est bâtie sur la traduction fonctionnelle précédemment - introduite. Elle est presque toujours incomplète, les parties - manquantes étant autant d'obligations de preuve qui seront laissées - à la charge de l'utilisateur. Nous montrons que la validité de ces - obligations entraîne la correction totale du programme. - - Nous avons implanté notre travail dans l'assistant de preuve - Coq, avec lequel il est dès à présent distribué. Cette - implantation se présente sous la forme d'une tactique prenant en - argument un programme annoté et engendrant les obligations de - preuve. Plusieurs algorithmes non triviaux ont été certifiés à - l'aide de cet outil (Find, Quicksort, Heapsort, algorithme de - Knuth-Morris-Pratt).} -} - -@INPROCEEDINGS{FilliatreMagaud99, - AUTHOR = {J.-C. Filli\^atre and N. Magaud}, - TITLE = {{Certification of sorting algorithms in the system Coq}}, - BOOKTITLE = {Theorem Proving in Higher Order Logics: - Emerging Trends}, - YEAR = 1999, - ABSTRACT = {We present the formal proofs of total correctness of three sorting - algorithms in the system Coq, namely \textit{insertion sort}, - \textit{quicksort} and \textit{heapsort}. The implementations are - imperative programs working in-place on a given array. Those - developments demonstrate the usefulness of inductive types and higher-order - logic in the process of software certification. They also - show that the proof of rather complex algorithms may be done in a - small amount of time --- only a few days for each development --- - and without great difficulty.}, - URL = {http://www.lri.fr/~filliatr/ftp/publis/Filliatre-Magaud.ps.gz} -} - -@INPROCEEDINGS{Filliatre98, - AUTHOR = {J.-C. Filli\^atre}, - TITLE = {{Proof of Imperative Programs in Type Theory}}, - BOOKTITLE = {International Workshop, TYPES '98, Kloster Irsee, Germany}, - PUBLISHER = {Springer-Verlag}, - VOLUME = 1657, - SERIES = {Lecture Notes in Computer Science}, - MONTH = MAR, - YEAR = {1998}, - ABSTRACT = {We present a new approach to certifying imperative programs, - in the context of Type Theory. - The key is a functional translation of imperative programs, which is - made possible by an analysis of their effects. - On sequential imperative programs, we get the same proof - obligations as those given by Floyd-Hoare logic, - but our approach also includes functional constructions. - As a side-effect, we propose a way to eradicate the use of auxiliary - variables in specifications. - This work has been implemented in the Coq Proof Assistant and applied - on non-trivial examples.}, - URL = {http://www.lri.fr/~filliatr/ftp/publis/types98.ps.gz} -} - -@TECHREPORT{Filliatre97, - AUTHOR = {J.-C. Filli\^atre}, - INSTITUTION = {LIP - ENS Lyon}, - NUMBER = {97--04}, - TITLE = {{Finite Automata Theory in Coq: - A constructive proof of Kleene's theorem}}, - TYPE = {Research Report}, - MONTH = {February}, - YEAR = {1997}, - ABSTRACT = {We describe here a development in the system Coq - of a piece of Finite Automata Theory. The main result is the Kleene's - theorem, expressing that regular expressions and finite automata - define the same languages. From a constructive proof of this result, - we automatically obtain a functional program that compiles any - regular expression into a finite automata, which constitutes the main - part of the implementation of {\tt grep}-like programs. This - functional program is obtained by the automatic method of {\em - extraction} which removes the logical parts of the proof to keep only - its informative contents. Starting with an idea of what we would - have written in ML, we write the specification and do the proofs in - such a way that we obtain the expected program, which is therefore - efficient.}, - URL = {ftp://ftp.ens-lyon.fr/pub/LIP/Rapports/RR/RR97/RR97-04.ps.Z} -} - -@TECHREPORT{Filliatre95, - AUTHOR = {J.-C. Filli\^atre}, - INSTITUTION = {LIP - ENS Lyon}, - NUMBER = {96--25}, - TITLE = {{A decision procedure for Direct Predicate - Calculus: study and implementation in - the Coq system}}, - TYPE = {Research Report}, - MONTH = {February}, - YEAR = {1995}, - ABSTRACT = {The paper of J. Ketonen and R. Weyhrauch \emph{A - decidable fragment of Predicate Calculus} defines a decidable - fragment of first-order predicate logic - Direct Predicate Calculus - - as the subset which is provable in Gentzen sequent calculus - without the contraction rule, and gives an effective decision - procedure for it. This report is a detailed study of this - procedure. We extend the decidability to non-prenex formulas. We - prove that the intuitionnistic fragment is still decidable, with a - refinement of the same procedure. An intuitionnistic version has - been implemented in the Coq system using a translation into - natural deduction.}, - URL = {ftp://ftp.ens-lyon.fr/pub/LIP/Rapports/RR/RR96/RR96-25.ps.Z} -} - -@TECHREPORT{Filliatre94, - AUTHOR = {J.-C. Filli\^atre}, - MONTH = {Juillet}, - INSTITUTION = {Ecole Normale Sup\'erieure}, - TITLE = {{Une proc\'edure de d\'ecision pour le Calcul des Pr\'edicats Direct~: \'etude et impl\'ementation dans le syst\`eme Coq}}, - TYPE = {Rapport de {DEA}}, - YEAR = {1994}, - URL = {ftp://ftp.lri.fr/LRI/articles/filliatr/memoire.dvi.gz} -} - -@TECHREPORT{CourantFilliatre93, - AUTHOR = {J. Courant et J.-C. Filli\^atre}, - MONTH = {Septembre}, - INSTITUTION = {Ecole Normale Sup\'erieure}, - TITLE = {{Formalisation de la th\'eorie des langages - formels en Coq}}, - TYPE = {Rapport de ma\^{\i}trise}, - YEAR = {1993}, - URL = {http://www.ens-lyon.fr/~jcourant/stage_maitrise.dvi.gz}, - URL2 = {http://www.ens-lyon.fr/~jcourant/stage_maitrise.ps.gz} -} - -@INPROCEEDINGS{tphols2000-Letouzey, - crossref = "tphols2000", - title = "Formalizing {S}t{\aa}lmarck's algorithm in {C}oq", - author = "Pierre Letouzey and Laurent Th{\'e}ry", - pages = "387--404"} - -@PROCEEDINGS{tphols2000, - editor = "J. Harrison and M. Aagaard", - booktitle = "Theorem Proving in Higher Order Logics: - 13th International Conference, TPHOLs 2000", - series = "Lecture Notes in Computer Science", - volume = 1869, - year = 2000, - publisher = "Springer-Verlag"} - -@InCollection{howe, - author = {Doug Howe}, - title = {Computation Meta theory in Nuprl}, - booktitle = {The Proceedings of the Ninth International Conference of Autom -ated Deduction}, - volume = {310}, - editor = {E. Lusk and R. Overbeek}, - publisher = {Springer-Verlag}, - pages = {238--257}, - year = {1988} -} - -@TechReport{harrison, - author = {John Harrison}, - title = {Meta theory and Reflection in Theorem Proving:a Survey and Cri -tique}, - institution = {SRI International Cambridge Computer Science Research Center}, - year = {1995}, - number = {CRC-053} -} - -@InCollection{cc, - author = {Thierry Coquand and Gérard Huet}, - title = {The Calculus of Constructions}, - booktitle = {Information and Computation}, - year = {1988}, - volume = {76}, - number = {2/3} -} - - -@InProceedings{coquandcci, - author = {Thierry Coquand and Christine Paulin-Mohring}, - title = {Inductively defined types}, - booktitle = {Proceedings of Colog'88}, - year = {1990}, - editor = {P. Martin-Löf and G. Mints}, - volume = {417}, - series = {LNCS}, - publisher = {Springer-Verlag} -} - - -@InProceedings{boutin, - author = {Samuel Boutin}, - title = {Using reflection to build efficient and certified decision pro -cedures.}, - booktitle = {Proceedings of TACS'97}, - year = {1997}, - editor = {M. Abadi and T. Ito}, - volume = {1281}, - series = {LNCS}, - publisher = {Springer-Verlag} -} - -@Manual{Coq:manual, - title = {The Coq proof assistant reference manual}, - author = {\mbox{The Coq development team}}, - organization = {LogiCal Project}, - note = {Version 8.0}, - year = {2004}, - url = "http://coq.inria.fr" -} - -@string{jfp = "Journal of Functional Programming"} -@STRING{lncs="Lecture Notes in Computer Science"} -@STRING{lnai="Lecture Notes in Artificial Intelligence"} -@string{SV = "{Sprin\-ger-Verlag}"} - -@INPROCEEDINGS{Aud91, - AUTHOR = {Ph. Audebaud}, - BOOKTITLE = {Proceedings of the sixth Conf. on Logic in Computer Science.}, - PUBLISHER = {IEEE}, - TITLE = {Partial {Objects} in the {Calculus of Constructions}}, - YEAR = {1991} -} - -@PHDTHESIS{Aud92, - AUTHOR = {Ph. Audebaud}, - SCHOOL = {{Universit\'e} Bordeaux I}, - TITLE = {Extension du Calcul des Constructions par Points fixes}, - YEAR = {1992} -} - -@INPROCEEDINGS{Audebaud92b, - AUTHOR = {Ph. Audebaud}, - BOOKTITLE = {{Proceedings of the 1992 Workshop on Types for Proofs and Programs}}, - EDITOR = {{B. Nordstr\"om and K. Petersson and G. Plotkin}}, - NOTE = {Also Research Report LIP-ENS-Lyon}, - PAGES = {pp 21--34}, - TITLE = {{CC+ : an extension of the Calculus of Constructions with fixpoints}}, - YEAR = {1992} -} - -@INPROCEEDINGS{Augustsson85, - AUTHOR = {L. Augustsson}, - TITLE = {{Compiling Pattern Matching}}, - BOOKTITLE = {Conference Functional Programming and -Computer Architecture}, - YEAR = {1985} -} - -@ARTICLE{BaCo85, - AUTHOR = {J.L. Bates and R.L. Constable}, - JOURNAL = {ACM transactions on Programming Languages and Systems}, - TITLE = {Proofs as {Programs}}, - VOLUME = {7}, - YEAR = {1985} -} - -@BOOK{Bar81, - AUTHOR = {H.P. Barendregt}, - PUBLISHER = {North-Holland}, - TITLE = {The Lambda Calculus its Syntax and Semantics}, - YEAR = {1981} -} - -@TECHREPORT{Bar91, - AUTHOR = {H. Barendregt}, - INSTITUTION = {Catholic University Nijmegen}, - NOTE = {In Handbook of Logic in Computer Science, Vol II}, - NUMBER = {91-19}, - TITLE = {Lambda {Calculi with Types}}, - YEAR = {1991} -} - -@ARTICLE{BeKe92, - AUTHOR = {G. Bellin and J. Ketonen}, - JOURNAL = {Theoretical Computer Science}, - PAGES = {115--142}, - TITLE = {A decision procedure revisited : Notes on direct logic, linear logic and its implementation}, - VOLUME = {95}, - YEAR = {1992} -} - -@BOOK{Bee85, - AUTHOR = {M.J. Beeson}, - PUBLISHER = SV, - TITLE = {Foundations of Constructive Mathematics, Metamathematical Studies}, - YEAR = {1985} -} - -@BOOK{Bis67, - AUTHOR = {E. Bishop}, - PUBLISHER = {McGraw-Hill}, - TITLE = {Foundations of Constructive Analysis}, - YEAR = {1967} -} - -@BOOK{BoMo79, - AUTHOR = {R.S. Boyer and J.S. Moore}, - KEY = {BoMo79}, - PUBLISHER = {Academic Press}, - SERIES = {ACM Monograph}, - TITLE = {A computational logic}, - YEAR = {1979} -} - -@MASTERSTHESIS{Bou92, - AUTHOR = {S. Boutin}, - MONTH = sep, - SCHOOL = {{Universit\'e Paris 7}}, - TITLE = {Certification d'un compilateur {ML en Coq}}, - YEAR = {1992} -} - -@inproceedings{Bou97, - title = {Using reflection to build efficient and certified decision procedure -s}, - author = {S. Boutin}, - booktitle = {TACS'97}, - editor = {Martin Abadi and Takahashi Ito}, - publisher = SV, - series = lncs, - volume=1281, - PS={http://pauillac.inria.fr/~boutin/public_w/submitTACS97.ps.gz}, - year = {1997} -} - -@PhdThesis{Bou97These, - author = {S. Boutin}, - title = {R\'eflexions sur les quotients}, - school = {Paris 7}, - year = 1997, - type = {th\`ese d'Universit\'e}, - month = apr -} - -@ARTICLE{Bru72, - AUTHOR = {N.J. de Bruijn}, - JOURNAL = {Indag. Math.}, - TITLE = {{Lambda-Calculus Notation with Nameless Dummies, a Tool for Automatic Formula Manipulation, with Application to the Church-Rosser Theorem}}, - VOLUME = {34}, - YEAR = {1972} -} - - -@INCOLLECTION{Bru80, - AUTHOR = {N.J. de Bruijn}, - BOOKTITLE = {to H.B. Curry : Essays on Combinatory Logic, Lambda Calculus and Formalism.}, - EDITOR = {J.P. Seldin and J.R. Hindley}, - PUBLISHER = {Academic Press}, - TITLE = {A survey of the project {Automath}}, - YEAR = {1980} -} - -@TECHREPORT{COQ93, - AUTHOR = {G. Dowek and A. Felty and H. Herbelin and G. Huet and C. Murthy and C. Parent and C. Paulin-Mohring and B. Werner}, - INSTITUTION = {INRIA}, - MONTH = may, - NUMBER = {154}, - TITLE = {{The Coq Proof Assistant User's Guide Version 5.8}}, - YEAR = {1993} -} - -@TECHREPORT{CPar93, - AUTHOR = {C. Parent}, - INSTITUTION = {Ecole {Normale} {Sup\'erieure} de {Lyon}}, - MONTH = oct, - NOTE = {Also in~\cite{Nijmegen93}}, - NUMBER = {93-29}, - TITLE = {Developing certified programs in the system {Coq}- {The} {Program} tactic}, - YEAR = {1993} -} - -@PHDTHESIS{CPar95, - AUTHOR = {C. Parent}, - SCHOOL = {Ecole {Normale} {Sup\'erieure} de {Lyon}}, - TITLE = {{Synth\`ese de preuves de programmes dans le Calcul des Constructions Inductives}}, - YEAR = {1995} -} - -@BOOK{Caml, - AUTHOR = {P. Weis and X. Leroy}, - PUBLISHER = {InterEditions}, - TITLE = {Le langage Caml}, - YEAR = {1993} -} - -@INPROCEEDINGS{ChiPotSimp03, - AUTHOR = {Laurent Chicli and Lo\"{\i}c Pottier and Carlos Simpson}, - ADDRESS = {Berg en Dal, The Netherlands}, - TITLE = {Mathematical Quotients and Quotient Types in Coq}, - BOOKTITLE = {TYPES'02}, - PUBLISHER = SV, - SERIES = LNCS, - VOLUME = {2646}, - YEAR = {2003} -} - -@TECHREPORT{CoC89, - AUTHOR = {Projet Formel}, - INSTITUTION = {INRIA}, - NUMBER = {110}, - TITLE = {{The Calculus of Constructions. Documentation and user's guide, Version 4.10}}, - YEAR = {1989} -} - -@INPROCEEDINGS{CoHu85a, - AUTHOR = {Thierry Coquand and Gérard Huet}, - ADDRESS = {Linz}, - BOOKTITLE = {EUROCAL'85}, - PUBLISHER = SV, - SERIES = LNCS, - TITLE = {{Constructions : A Higher Order Proof System for Mechanizing Mathematics}}, - VOLUME = {203}, - YEAR = {1985} -} - -@INPROCEEDINGS{CoHu85b, - AUTHOR = {Thierry Coquand and Gérard Huet}, - BOOKTITLE = {Logic Colloquium'85}, - EDITOR = {The Paris Logic Group}, - PUBLISHER = {North-Holland}, - TITLE = {{Concepts Math\'ematiques et Informatiques formalis\'es dans le Calcul des Constructions}}, - YEAR = {1987} -} - -@ARTICLE{CoHu86, - AUTHOR = {Thierry Coquand and Gérard Huet}, - JOURNAL = {Information and Computation}, - NUMBER = {2/3}, - TITLE = {The {Calculus of Constructions}}, - VOLUME = {76}, - YEAR = {1988} -} - -@INPROCEEDINGS{CoPa89, - AUTHOR = {Thierry Coquand and Christine Paulin-Mohring}, - BOOKTITLE = {Proceedings of Colog'88}, - EDITOR = {P. Martin-L\"of and G. Mints}, - PUBLISHER = SV, - SERIES = LNCS, - TITLE = {Inductively defined types}, - VOLUME = {417}, - YEAR = {1990} -} - -@BOOK{Con86, - AUTHOR = {R.L. {Constable et al.}}, - PUBLISHER = {Prentice-Hall}, - TITLE = {{Implementing Mathematics with the Nuprl Proof Development System}}, - YEAR = {1986} -} - -@PHDTHESIS{Coq85, - AUTHOR = {Thierry Coquand}, - MONTH = jan, - SCHOOL = {Universit\'e Paris~7}, - TITLE = {Une Th\'eorie des Constructions}, - YEAR = {1985} -} - -@INPROCEEDINGS{Coq86, - AUTHOR = {Thierry Coquand}, - ADDRESS = {Cambridge, MA}, - BOOKTITLE = {Symposium on Logic in Computer Science}, - PUBLISHER = {IEEE Computer Society Press}, - TITLE = {{An Analysis of Girard's Paradox}}, - YEAR = {1986} -} - -@INPROCEEDINGS{Coq90, - AUTHOR = {Thierry Coquand}, - BOOKTITLE = {Logic and Computer Science}, - EDITOR = {P. Oddifredi}, - NOTE = {INRIA Research Report 1088, also in~\cite{CoC89}}, - PUBLISHER = {Academic Press}, - TITLE = {{Metamathematical Investigations of a Calculus of Constructions}}, - YEAR = {1990} -} - -@INPROCEEDINGS{Coq91, - AUTHOR = {Thierry Coquand}, - BOOKTITLE = {Proceedings 9th Int. Congress of Logic, Methodology and Philosophy of Science}, - TITLE = {{A New Paradox in Type Theory}}, - MONTH = {August}, - YEAR = {1991} -} - -@INPROCEEDINGS{Coq92, - AUTHOR = {Thierry Coquand}, - TITLE = {{Pattern Matching with Dependent Types}}, - YEAR = {1992}, - crossref = {Bastad92} -} - -@INPROCEEDINGS{Coquand93, - AUTHOR = {Thierry Coquand}, - TITLE = {{Infinite Objects in Type Theory}}, - YEAR = {1993}, - crossref = {Nijmegen93} -} - -@MASTERSTHESIS{Cou94a, - AUTHOR = {J. Courant}, - MONTH = sep, - SCHOOL = {DEA d'Informatique, ENS Lyon}, - TITLE = {Explicitation de preuves par r\'ecurrence implicite}, - YEAR = {1994} -} - -@INPROCEEDINGS{Del99, - author = "Delahaye, D.", - title = "Information Retrieval in a Coq Proof Library using - Type Isomorphisms", - booktitle = {Proceedings of TYPES'99, L\"okeberg}, - publisher = SV, - series = lncs, - year = "1999", - url = - "\\{\sf ftp://ftp.inria.fr/INRIA/Projects/coq/David.Delahaye/papers/}"# - "{\sf TYPES99-SIsos.ps.gz}" -} - -@INPROCEEDINGS{Del00, - author = "Delahaye, D.", - title = "A {T}actic {L}anguage for the {S}ystem {{\sf Coq}}", - booktitle = "Proceedings of Logic for Programming and Automated Reasoning - (LPAR), Reunion Island", - publisher = SV, - series = LNCS, - volume = "1955", - pages = "85--95", - month = "November", - year = "2000", - url = - "{\sf ftp://ftp.inria.fr/INRIA/Projects/coq/David.Delahaye/papers/}"# - "{\sf LPAR2000-ltac.ps.gz}" -} - -@INPROCEEDINGS{DelMay01, - author = "Delahaye, D. and Mayero, M.", - title = {{\tt Field}: une proc\'edure de d\'ecision pour les nombres r\'eels - en {\Coq}}, - booktitle = "Journ\'ees Francophones des Langages Applicatifs, Pontarlier", - publisher = "INRIA", - month = "Janvier", - year = "2001", - url = - "\\{\sf ftp://ftp.inria.fr/INRIA/Projects/coq/David.Delahaye/papers/}"# - "{\sf JFLA2000-Field.ps.gz}" -} - -@TECHREPORT{Dow90, - AUTHOR = {G. Dowek}, - INSTITUTION = {INRIA}, - NUMBER = {1283}, - TITLE = {Naming and Scoping in a Mathematical Vernacular}, - TYPE = {Research Report}, - YEAR = {1990} -} - -@ARTICLE{Dow91a, - AUTHOR = {G. Dowek}, - JOURNAL = {Compte-Rendus de l'Acad\'emie des Sciences}, - NOTE = {The undecidability of Third Order Pattern Matching in Calculi with Dependent Types or Type Constructors}, - NUMBER = {12}, - PAGES = {951--956}, - TITLE = {L'Ind\'ecidabilit\'e du Filtrage du Troisi\`eme Ordre dans les Calculs avec Types D\'ependants ou Constructeurs de Types}, - VOLUME = {I, 312}, - YEAR = {1991} -} - -@INPROCEEDINGS{Dow91b, - AUTHOR = {G. Dowek}, - BOOKTITLE = {Proceedings of Mathematical Foundation of Computer Science}, - NOTE = {Also INRIA Research Report}, - PAGES = {151--160}, - PUBLISHER = SV, - SERIES = LNCS, - TITLE = {A Second Order Pattern Matching Algorithm in the Cube of Typed $\lambda$-calculi}, - VOLUME = {520}, - YEAR = {1991} -} - -@PHDTHESIS{Dow91c, - AUTHOR = {G. Dowek}, - MONTH = dec, - SCHOOL = {Universit\'e Paris 7}, - TITLE = {D\'emonstration automatique dans le Calcul des Constructions}, - YEAR = {1991} -} - -@article{Dow92a, - AUTHOR = {G. Dowek}, - TITLE = {The Undecidability of Pattern Matching in Calculi where Primitive Recursive Functions are Representable}, - YEAR = 1993, - journal = tcs, - volume = 107, - number = 2, - pages = {349-356} -} - - -@ARTICLE{Dow94a, - AUTHOR = {G. Dowek}, - JOURNAL = {Annals of Pure and Applied Logic}, - VOLUME = {69}, - PAGES = {135--155}, - TITLE = {Third order matching is decidable}, - YEAR = {1994} -} - -@INPROCEEDINGS{Dow94b, - AUTHOR = {G. Dowek}, - BOOKTITLE = {Proceedings of the second international conference on typed lambda calculus and applications}, - TITLE = {Lambda-calculus, Combinators and the Comprehension Schema}, - YEAR = {1995} -} - -@INPROCEEDINGS{Dyb91, - AUTHOR = {P. Dybjer}, - BOOKTITLE = {Logical Frameworks}, - EDITOR = {G. Huet and G. Plotkin}, - PAGES = {59--79}, - PUBLISHER = {Cambridge University Press}, - TITLE = {Inductive sets and families in {Martin-L{\"o}f's} - Type Theory and their set-theoretic semantics: An inversion principle for {Martin-L\"of's} type theory}, - VOLUME = {14}, - YEAR = {1991} -} - -@ARTICLE{Dyc92, - AUTHOR = {Roy Dyckhoff}, - JOURNAL = {The Journal of Symbolic Logic}, - MONTH = sep, - NUMBER = {3}, - TITLE = {Contraction-free sequent calculi for intuitionistic logic}, - VOLUME = {57}, - YEAR = {1992} -} - -@MASTERSTHESIS{Fil94, - AUTHOR = {J.-C. Filli\^atre}, - MONTH = sep, - SCHOOL = {DEA d'Informatique, ENS Lyon}, - TITLE = {Une proc\'edure de d\'ecision pour le Calcul des Pr\'edicats Direct. {\'E}tude et impl\'ementation dans le syst\`eme {\Coq}}, - YEAR = {1994} -} - -@TECHREPORT{Filliatre95, - AUTHOR = {J.-C. Filli\^atre}, - INSTITUTION = {LIP-ENS-Lyon}, - TITLE = {A decision procedure for Direct Predicate Calculus}, - TYPE = {Research report}, - NUMBER = {96--25}, - YEAR = {1995} -} - -@Article{Filliatre03jfp, - author = {J.-C. Filli{\^a}tre}, - title = {Verification of Non-Functional Programs - using Interpretations in Type Theory}, - journal = jfp, - volume = 13, - number = 4, - pages = {709--745}, - month = jul, - year = 2003, - note = {[English translation of \cite{Filliatre99}]}, - url = {http://www.lri.fr/~filliatr/ftp/publis/jphd.ps.gz}, - topics = "team, lri", - type_publi = "irevcomlec" -} - - -@PhdThesis{Filliatre99, - author = {J.-C. Filli\^atre}, - title = {Preuve de programmes imp\'eratifs en th\'eorie des types}, - type = {Th{\`e}se de Doctorat}, - school = {Universit\'e Paris-Sud}, - year = 1999, - month = {July}, - url = {\url{http://www.lri.fr/~filliatr/ftp/publis/these.ps.gz}} -} - -@Unpublished{Filliatre99c, - author = {J.-C. Filli\^atre}, - title = {{Formal Proof of a Program: Find}}, - month = {January}, - year = 2000, - note = {Submitted to \emph{Science of Computer Programming}}, - url = {\url{http://www.lri.fr/~filliatr/ftp/publis/find.ps.gz}} -} - -@InProceedings{FilliatreMagaud99, - author = {J.-C. Filli\^atre and N. Magaud}, - title = {Certification of sorting algorithms in the system {\Coq}}, - booktitle = {Theorem Proving in Higher Order Logics: - Emerging Trends}, - year = 1999, - url = {\url{http://www.lri.fr/~filliatr/ftp/publis/Filliatre-Magaud.ps.gz}} -} - -@UNPUBLISHED{Fle90, - AUTHOR = {E. Fleury}, - MONTH = jul, - NOTE = {Rapport de Stage}, - TITLE = {Implantation des algorithmes de {Floyd et de Dijkstra} dans le {Calcul des Constructions}}, - YEAR = {1990} -} - -@BOOK{Fourier, - AUTHOR = {Jean-Baptiste-Joseph Fourier}, - PUBLISHER = {Gauthier-Villars}, - TITLE = {Fourier's method to solve linear - inequations/equations systems.}, - YEAR = {1890} -} - -@INPROCEEDINGS{Gim94, - AUTHOR = {Eduardo Gim\'enez}, - BOOKTITLE = {Types'94 : Types for Proofs and Programs}, - NOTE = {Extended version in LIP research report 95-07, ENS Lyon}, - PUBLISHER = SV, - SERIES = LNCS, - TITLE = {Codifying guarded definitions with recursive schemes}, - VOLUME = {996}, - YEAR = {1994} -} - -@TechReport{Gim98, - author = {E. Gim\'enez}, - title = {A Tutorial on Recursive Types in Coq}, - institution = {INRIA}, - year = 1998, - month = mar -} - -@INPROCEEDINGS{Gimenez95b, - AUTHOR = {E. Gim\'enez}, - BOOKTITLE = {Workshop on Types for Proofs and Programs}, - SERIES = LNCS, - NUMBER = {1158}, - PAGES = {135-152}, - TITLE = {An application of co-Inductive types in Coq: - verification of the Alternating Bit Protocol}, - EDITORS = {S. Berardi and M. Coppo}, - PUBLISHER = SV, - YEAR = {1995} -} - -@INPROCEEDINGS{Gir70, - AUTHOR = {Jean-Yves Girard}, - BOOKTITLE = {Proceedings of the 2nd Scandinavian Logic Symposium}, - PUBLISHER = {North-Holland}, - TITLE = {Une extension de l'interpr\'etation de {G\"odel} \`a l'analyse, et son application \`a l'\'elimination des coupures dans l'analyse et la th\'eorie des types}, - YEAR = {1970} -} - -@PHDTHESIS{Gir72, - AUTHOR = {Jean-Yves Girard}, - SCHOOL = {Universit\'e Paris~7}, - TITLE = {Interpr\'etation fonctionnelle et \'elimination des coupures de l'arithm\'etique d'ordre sup\'erieur}, - YEAR = {1972} -} - - - -@BOOK{Gir89, - AUTHOR = {Jean-Yves Girard and Yves Lafont and Paul Taylor}, - PUBLISHER = {Cambridge University Press}, - SERIES = {Cambridge Tracts in Theoretical Computer Science 7}, - TITLE = {Proofs and Types}, - YEAR = {1989} -} - -@TechReport{Har95, - author = {John Harrison}, - title = {Metatheory and Reflection in Theorem Proving: A Survey and Critique}, - institution = {SRI International Cambridge Computer Science Research Centre,}, - year = 1995, - type = {Technical Report}, - number = {CRC-053}, - abstract = {http://www.cl.cam.ac.uk/users/jrh/papers.html} -} - -@MASTERSTHESIS{Hir94, - AUTHOR = {Daniel Hirschkoff}, - MONTH = sep, - SCHOOL = {DEA IARFA, Ecole des Ponts et Chauss\'ees, Paris}, - TITLE = {{\'E}criture d'une tactique arithm\'etique pour le syst\`eme {\Coq}}, - YEAR = {1994} -} - -@INPROCEEDINGS{HofStr98, - AUTHOR = {Martin Hofmann and Thomas Streicher}, - TITLE = {The groupoid interpretation of type theory}, - BOOKTITLE = {Proceedings of the meeting Twenty-five years of constructive type theory}, - PUBLISHER = {Oxford University Press}, - YEAR = {1998} -} - -@INCOLLECTION{How80, - AUTHOR = {W.A. Howard}, - BOOKTITLE = {to H.B. Curry : Essays on Combinatory Logic, Lambda Calculus and Formalism.}, - EDITOR = {J.P. Seldin and J.R. Hindley}, - NOTE = {Unpublished 1969 Manuscript}, - PUBLISHER = {Academic Press}, - TITLE = {The Formulae-as-Types Notion of Constructions}, - YEAR = {1980} -} - - - -@InProceedings{Hue87tapsoft, - author = {G. Huet}, - title = {Programming of Future Generation Computers}, - booktitle = {Proceedings of TAPSOFT87}, - series = LNCS, - volume = 249, - pages = {276--286}, - year = 1987, - publisher = SV -} - -@INPROCEEDINGS{Hue87, - AUTHOR = {G. Huet}, - BOOKTITLE = {Programming of Future Generation Computers}, - EDITOR = {K. Fuchi and M. Nivat}, - NOTE = {Also in \cite{Hue87tapsoft}}, - PUBLISHER = {Elsevier Science}, - TITLE = {Induction Principles Formalized in the {Calculus of Constructions}}, - YEAR = {1988} -} - - - -@INPROCEEDINGS{Hue88, - AUTHOR = {G. Huet}, - BOOKTITLE = {A perspective in Theoretical Computer Science. Commemorative Volume for Gift Siromoney}, - EDITOR = {R. Narasimhan}, - NOTE = {Also in~\cite{CoC89}}, - PUBLISHER = {World Scientific Publishing}, - TITLE = {{The Constructive Engine}}, - YEAR = {1989} -} - -@BOOK{Hue89, - EDITOR = {G. Huet}, - PUBLISHER = {Addison-Wesley}, - SERIES = {The UT Year of Programming Series}, - TITLE = {Logical Foundations of Functional Programming}, - YEAR = {1989} -} - -@INPROCEEDINGS{Hue92, - AUTHOR = {G. Huet}, - BOOKTITLE = {Proceedings of 12th FST/TCS Conference, New Delhi}, - PAGES = {229--240}, - PUBLISHER = SV, - SERIES = LNCS, - TITLE = {The Gallina Specification Language : A case study}, - VOLUME = {652}, - YEAR = {1992} -} - -@ARTICLE{Hue94, - AUTHOR = {G. Huet}, - JOURNAL = {J. Functional Programming}, - PAGES = {371--394}, - PUBLISHER = {Cambridge University Press}, - TITLE = {Residual theory in $\lambda$-calculus: a formal development}, - VOLUME = {4,3}, - YEAR = {1994} -} - -@INCOLLECTION{HuetLevy79, - AUTHOR = {G. Huet and J.-J. L\'{e}vy}, - TITLE = {Call by Need Computations in Non-Ambigous -Linear Term Rewriting Systems}, - NOTE = {Also research report 359, INRIA, 1979}, - BOOKTITLE = {Computational Logic, Essays in Honor of -Alan Robinson}, - EDITOR = {J.-L. Lassez and G. Plotkin}, - PUBLISHER = {The MIT press}, - YEAR = {1991} -} - -@ARTICLE{KeWe84, - AUTHOR = {J. Ketonen and R. Weyhrauch}, - JOURNAL = {Theoretical Computer Science}, - PAGES = {297--307}, - TITLE = {A decidable fragment of {P}redicate {C}alculus}, - VOLUME = {32}, - YEAR = {1984} -} - -@BOOK{Kle52, - AUTHOR = {S.C. Kleene}, - PUBLISHER = {North-Holland}, - SERIES = {Bibliotheca Mathematica}, - TITLE = {Introduction to Metamathematics}, - YEAR = {1952} -} - -@BOOK{Kri90, - AUTHOR = {J.-L. Krivine}, - PUBLISHER = {Masson}, - SERIES = {Etudes et recherche en informatique}, - TITLE = {Lambda-calcul {types et mod\`eles}}, - YEAR = {1990} -} - -@BOOK{LE92, - EDITOR = {G. Huet and G. Plotkin}, - PUBLISHER = {Cambridge University Press}, - TITLE = {Logical Environments}, - YEAR = {1992} -} - -@BOOK{LF91, - EDITOR = {G. Huet and G. Plotkin}, - PUBLISHER = {Cambridge University Press}, - TITLE = {Logical Frameworks}, - YEAR = {1991} -} - -@ARTICLE{Laville91, - AUTHOR = {A. Laville}, - TITLE = {Comparison of Priority Rules in Pattern -Matching and Term Rewriting}, - JOURNAL = {Journal of Symbolic Computation}, - VOLUME = {11}, - PAGES = {321--347}, - YEAR = {1991} -} - -@INPROCEEDINGS{LePa94, - AUTHOR = {F. Leclerc and C. Paulin-Mohring}, - BOOKTITLE = {{Types for Proofs and Programs, Types' 93}}, - EDITOR = {H. Barendregt and T. Nipkow}, - PUBLISHER = SV, - SERIES = {LNCS}, - TITLE = {{Programming with Streams in Coq. A case study : The Sieve of Eratosthenes}}, - VOLUME = {806}, - YEAR = {1994} -} - -@TECHREPORT{Leroy90, - AUTHOR = {X. Leroy}, - TITLE = {The {ZINC} experiment: an economical implementation -of the {ML} language}, - INSTITUTION = {INRIA}, - NUMBER = {117}, - YEAR = {1990} -} - -@INPROCEEDINGS{Let02, - author = {P. Letouzey}, - title = {A New Extraction for Coq}, - booktitle = {Proceedings of the TYPES'2002 workshop}, - year = 2002, - note = {to appear}, - url = {draft at \url{http://www.lri.fr/~letouzey/download/extraction2002.ps.gz}} -} - -@BOOK{MaL84, - AUTHOR = {{P. Martin-L\"of}}, - PUBLISHER = {Bibliopolis}, - SERIES = {Studies in Proof Theory}, - TITLE = {Intuitionistic Type Theory}, - YEAR = {1984} -} - -@ARTICLE{MaSi94, - AUTHOR = {P. Manoury and M. Simonot}, - JOURNAL = {TCS}, - TITLE = {Automatizing termination proof of recursively defined function}, - YEAR = {To appear} -} - -@INPROCEEDINGS{Moh89a, - AUTHOR = {Christine Paulin-Mohring}, - ADDRESS = {Austin}, - BOOKTITLE = {Sixteenth Annual ACM Symposium on Principles of Programming Languages}, - MONTH = jan, - PUBLISHER = {ACM}, - TITLE = {Extracting ${F}_{\omega}$'s programs from proofs in the {Calculus of Constructions}}, - YEAR = {1989} -} - -@PHDTHESIS{Moh89b, - AUTHOR = {Christine Paulin-Mohring}, - MONTH = jan, - SCHOOL = {{Universit\'e Paris 7}}, - TITLE = {Extraction de programmes dans le {Calcul des Constructions}}, - YEAR = {1989} -} - -@INPROCEEDINGS{Moh93, - AUTHOR = {Christine Paulin-Mohring}, - BOOKTITLE = {Proceedings of the conference Typed Lambda Calculi and Applications}, - EDITOR = {M. Bezem and J.-F. Groote}, - NOTE = {Also LIP research report 92-49, ENS Lyon}, - NUMBER = {664}, - PUBLISHER = SV, - SERIES = {LNCS}, - TITLE = {{Inductive Definitions in the System Coq - Rules and Properties}}, - YEAR = {1993} -} - -@BOOK{Moh97, - AUTHOR = {Christine Paulin-Mohring}, - MONTH = jan, - PUBLISHER = {{ENS Lyon}}, - TITLE = {{Le syst\`eme Coq. \mbox{Th\`ese d'habilitation}}}, - YEAR = {1997} -} - -@MASTERSTHESIS{Mun94, - AUTHOR = {C. Mu{\~n}oz}, - MONTH = sep, - SCHOOL = {DEA d'Informatique Fondamentale, Universit\'e Paris 7}, - TITLE = {D\'emonstration automatique dans la logique propositionnelle intuitionniste}, - YEAR = {1994} -} - -@PHDTHESIS{Mun97d, - AUTHOR = "C. Mu{\~{n}}oz", - TITLE = "Un calcul de substitutions pour la repr\'esentation - de preuves partielles en th\'eorie de types", - SCHOOL = {Universit\'e Paris 7}, - YEAR = "1997", - Note = {Version en anglais disponible comme rapport de - recherche INRIA RR-3309}, - Type = {Th\`ese de Doctorat} -} - -@BOOK{NoPS90, - AUTHOR = {B. {Nordstr\"om} and K. Peterson and J. Smith}, - BOOKTITLE = {Information Processing 83}, - PUBLISHER = {Oxford Science Publications}, - SERIES = {International Series of Monographs on Computer Science}, - TITLE = {Programming in {Martin-L\"of's} Type Theory}, - YEAR = {1990} -} - -@ARTICLE{Nor88, - AUTHOR = {B. {Nordstr\"om}}, - JOURNAL = {BIT}, - TITLE = {Terminating General Recursion}, - VOLUME = {28}, - YEAR = {1988} -} - -@BOOK{Odi90, - EDITOR = {P. Odifreddi}, - PUBLISHER = {Academic Press}, - TITLE = {Logic and Computer Science}, - YEAR = {1990} -} - -@INPROCEEDINGS{PaMS92, - AUTHOR = {M. Parigot and P. Manoury and M. Simonot}, - ADDRESS = {St. Petersburg, Russia}, - BOOKTITLE = {Logic Programming and automated reasoning}, - EDITOR = {A. Voronkov}, - MONTH = jul, - NUMBER = {624}, - PUBLISHER = SV, - SERIES = {LNCS}, - TITLE = {{ProPre : A Programming language with proofs}}, - YEAR = {1992} -} - -@ARTICLE{PaWe92, - AUTHOR = {Christine Paulin-Mohring and Benjamin Werner}, - JOURNAL = {Journal of Symbolic Computation}, - PAGES = {607--640}, - TITLE = {{Synthesis of ML programs in the system Coq}}, - VOLUME = {15}, - YEAR = {1993} -} - -@ARTICLE{Par92, - AUTHOR = {M. Parigot}, - JOURNAL = {Theoretical Computer Science}, - NUMBER = {2}, - PAGES = {335--356}, - TITLE = {{Recursive Programming with Proofs}}, - VOLUME = {94}, - YEAR = {1992} -} - -@INPROCEEDINGS{Parent95b, - AUTHOR = {C. Parent}, - BOOKTITLE = {{Mathematics of Program Construction'95}}, - PUBLISHER = SV, - SERIES = {LNCS}, - TITLE = {{Synthesizing proofs from programs in -the Calculus of Inductive Constructions}}, - VOLUME = {947}, - YEAR = {1995} -} - -@INPROCEEDINGS{Prasad93, - AUTHOR = {K.V. Prasad}, - BOOKTITLE = {{Proceedings of CONCUR'93}}, - PUBLISHER = SV, - SERIES = {LNCS}, - TITLE = {{Programming with broadcasts}}, - VOLUME = {715}, - YEAR = {1993} -} - -@BOOK{RC95, - author = "di~Cosmo, R.", - title = "Isomorphisms of Types: from $\lambda$-calculus to information - retrieval and language design", - series = "Progress in Theoretical Computer Science", - publisher = "Birkhauser", - year = "1995", - note = "ISBN-0-8176-3763-X" -} - -@TECHREPORT{Rou92, - AUTHOR = {J. Rouyer}, - INSTITUTION = {INRIA}, - MONTH = nov, - NUMBER = {1795}, - TITLE = {{D{\'e}veloppement de l'Algorithme d'Unification dans le Calcul des Constructions}}, - YEAR = {1992} -} - -@TECHREPORT{Saibi94, - AUTHOR = {A. Sa\"{\i}bi}, - INSTITUTION = {INRIA}, - MONTH = dec, - NUMBER = {2345}, - TITLE = {{Axiomatization of a lambda-calculus with explicit-substitutions in the Coq System}}, - YEAR = {1994} -} - - -@MASTERSTHESIS{Ter92, - AUTHOR = {D. Terrasse}, - MONTH = sep, - SCHOOL = {IARFA}, - TITLE = {{Traduction de TYPOL en COQ. Application \`a Mini ML}}, - YEAR = {1992} -} - -@TECHREPORT{ThBeKa92, - AUTHOR = {L. Th\'ery and Y. Bertot and G. Kahn}, - INSTITUTION = {INRIA Sophia}, - MONTH = may, - NUMBER = {1684}, - TITLE = {Real theorem provers deserve real user-interfaces}, - TYPE = {Research Report}, - YEAR = {1992} -} - -@BOOK{TrDa89, - AUTHOR = {A.S. Troelstra and D. van Dalen}, - PUBLISHER = {North-Holland}, - SERIES = {Studies in Logic and the foundations of Mathematics, volumes 121 and 123}, - TITLE = {Constructivism in Mathematics, an introduction}, - YEAR = {1988} -} - -@PHDTHESIS{Wer94, - AUTHOR = {B. Werner}, - SCHOOL = {Universit\'e Paris 7}, - TITLE = {Une th\'eorie des constructions inductives}, - TYPE = {Th\`ese de Doctorat}, - YEAR = {1994} -} - -@PHDTHESIS{Bar99, - AUTHOR = {B. Barras}, - SCHOOL = {Universit\'e Paris 7}, - TITLE = {Auto-validation d'un système de preuves avec familles inductives}, - TYPE = {Th\`ese de Doctorat}, - YEAR = {1999} -} - -@UNPUBLISHED{ddr98, - AUTHOR = {D. de Rauglaudre}, - TITLE = {Camlp4 version 1.07.2}, - YEAR = {1998}, - NOTE = {In Camlp4 distribution} -} - -@ARTICLE{dowek93, - AUTHOR = {G. Dowek}, - TITLE = {{A Complete Proof Synthesis Method for the Cube of Type Systems}}, - JOURNAL = {Journal Logic Computation}, - VOLUME = {3}, - NUMBER = {3}, - PAGES = {287--315}, - MONTH = {June}, - YEAR = {1993} -} - -@INPROCEEDINGS{manoury94, - AUTHOR = {P. Manoury}, - TITLE = {{A User's Friendly Syntax to Define -Recursive Functions as Typed $\lambda-$Terms}}, - BOOKTITLE = {{Types for Proofs and Programs, TYPES'94}}, - SERIES = {LNCS}, - VOLUME = {996}, - MONTH = jun, - YEAR = {1994} -} - -@TECHREPORT{maranget94, - AUTHOR = {L. Maranget}, - INSTITUTION = {INRIA}, - NUMBER = {2385}, - TITLE = {{Two Techniques for Compiling Lazy Pattern Matching}}, - YEAR = {1994} -} - -@INPROCEEDINGS{puel-suarez90, - AUTHOR = {L.Puel and A. Su\'arez}, - BOOKTITLE = {{Conference Lisp and Functional Programming}}, - SERIES = {ACM}, - PUBLISHER = SV, - TITLE = {{Compiling Pattern Matching by Term -Decomposition}}, - YEAR = {1990} -} - -@MASTERSTHESIS{saidi94, - AUTHOR = {H. Saidi}, - MONTH = sep, - SCHOOL = {DEA d'Informatique Fondamentale, Universit\'e Paris 7}, - TITLE = {R\'esolution d'\'equations dans le syst\`eme T - de G\"odel}, - YEAR = {1994} -} - -@misc{streicher93semantical, - author = "T. Streicher", - title = "Semantical Investigations into Intensional Type Theory", - note = "Habilitationsschrift, LMU Munchen.", - year = "1993" } - - - -@Misc{Pcoq, - author = {Lemme Team}, - title = {Pcoq a graphical user-interface for {Coq}}, - note = {\url{http://www-sop.inria.fr/lemme/pcoq/}} -} - - -@Misc{ProofGeneral, - author = {David Aspinall}, - title = {Proof General}, - note = {\url{https://proofgeneral.github.io/}} -} - - - -@Book{CoqArt, - author = {Yves bertot and Pierre Castéran}, - title = {Coq'Art}, - publisher = {Springer-Verlag}, - year = 2004, - note = {To appear} -} - -@INCOLLECTION{wadler87, - AUTHOR = {P. Wadler}, - TITLE = {Efficient Compilation of Pattern Matching}, - BOOKTITLE = {The Implementation of Functional Programming -Languages}, - EDITOR = {S.L. Peyton Jones}, - PUBLISHER = {Prentice-Hall}, - YEAR = {1987} -} - - -@COMMENT{cross-references, must be at end} - -@BOOK{Bastad92, - EDITOR = {B. Nordstr\"om and K. Petersson and G. Plotkin}, - PUBLISHER = {Available by ftp at site ftp.inria.fr}, - TITLE = {Proceedings of the 1992 Workshop on Types for Proofs and Programs}, - YEAR = {1992} -} - -@BOOK{Nijmegen93, - EDITOR = {H. Barendregt and T. Nipkow}, - PUBLISHER = SV, - SERIES = LNCS, - TITLE = {Types for Proofs and Programs}, - VOLUME = {806}, - YEAR = {1994} -} - -@PHDTHESIS{Luo90, - AUTHOR = {Z. Luo}, - TITLE = {An Extended Calculus of Constructions}, - SCHOOL = {University of Edinburgh}, - YEAR = {1990} -} diff --git a/doc/faq/hevea.sty b/doc/faq/hevea.sty deleted file mode 100644 index 6d49aa8cee..0000000000 --- a/doc/faq/hevea.sty +++ /dev/null @@ -1,78 +0,0 @@ -% hevea : hevea.sty -% This is a very basic style file for latex document to be processed -% with hevea. It contains definitions of LaTeX environment which are -% processed in a special way by the translator. -% Mostly : -% - latexonly, not processed by hevea, processed by latex. -% - htmlonly , the reverse. -% - rawhtml, to include raw HTML in hevea output. -% - toimage, to send text to the image file. -% The package also provides hevea logos, html related commands (ahref -% etc.), void cutting and image commands. -\NeedsTeXFormat{LaTeX2e} -\ProvidesPackage{hevea}[2002/01/11] -\RequirePackage{comment} -\newif\ifhevea\heveafalse -\@ifundefined{ifimagen}{\newif\ifimagen\imagenfalse} -\makeatletter% -\newcommand{\heveasmup}[2]{% -\raise #1\hbox{$\m@th$% - \csname S@\f@size\endcsname - \fontsize\sf@size 0% - \math@fontsfalse\selectfont -#2% -}}% -\DeclareRobustCommand{\hevea}{H\kern-.15em\heveasmup{.2ex}{E}\kern-.15emV\kern-.15em\heveasmup{.2ex}{E}\kern-.15emA}% -\DeclareRobustCommand{\hacha}{H\kern-.15em\heveasmup{.2ex}{A}\kern-.15emC\kern-.1em\heveasmup{.2ex}{H}\kern-.15emA}% -\DeclareRobustCommand{\html}{\protect\heveasmup{0.ex}{HTML}} -%%%%%%%%% Hyperlinks hevea style -\newcommand{\ahref}[2]{{#2}} -\newcommand{\ahrefloc}[2]{{#2}} -\newcommand{\aname}[2]{{#2}} -\newcommand{\ahrefurl}[1]{\texttt{#1}} -\newcommand{\footahref}[2]{#2\footnote{\texttt{#1}}} -\newcommand{\mailto}[1]{\texttt{#1}} -\newcommand{\imgsrc}[2][]{} -\newcommand{\home}[1]{\protect\raisebox{-.75ex}{\char126}#1} -\AtBeginDocument -{\@ifundefined{url} -{%url package is not loaded -\let\url\ahref\let\oneurl\ahrefurl\let\footurl\footahref} -{}} -%% Void cutting instructions -\newcounter{cuttingdepth} -\newcommand{\tocnumber}{} -\newcommand{\notocnumber}{} -\newcommand{\cuttingunit}{} -\newcommand{\cutdef}[2][]{} -\newcommand{\cuthere}[2]{} -\newcommand{\cutend}{} -\newcommand{\htmlhead}[1]{} -\newcommand{\htmlfoot}[1]{} -\newcommand{\htmlprefix}[1]{} -\newenvironment{cutflow}[1]{}{} -\newcommand{\cutname}[1]{} -\newcommand{\toplinks}[3]{} -%%%% Html only -\excludecomment{rawhtml} -\newcommand{\rawhtmlinput}[1]{} -\excludecomment{htmlonly} -%%%% Latex only -\newenvironment{latexonly}{}{} -\newenvironment{verblatex}{}{} -%%%% Image file stuff -\def\toimage{\endgroup} -\def\endtoimage{\begingroup\def\@currenvir{toimage}} -\def\verbimage{\endgroup} -\def\endverbimage{\begingroup\def\@currenvir{verbimage}} -\newcommand{\imageflush}[1][]{} -%%% Bgcolor definition -\newsavebox{\@bgcolorbin} -\newenvironment{bgcolor}[2][] - {\newcommand{\@mycolor}{#2}\begin{lrbox}{\@bgcolorbin}\vbox\bgroup} - {\egroup\end{lrbox}% - \begin{flushleft}% - \colorbox{\@mycolor}{\usebox{\@bgcolorbin}}% - \end{flushleft}} -%%% Postlude -\makeatother diff --git a/doc/faq/interval_discr.v b/doc/faq/interval_discr.v deleted file mode 100644 index 671dc988a2..0000000000 --- a/doc/faq/interval_discr.v +++ /dev/null @@ -1,419 +0,0 @@ -(** Sketch of the proof of {p:nat|p<=n} = {p:nat|p<=m} -> n=m - - - preliminary results on the irrelevance of boundedness proofs - - introduce the notion of finite cardinal |A| - - prove that |{p:nat|p<=n}| = n - - prove that |A| = n /\ |A| = m -> n = m if equality is decidable on A - - prove that equality is decidable on A - - conclude -*) - -(** * Preliminary results on [nat] and [le] *) - -(** Proving axiom K on [nat] *) - -Require Import Eqdep_dec. -Require Import Arith. - -Theorem eq_rect_eq_nat : - forall (p:nat) (Q:nat->Type) (x:Q p) (h:p=p), x = eq_rect p Q x p h. -Proof. -intros. -apply K_dec_set with (p := h). -apply eq_nat_dec. -reflexivity. -Qed. - -(** Proving unicity of proofs of [(n<=m)%nat] *) - -Scheme le_ind' := Induction for le Sort Prop. - -Theorem le_uniqueness_proof : forall (n m : nat) (p q : n <= m), p = q. -Proof. -induction p using le_ind'; intro q. - replace (le_n n) with - (eq_rect _ (fun n0 => n <= n0) (le_n n) _ eq_refl). - 2:reflexivity. - generalize (eq_refl n). - pattern n at 2 4 6 10, q; case q; [intro | intros m l e]. - rewrite <- eq_rect_eq_nat; trivial. - contradiction (le_Sn_n m); rewrite <- e; assumption. - replace (le_S n m p) with - (eq_rect _ (fun n0 => n <= n0) (le_S n m p) _ eq_refl). - 2:reflexivity. - generalize (eq_refl (S m)). - pattern (S m) at 1 3 4 6, q; case q; [intro Heq | intros m0 l HeqS]. - contradiction (le_Sn_n m); rewrite Heq; assumption. - injection HeqS; intro Heq; generalize l HeqS. - rewrite <- Heq; intros; rewrite <- eq_rect_eq_nat. - rewrite (IHp l0); reflexivity. -Qed. - -(** Proving irrelevance of boundedness proofs while building - elements of interval *) - -Lemma dep_pair_intro : - forall (n x y:nat) (Hx : x<=n) (Hy : y<=n), x=y -> - exist (fun x => x <= n) x Hx = exist (fun x => x <= n) y Hy. -Proof. -intros n x y Hx Hy Heq. -generalize Hy. -rewrite <- Heq. -intros. -rewrite (le_uniqueness_proof x n Hx Hy0). -reflexivity. -Qed. - -(** * Proving that {p:nat|p<=n} = {p:nat|p<=m} -> n=m *) - -(** Definition of having finite cardinality [n+1] for a set [A] *) - -Definition card (A:Set) n := - exists f, - (forall x:A, f x <= n) /\ - (forall x y:A, f x = f y -> x = y) /\ - (forall m, m <= n -> exists x:A, f x = m). - -Require Import Arith. - -(** Showing that the interval [0;n] has cardinality [n+1] *) - -Theorem card_interval : forall n, card {x:nat|x<=n} n. -Proof. -intro n. -exists (fun x:{x:nat|x<=n} => proj1_sig x). -split. -(* bounded *) -intro x; apply (proj2_sig x). -split. -(* injectivity *) -intros (p,Hp) (q,Hq). -simpl. -intro Hpq. -apply dep_pair_intro; assumption. -(* surjectivity *) -intros m Hmn. -exists (exist (fun x : nat => x <= n) m Hmn). -reflexivity. -Qed. - -(** Showing that equality on the interval [0;n] is decidable *) - -Lemma interval_dec : - forall n (x y : {m:nat|m<=n}), {x=y}+{x<>y}. -Proof. -intros n (p,Hp). -induction p; intros ([|q],Hq). -left. - apply dep_pair_intro. - reflexivity. -right. - intro H; discriminate H. -right. - intro H; discriminate H. -assert (Hp' : p <= n). - apply le_Sn_le; assumption. -assert (Hq' : q <= n). - apply le_Sn_le; assumption. -destruct (IHp Hp' (exist (fun m => m <= n) q Hq')) - as [Heq|Hneq]. -left. - injection Heq; intro Heq'. - apply dep_pair_intro. - apply eq_S. - assumption. -right. - intro HeqS. - injection HeqS; intro Heq. - apply Hneq. - apply dep_pair_intro. - assumption. -Qed. - -(** Showing that the cardinality relation is functional on decidable sets *) - -Lemma card_inj_aux : - forall (A:Type) f g n, - (forall x:A, f x <= 0) -> - (forall x y:A, f x = f y -> x = y) -> - (forall m, m <= S n -> exists x:A, g x = m) - -> False. -Proof. -intros A f g n Hfbound Hfinj Hgsurj. -destruct (Hgsurj (S n) (le_n _)) as (x,Hx). -destruct (Hgsurj n (le_S _ _ (le_n _))) as (x',Hx'). -assert (Hfx : 0 = f x). -apply le_n_O_eq. -apply Hfbound. -assert (Hfx' : 0 = f x'). -apply le_n_O_eq. -apply Hfbound. -assert (x=x'). -apply Hfinj. -rewrite <- Hfx. -rewrite <- Hfx'. -reflexivity. -rewrite H in Hx. -rewrite Hx' in Hx. -apply (n_Sn _ Hx). -Qed. - -(** For [dec_restrict], we use a lemma on the negation of equality -that requires proof-irrelevance. It should be possible to avoid this -lemma by generalizing over a first-order definition of [x<>y], say -[neq] such that [{x=y}+{neq x y}] and [~(x=y /\ neq x y)]; for such -[neq], unicity of proofs could be proven *) - - Require Import Classical. - Lemma neq_dep_intro : - forall (A:Set) (z x y:A) (p:x<>z) (q:y<>z), x=y -> - exist (fun x => x <> z) x p = exist (fun x => x <> z) y q. - Proof. - intros A z x y p q Heq. - generalize q; clear q; rewrite <- Heq; intro q. - rewrite (proof_irrelevance _ p q); reflexivity. - Qed. - -Lemma dec_restrict : - forall (A:Set), - (forall x y :A, {x=y}+{x<>y}) -> - forall z (x y :{a:A|a<>z}), {x=y}+{x<>y}. -Proof. -intros A Hdec z (x,Hx) (y,Hy). -destruct (Hdec x y) as [Heq|Hneq]. -left; apply neq_dep_intro; assumption. -right; intro Heq; injection Heq; exact Hneq. -Qed. - -Lemma pred_inj : forall n m, - 0 <> n -> 0 <> m -> pred m = pred n -> m = n. -Proof. -destruct n. -intros m H; destruct H; reflexivity. -destruct m. -intros _ H; destruct H; reflexivity. -simpl; intros _ _ H. -rewrite H. -reflexivity. -Qed. - -Lemma le_neq_lt : forall n m, n <= m -> n<>m -> n < m. -Proof. -intros n m Hle Hneq. -destruct (le_lt_eq_dec n m Hle). -assumption. -contradiction. -Qed. - -Lemma inj_restrict : - forall (A:Set) (f:A->nat) x y z, - (forall x y : A, f x = f y -> x = y) - -> x <> z -> f y < f z -> f z <= f x - -> pred (f x) = f y - -> False. - -(* Search error sans le type de f !! *) -Proof. -intros A f x y z Hfinj Hneqx Hfy Hfx Heq. -assert (f z <> f x). - apply not_eq_sym. - intro Heqf. - apply Hneqx. - apply Hfinj. - assumption. -assert (f x = S (f y)). - assert (0 < f x). - apply le_lt_trans with (f z). - apply le_O_n. - apply le_neq_lt; assumption. - apply pred_inj. - apply O_S. - apply lt_O_neq; assumption. - exact Heq. -assert (f z <= f y). -destruct (le_lt_or_eq _ _ Hfx). - apply lt_n_Sm_le. - rewrite <- H0. - assumption. - contradiction Hneqx. - symmetry. - apply Hfinj. - assumption. -contradiction (lt_not_le (f y) (f z)). -Qed. - -Theorem card_inj : forall m n (A:Set), - (forall x y :A, {x=y}+{x<>y}) -> - card A m -> card A n -> m = n. -Proof. -induction m; destruct n; -intros A Hdec - (f,(Hfbound,(Hfinj,Hfsurj))) - (g,(Hgbound,(Hginj,Hgsurj))). -(* 0/0 *) -reflexivity. -(* 0/Sm *) -destruct (card_inj_aux _ _ _ _ Hfbound Hfinj Hgsurj). -(* Sn/0 *) -destruct (card_inj_aux _ _ _ _ Hgbound Hginj Hfsurj). -(* Sn/Sm *) -destruct (Hgsurj (S n) (le_n _)) as (xSn,HSnx). -rewrite IHm with (n:=n) (A := {x:A|x<>xSn}). -reflexivity. -(* decidability of eq on {x:A|x<>xSm} *) -apply dec_restrict. -assumption. -(* cardinality of {x:A|x<>xSn} is m *) -pose (f' := fun x' : {x:A|x<>xSn} => - let (x,Hneq) := x' in - if le_lt_dec (f xSn) (f x) - then pred (f x) - else f x). -exists f'. -split. -(* f' is bounded *) -unfold f'. -intros (x,_). -destruct (le_lt_dec (f xSn) (f x)) as [Hle|Hge]. -change m with (pred (S m)). -apply le_pred. -apply Hfbound. -apply le_S_n. -apply le_trans with (f xSn). -exact Hge. -apply Hfbound. -split. -(* f' is injective *) -unfold f'. -intros (x,Hneqx) (y,Hneqy) Heqf'. -destruct (le_lt_dec (f xSn) (f x)) as [Hlefx|Hgefx]; -destruct (le_lt_dec (f xSn) (f y)) as [Hlefy|Hgefy]. -(* f xSn <= f x et f xSn <= f y *) -assert (Heq : x = y). - apply Hfinj. - assert (f xSn <> f y). - apply not_eq_sym. - intro Heqf. - apply Hneqy. - apply Hfinj. - assumption. - assert (0 < f y). - apply le_lt_trans with (f xSn). - apply le_O_n. - apply le_neq_lt; assumption. - assert (f xSn <> f x). - apply not_eq_sym. - intro Heqf. - apply Hneqx. - apply Hfinj. - assumption. - assert (0 < f x). - apply le_lt_trans with (f xSn). - apply le_O_n. - apply le_neq_lt; assumption. - apply pred_inj. - apply lt_O_neq; assumption. - apply lt_O_neq; assumption. - assumption. -apply neq_dep_intro; assumption. -(* f y < f xSn <= f x *) -destruct (inj_restrict A f x y xSn); assumption. -(* f x < f xSn <= f y *) -symmetry in Heqf'. -destruct (inj_restrict A f y x xSn); assumption. -(* f x < f xSn et f y < f xSn *) -assert (Heq : x=y). - apply Hfinj; assumption. -apply neq_dep_intro; assumption. -(* f' is surjective *) -intros p Hlep. -destruct (le_lt_dec (f xSn) p) as [Hle|Hlt]. -(* case f xSn <= p *) -destruct (Hfsurj (S p) (le_n_S _ _ Hlep)) as (x,Hx). -assert (Hneq : x <> xSn). - intro Heqx. - rewrite Heqx in Hx. - rewrite Hx in Hle. - apply le_Sn_n with p; assumption. -exists (exist (fun a => a<>xSn) x Hneq). -unfold f'. -destruct (le_lt_dec (f xSn) (f x)) as [Hle'|Hlt']. -rewrite Hx; reflexivity. -rewrite Hx in Hlt'. -contradiction (le_not_lt (f xSn) p). -apply lt_trans with (S p). -apply lt_n_Sn. -assumption. -(* case p < f xSn *) -destruct (Hfsurj p (le_S _ _ Hlep)) as (x,Hx). -assert (Hneq : x <> xSn). - intro Heqx. - rewrite Heqx in Hx. - rewrite Hx in Hlt. - apply (lt_irrefl p). - assumption. -exists (exist (fun a => a<>xSn) x Hneq). -unfold f'. -destruct (le_lt_dec (f xSn) (f x)) as [Hle'|Hlt']. - rewrite Hx in Hle'. - contradiction (lt_irrefl p). - apply lt_le_trans with (f xSn); assumption. - assumption. -(* cardinality of {x:A|x<>xSn} is n *) -pose (g' := fun x' : {x:A|x<>xSn} => - let (x,Hneq) := x' in - if Hdec x xSn then 0 else g x). -exists g'. -split. -(* g is bounded *) -unfold g'. -intros (x,_). -destruct (Hdec x xSn) as [_|Hneq]. -apply le_O_n. -assert (Hle_gx:=Hgbound x). -destruct (le_lt_or_eq _ _ Hle_gx). -apply lt_n_Sm_le. -assumption. -contradiction Hneq. -apply Hginj. -rewrite HSnx. -assumption. -split. -(* g is injective *) -unfold g'. -intros (x,Hneqx) (y,Hneqy) Heqg'. -destruct (Hdec x xSn) as [Heqx|_]. -contradiction Hneqx. -destruct (Hdec y xSn) as [Heqy|_]. -contradiction Hneqy. -assert (Heq : x=y). - apply Hginj; assumption. -apply neq_dep_intro; assumption. -(* g is surjective *) -intros p Hlep. -destruct (Hgsurj p (le_S _ _ Hlep)) as (x,Hx). -assert (Hneq : x<>xSn). - intro Heq. - rewrite Heq in Hx. - rewrite Hx in HSnx. - rewrite HSnx in Hlep. - contradiction (le_Sn_n _ Hlep). -exists (exist (fun a => a<>xSn) x Hneq). -simpl. -destruct (Hdec x xSn) as [Heqx|_]. -contradiction Hneq. -assumption. -Qed. - -(** Conclusion *) - -Theorem interval_discr : - forall n m, {p:nat|p<=n} = {p:nat|p<=m} -> n=m. -Proof. -intros n m Heq. -apply card_inj with (A := {p:nat|p<=n}). -apply interval_dec. -apply card_interval. -rewrite Heq. -apply card_interval. -Qed. diff --git a/doc/refman/Extraction.tex b/doc/refman/Extraction.tex index 79060e6062..cff7be3e96 100644 --- a/doc/refman/Extraction.tex +++ b/doc/refman/Extraction.tex @@ -1,4 +1,4 @@ -\achapter{Extraction of programs in Objective Caml and Haskell} +\achapter{Extraction of programs in OCaml and Haskell} %HEVEA\cutname{extraction.html} \label{Extraction} \aauthor{Jean-Christophe Filliâtre and Pierre Letouzey} @@ -95,12 +95,12 @@ one monolithic file or one file per \Coq\ library. \begin{description} \item {\tt Extraction TestCompile} \qualid$_1$ \dots\ \qualid$_n$. ~\par All the globals (or modules) \qualid$_1$ \dots\ \qualid$_n$ and all - their dependencies are extracted to a temporary Ocaml file, just as in + their dependencies are extracted to a temporary {\ocaml} file, just as in {\tt Extraction "{\em file}"}. Then this temporary file and its - signature are compiled with the same Ocaml compiler used to built - \Coq. This command succeeds only if the extraction and the Ocaml + signature are compiled with the same {\ocaml} compiler used to built + \Coq. This command succeeds only if the extraction and the {\ocaml} compilation succeed (and it fails if the current target language - of the extraction is not Ocaml). + of the extraction is not {\ocaml}). \end{description} \asection{Extraction options} @@ -109,26 +109,26 @@ one monolithic file or one file per \Coq\ library. \comindex{Extraction Language} The ability to fix target language is the first and more important -of the extraction options. Default is Ocaml. +of the extraction options. Default is {\ocaml}. \begin{description} -\item {\tt Extraction Language Ocaml}. +\item {\tt Extraction Language OCaml}. \item {\tt Extraction Language Haskell}. \item {\tt Extraction Language Scheme}. \end{description} \asubsection{Inlining and optimizations} -Since Objective Caml is a strict language, the extracted code has to +Since {\ocaml} is a strict language, the extracted code has to be optimized in order to be efficient (for instance, when using induction principles we do not want to compute all the recursive calls but only the needed ones). So the extraction mechanism provides an automatic optimization routine that will be called each time the user -want to generate Ocaml programs. The optimizations can be split in two +want to generate {\ocaml} programs. The optimizations can be split in two groups: the type-preserving ones -- essentially constant inlining and reductions -- and the non type-preserving ones -- some function abstractions of dummy types are removed when it is deemed safe in order to have more elegant types. Therefore some constants may not appear in the -resulting monolithic Ocaml program. In the case of modular extraction, +resulting monolithic {\ocaml} program. In the case of modular extraction, even if some inlining is done, the inlined constant are nevertheless printed, to ensure session-independent programs. @@ -367,15 +367,15 @@ As for {\tt Extract Inductive}, this command should be used with care: \item Extracting an inductive type to a pre-existing ML inductive type is quite sound. But extracting to a general type (by providing an ad-hoc pattern-matching) will often \emph{not} be fully rigorously -correct. For instance, when extracting {\tt nat} to Ocaml's {\tt +correct. For instance, when extracting {\tt nat} to {\ocaml}'s {\tt int}, it is theoretically possible to build {\tt nat} values that are -larger than Ocaml's {\tt max\_int}. It is the user's responsibility to +larger than {\ocaml}'s {\tt max\_int}. It is the user's responsibility to be sure that no overflow or other bad events occur in practice. \item Translating an inductive type to an ML type does \emph{not} magically improve the asymptotic complexity of functions, even if the ML type is an efficient representation. For instance, when extracting -{\tt nat} to Ocaml's {\tt int}, the function {\tt mult} stays +{\tt nat} to {\ocaml}'s {\tt int}, the function {\tt mult} stays quadratic. It might be interesting to associate this translation with some specific {\tt Extract Constant} when primitive counterparts exist. \end{itemize} @@ -402,7 +402,7 @@ Extract Inductive prod => "(*)" [ "(,)" ]. \end{coq_example} \noindent As an example of translation to a non-inductive datatype, let's turn -{\tt nat} into Ocaml's {\tt int} (see caveat above): +{\tt nat} into {\ocaml}'s {\tt int} (see caveat above): \begin{coq_example} Extract Inductive nat => int [ "0" "succ" ] "(fun fO fS n -> if n=0 then fO () else fS (n-1))". @@ -417,7 +417,7 @@ directly depends from the names of the \Coq\ files. It may happen that these filenames are in conflict with already existing files, either in the standard library of the target language or in other code that is meant to be linked with the extracted code. -For instance the module {\tt List} exists both in \Coq\ and in Ocaml. +For instance the module {\tt List} exists both in \Coq\ and in {\ocaml}. It is possible to instruct the extraction not to use particular filenames. \begin{description} @@ -430,7 +430,7 @@ It is possible to instruct the extraction not to use particular filenames. Allow the extraction to use any filename. \end{description} -\noindent For Ocaml, a typical use of these commands is +\noindent For {\ocaml}, a typical use of these commands is {\tt Extraction Blacklist String List}. \asection{Differences between \Coq\ and ML type systems} @@ -438,7 +438,7 @@ It is possible to instruct the extraction not to use particular filenames. Due to differences between \Coq\ and ML type systems, some extracted programs are not directly typable in ML. -We now solve this problem (at least in Ocaml) by adding +We now solve this problem (at least in {\ocaml}) by adding when needed some unsafe casting {\tt Obj.magic}, which give a generic type {\tt 'a} to any term. @@ -455,7 +455,7 @@ Definition dp := fun (A B:Set)(x:A)(y:B)(f:forall C:Set, C->C) => (f A x, f B y). \end{verbatim} -In Ocaml, for instance, the direct extracted term would be +In {\ocaml}, for instance, the direct extracted term would be \begin{verbatim} let dp x y f = Pair((f () x),(f () y)) \end{verbatim} @@ -480,13 +480,13 @@ Inductive anything : Type := dummy : forall A:Set, A -> anything. \end{verbatim} which corresponds to the definition of an ML dynamic type. -In Ocaml, we must cast any argument of the constructor dummy. +In {\ocaml}, we must cast any argument of the constructor dummy. \end{itemize} \noindent Even with those unsafe castings, you should never get error like ``segmentation fault''. In fact even if your program may seem -ill-typed to the Ocaml type-checker, it can't go wrong: it comes +ill-typed to the {\ocaml} type-checker, it can't go wrong: it comes from a Coq well-typed terms, so for example inductives will always have the correct number of arguments, etc. diff --git a/doc/refman/RefMan-ltac.tex b/doc/refman/RefMan-ltac.tex index 8d82460a72..ef0f4af8f6 100644 --- a/doc/refman/RefMan-ltac.tex +++ b/doc/refman/RefMan-ltac.tex @@ -709,6 +709,55 @@ runs is displayed. Time is in seconds and is machine-dependent. The {\qstring} argument is optional. When provided, it is used to identify this particular occurrence of {\tt time}. +\subsubsection{Timing a tactic that evaluates to a term\tacindex{time\_constr}\tacindex{restart\_timer}\tacindex{finish\_timing} +\index{Tacticals!time\_constr@{\tt time\_constr}}} +\index{Tacticals!restart\_timer@{\tt restart\_timer}} +\index{Tacticals!finish\_timing@{\tt finish\_timing}} + +Tactic expressions that produce terms can be timed with the experimental tactic +\begin{quote} + {\tt time\_constr} {\tacexpr} +\end{quote} +which evaluates {\tacexpr\tt{ ()}} +and displays the time the tactic expression evaluated, assuming successful evaluation. +Time is in seconds and is machine-dependent. + +This tactic currently does not support nesting, and will report times based on the innermost execution. +This is due to the fact that it is implemented using the tactics +\begin{quote} + {\tt restart\_timer} {\qstring} +\end{quote} +and +\begin{quote} + {\tt finish\_timing} ({\qstring}) {\qstring} +\end{quote} +which (re)set and display an optionally named timer, respectively. +The parenthesized {\qstring} argument to {\tt finish\_timing} is also +optional, and determines the label associated with the timer for +printing. + +By copying the definition of {\tt time\_constr} from the standard +library, users can achive support for a fixed pattern of nesting by +passing different {\qstring} parameters to {\tt restart\_timer} and +{\tt finish\_timing} at each level of nesting. For example: + +\begin{coq_example} +Ltac time_constr1 tac := + let eval_early := match goal with _ => restart_timer "(depth 1)" end in + let ret := tac () in + let eval_early := match goal with _ => finish_timing ( "Tactic evaluation" ) "(depth 1)" end in + ret. + +Goal True. + let v := time_constr + ltac:(fun _ => + let x := time_constr1 ltac:(fun _ => constr:(10 * 10)) in + let y := time_constr1 ltac:(fun _ => eval compute in x) in + y) in + pose v. +Abort. +\end{coq_example} + \subsubsection[Local definitions]{Local definitions\index{Ltac!let@\texttt{let}} \index{Ltac!let rec@\texttt{let rec}} \index{let@\texttt{let}!in Ltac} @@ -1358,6 +1407,21 @@ The following two tactics behave like {\tt idtac} but enable and disable the pro {\tt stop ltac profiling}. \end{quote} +\tacindex{reset ltac profile}\tacindex{show ltac profile} +The following tactics behave like the corresponding vernacular commands and allow displaying and resetting the profile from tactic scripts for benchmarking purposes. + +\begin{quote} +{\tt reset ltac profile}. +\end{quote} + +\begin{quote} +{\tt show ltac profile}. +\end{quote} + +\begin{quote} +{\tt show ltac profile} {\qstring}. +\end{quote} + You can also pass the {\tt -profile-ltac} command line option to {\tt coqc}, which performs a {\tt Set Ltac Profiling} at the beginning of each document, and a {\tt Show Ltac Profile} at the end. Note that the profiler currently does not handle backtracking into multi-success tactics, and issues a warning to this effect in many cases when such backtracking occurs. diff --git a/doc/refman/RefMan-ssr.tex b/doc/refman/RefMan-ssr.tex index be199e0b24..31dabcdd4e 100644 --- a/doc/refman/RefMan-ssr.tex +++ b/doc/refman/RefMan-ssr.tex @@ -3096,10 +3096,10 @@ the tactic \ssrC{rewrite (=~ multi1)} is equivalent to \end{lstlisting} except that the constants \ssrC{eqba, eqab, mult1_rev} have not been created. -Rewriting with multirules -is useful to implement simplification or transformation -procedures, to be applied on terms of small to medium size. For -instance the library \ssrL{ssrnat} provides two implementations for +Rewriting with multirules is useful to implement simplification or +transformation procedures, to be applied on terms of small to medium +size. For instance, the library \ssrL{ssrnat} --- available in the +external math-comp library --- provides two implementations for arithmetic operations on natural numbers: an elementary one and a tail recursive version, less inefficient but also less convenient for reasoning purposes. The library also provides one lemma per such diff --git a/engine/eConstr.ml b/engine/eConstr.ml index 53123c9334..a65b3941ef 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -770,6 +770,20 @@ let rec isArity sigma c = | Sort _ -> true | _ -> false +type arity = rel_context * ESorts.t + +let destArity sigma = + let open Context.Rel.Declaration in + let rec prodec_rec l c = + match kind sigma c with + | Prod (x,t,c) -> prodec_rec (LocalAssum (x,t) :: l) c + | LetIn (x,b,t,c) -> prodec_rec (LocalDef (x,b,t) :: l) c + | Cast (c,_,_) -> prodec_rec l c + | Sort s -> l,s + | _ -> anomaly ~label:"destArity" (Pp.str "not an arity.") + in + prodec_rec [] + let mkProd_or_LetIn decl c = let open Context.Rel.Declaration in match decl with @@ -817,6 +831,15 @@ let lookup_rel i e = cast_rel_decl (sym unsafe_eq) (lookup_rel i e) let lookup_named n e = cast_named_decl (sym unsafe_eq) (lookup_named n e) let lookup_named_val n e = cast_named_decl (sym unsafe_eq) (lookup_named_val n e) +let map_rel_context_in_env f env sign = + let rec aux env acc = function + | d::sign -> + aux (push_rel d env) (Context.Rel.Declaration.map_constr (f env) d :: acc) sign + | [] -> + acc + in + aux env [] (List.rev sign) + let fresh_global ?loc ?rigid ?names env sigma reference = let (evd,t) = Evd.fresh_global ?loc ?rigid ?names env sigma reference in evd, of_constr t diff --git a/engine/eConstr.mli b/engine/eConstr.mli index 6f2a30f4a3..30de748a19 100644 --- a/engine/eConstr.mli +++ b/engine/eConstr.mli @@ -146,7 +146,11 @@ val isFix : Evd.evar_map -> t -> bool val isCoFix : Evd.evar_map -> t -> bool val isCase : Evd.evar_map -> t -> bool val isProj : Evd.evar_map -> t -> bool + +type arity = rel_context * ESorts.t +val destArity : Evd.evar_map -> types -> arity val isArity : Evd.evar_map -> t -> bool + val isVarId : Evd.evar_map -> Id.t -> t -> bool val isRelN : Evd.evar_map -> int -> t -> bool @@ -262,6 +266,9 @@ val lookup_rel : int -> env -> rel_declaration val lookup_named : variable -> env -> named_declaration val lookup_named_val : variable -> named_context_val -> named_declaration +val map_rel_context_in_env : + (env -> constr -> constr) -> env -> rel_context -> rel_context + (* XXX Missing Sigma proxy *) val fresh_global : ?loc:Loc.t -> ?rigid:Evd.rigid -> ?names:Univ.Instance.t -> Environ.env -> diff --git a/engine/evarutil.ml b/engine/evarutil.ml index 3445b744a1..374fdce722 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -692,6 +692,55 @@ let undefined_evars_of_evar_info evd evi = (undefined_evars_of_named_context evd (named_context_of_val evi.evar_hyps))) +type undefined_evars_cache = { + mutable cache : (EConstr.named_declaration * Evar.Set.t) ref Id.Map.t; +} + +let create_undefined_evars_cache () = { cache = Id.Map.empty; } + +let cached_evar_of_hyp cache sigma decl accu = match cache with +| None -> + let fold c acc = + let evs = undefined_evars_of_term sigma c in + Evar.Set.union evs acc + in + NamedDecl.fold_constr fold decl accu +| Some cache -> + let id = NamedDecl.get_id decl in + let r = + try Id.Map.find id cache.cache + with Not_found -> + (** Dummy value *) + let r = ref (NamedDecl.LocalAssum (id, EConstr.mkProp), Evar.Set.empty) in + let () = cache.cache <- Id.Map.add id r cache.cache in + r + in + let (decl', evs) = !r in + let evs = + if NamedDecl.equal (==) decl decl' then snd !r + else + let fold c acc = + let evs = undefined_evars_of_term sigma c in + Evar.Set.union evs acc + in + let evs = NamedDecl.fold_constr fold decl Evar.Set.empty in + let () = r := (decl, evs) in + evs + in + Evar.Set.fold Evar.Set.add evs accu + +let filtered_undefined_evars_of_evar_info ?cache sigma evi = + let evars_of_named_context cache accu nc = + let fold decl accu = cached_evar_of_hyp cache sigma (EConstr.of_named_decl decl) accu in + Context.Named.fold_outside fold nc ~init:accu + in + let accu = match evi.evar_body with + | Evar_empty -> Evar.Set.empty + | Evar_defined b -> evars_of_term b + in + let accu = Evar.Set.union (undefined_evars_of_term sigma (EConstr.of_constr evi.evar_concl)) accu in + evars_of_named_context cache accu (evar_filtered_context evi) + (* spiwack: this is a more complete version of {!Termops.occur_evar}. The latter does not look recursively into an [evar_map]. If unification only need to check superficially, tactics diff --git a/engine/evarutil.mli b/engine/evarutil.mli index 9d0b973a7e..37f5968ad8 100644 --- a/engine/evarutil.mli +++ b/engine/evarutil.mli @@ -133,6 +133,12 @@ val undefined_evars_of_term : evar_map -> constr -> Evar.Set.t val undefined_evars_of_named_context : evar_map -> Context.Named.t -> Evar.Set.t val undefined_evars_of_evar_info : evar_map -> evar_info -> Evar.Set.t +type undefined_evars_cache + +val create_undefined_evars_cache : unit -> undefined_evars_cache + +val filtered_undefined_evars_of_evar_info : ?cache:undefined_evars_cache -> evar_map -> evar_info -> Evar.Set.t + (** [occur_evar_upto sigma k c] returns [true] if [k] appears in [c]. It looks up recursively in [sigma] for the value of existential variables. *) diff --git a/engine/proofview.ml b/engine/proofview.ml index 3b945c87f9..0a64351950 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -634,32 +634,42 @@ let shelve_goals l = InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve_goals")) >> Shelf.modify (fun gls -> gls @ l) -(** [contained_in_info e evi] checks whether the evar [e] appears in - the hypotheses, the conclusion or the body of the evar_info - [evi]. Note: since we want to use it on goals, the body is actually - supposed to be empty. *) -let contained_in_info sigma e evi = - Evar.Set.mem e (Evd.evars_of_filtered_evar_info (Evarutil.nf_evar_info sigma evi)) - (** [depends_on sigma src tgt] checks whether the goal [src] appears as an existential variable in the definition of the goal [tgt] in [sigma]. *) let depends_on sigma src tgt = let evi = Evd.find sigma tgt in - contained_in_info sigma src evi + Evar.Set.mem src (Evd.evars_of_filtered_evar_info (Evarutil.nf_evar_info sigma evi)) + +let unifiable_delayed g l = + CList.exists (fun (tgt, lazy evs) -> not (Evar.equal g tgt) && Evar.Set.mem g evs) l + +let free_evars sigma l = + let cache = Evarutil.create_undefined_evars_cache () in + let map ev = + (** Computes the set of evars appearing in the hypotheses, the conclusion or + the body of the evar_info [evi]. Note: since we want to use it on goals, + the body is actually supposed to be empty. *) + let evi = Evd.find sigma ev in + let fevs = lazy (Evarutil.filtered_undefined_evars_of_evar_info ~cache sigma evi) in + (ev, fevs) + in + List.map map l (** [unifiable sigma g l] checks whether [g] appears in another subgoal of [l]. The list [l] may contain [g], but it does not affect the result. *) let unifiable sigma g l = - CList.exists (fun tgt -> not (Evar.equal g tgt) && depends_on sigma g tgt) l + let l = free_evars sigma l in + unifiable_delayed g l (** [partition_unifiable sigma l] partitions [l] into a pair [(u,n)] where [u] is composed of the unifiable goals, i.e. the goals on whose definition other goals of [l] depend, and [n] are the non-unifiable goals. *) let partition_unifiable sigma l = - CList.partition (fun g -> unifiable sigma g l) l + let fevs = free_evars sigma l in + CList.partition (fun g -> unifiable_delayed g fevs) l (** Shelves the unifiable goals under focus, i.e. the goals which appear in other goals under focus (the unfocused goals are not diff --git a/ide/coq-ssreflect.lang b/ide/coq-ssreflect.lang index 7cfc167018..bd9cb4bfa2 100644 --- a/ide/coq-ssreflect.lang +++ b/ide/coq-ssreflect.lang @@ -228,7 +228,7 @@ <keyword>Implicit\%{space}+Arguments</keyword> <keyword>(Import)|(Include)</keyword> <keyword>Require(\%{space}+((Import)|(Export)))?</keyword> - <keyword>(Recursive\%{space}+)?Extraction(\%{space}+(Language\%{space}+(Ocaml)|(Haskell)|(Scheme)|(Toplevel))|(Library)|((No)?Inline)|(Blacklist))?</keyword> + <keyword>(Recursive\%{space}+)?Extraction(\%{space}+(Language\%{space}+(OCaml)|(Haskell)|(Scheme)|(Toplevel))|(Library)|((No)?Inline)|(Blacklist))?</keyword> <keyword>Extract\%{space}+(Inlined\%{space}+)?(Constant)|(Inductive)</keyword> <include> <context sub-pattern="1" style-ref="vernac-keyword"/> diff --git a/ide/coq.lang b/ide/coq.lang index 484264ece3..e9eab48de7 100644 --- a/ide/coq.lang +++ b/ide/coq.lang @@ -188,7 +188,7 @@ <keyword>(\%{locality}|(Reserved|Tactic)\%{space})?Notation</keyword> <keyword>\%{locality}Infix</keyword> <keyword>Declare\%{space}ML\%{space}Module</keyword> - <keyword>Extraction\%{space}Language\%{space}(Ocaml|Haskell|Scheme|JSON)</keyword> + <keyword>Extraction\%{space}Language\%{space}(OCaml|Haskell|Scheme|JSON)</keyword> </context> <context id="hint-command" style-ref="vernac-keyword"> diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 14234b3118..61b33aa415 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -2098,39 +2098,36 @@ let interp_open_constr env sigma c = (* Not all evars expected to be resolved and computation of implicit args *) -let interp_constr_evars_gen_impls env evdref +let interp_constr_evars_gen_impls env sigma ?(impls=empty_internalization_env) expected_type c = let c = intern_gen expected_type ~impls env c in let imps = Implicit_quantifiers.implicits_of_glob_constr ~with_products:(expected_type == IsType) c in - let evd, c = understand_tcc env !evdref ~expected_type c in - evdref := evd; - c, imps + let sigma, c = understand_tcc env sigma ~expected_type c in + sigma, (c, imps) -let interp_constr_evars_impls env evdref ?(impls=empty_internalization_env) c = - interp_constr_evars_gen_impls env evdref ~impls WithoutTypeConstraint c +let interp_constr_evars_impls env sigma ?(impls=empty_internalization_env) c = + interp_constr_evars_gen_impls env sigma ~impls WithoutTypeConstraint c let interp_casted_constr_evars_impls env evdref ?(impls=empty_internalization_env) c typ = interp_constr_evars_gen_impls env evdref ~impls (OfType typ) c -let interp_type_evars_impls env evdref ?(impls=empty_internalization_env) c = - interp_constr_evars_gen_impls env evdref ~impls IsType c +let interp_type_evars_impls env sigma ?(impls=empty_internalization_env) c = + interp_constr_evars_gen_impls env sigma ~impls IsType c (* Not all evars expected to be resolved, with side-effect on evars *) -let interp_constr_evars_gen env evdref ?(impls=empty_internalization_env) expected_type c = +let interp_constr_evars_gen env sigma ?(impls=empty_internalization_env) expected_type c = let c = intern_gen expected_type ~impls env c in - let evd, c = understand_tcc env !evdref ~expected_type c in - evdref := evd; - c + understand_tcc env sigma ~expected_type c let interp_constr_evars env evdref ?(impls=empty_internalization_env) c = interp_constr_evars_gen env evdref WithoutTypeConstraint ~impls c -let interp_casted_constr_evars env evdref ?(impls=empty_internalization_env) c typ = - interp_constr_evars_gen env evdref ~impls (OfType typ) c +let interp_casted_constr_evars env sigma ?(impls=empty_internalization_env) c typ = + interp_constr_evars_gen env sigma ~impls (OfType typ) c -let interp_type_evars env evdref ?(impls=empty_internalization_env) c = - interp_constr_evars_gen env evdref IsType ~impls c +let interp_type_evars env sigma ?(impls=empty_internalization_env) c = + interp_constr_evars_gen env sigma IsType ~impls c (* Miscellaneous *) @@ -2185,17 +2182,16 @@ let intern_context global_level env impl_env binders = with InternalizationError (loc,e) -> user_err ?loc ~hdr:"internalize" (explain_internalization_error e) -let interp_glob_context_evars env evdref k bl = +let interp_glob_context_evars env sigma k bl = let open EConstr in - let (env, par, _, impls) = + let env, sigma, par, _, impls = List.fold_left - (fun (env,params,n,impls) (na, k, b, t) -> + (fun (env,sigma,params,n,impls) (na, k, b, t) -> let t' = if Option.is_empty b then locate_if_hole ?loc:(loc_of_glob_constr t) na t else t in - let (evd,t) = understand_tcc env !evdref ~expected_type:IsType t' in - evdref := evd; + let sigma, t = understand_tcc env sigma ~expected_type:IsType t' in match b with None -> let d = LocalAssum (na,t) in @@ -2205,16 +2201,15 @@ let interp_glob_context_evars env evdref k bl = (ExplByPos (n, na), (true, true, true)) :: impls else impls in - (push_rel d env, d::params, succ n, impls) + (push_rel d env, sigma, d::params, succ n, impls) | Some b -> - let (evd,c) = understand_tcc env !evdref ~expected_type:(OfType t) b in - evdref := evd; + let sigma, c = understand_tcc env sigma ~expected_type:(OfType t) b in let d = LocalDef (na, c, t) in - (push_rel d env, d::params, n, impls)) - (env,[],k+1,[]) (List.rev bl) - in (env, par), impls + (push_rel d env, sigma, d::params, n, impls)) + (env,sigma,[],k+1,[]) (List.rev bl) + in sigma, ((env, par), impls) -let interp_context_evars ?(global_level=false) ?(impl_env=empty_internalization_env) ?(shift=0) env evdref params = +let interp_context_evars ?(global_level=false) ?(impl_env=empty_internalization_env) ?(shift=0) env sigma params = let int_env,bl = intern_context global_level env impl_env params in - let x = interp_glob_context_evars env evdref shift bl in - int_env, x + let sigma, x = interp_glob_context_evars env sigma shift bl in + sigma, (int_env, x) diff --git a/interp/constrintern.mli b/interp/constrintern.mli index af4e4a9c55..632b423b05 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -112,29 +112,28 @@ val interp_open_constr : env -> evar_map -> constr_expr -> evar_map * EConstr.co (** Accepting unresolved evars *) -val interp_constr_evars : env -> evar_map ref -> - ?impls:internalization_env -> constr_expr -> EConstr.constr +val interp_constr_evars : env -> evar_map -> + ?impls:internalization_env -> constr_expr -> evar_map * EConstr.constr +val interp_casted_constr_evars : env -> evar_map -> + ?impls:internalization_env -> constr_expr -> EConstr.types -> evar_map * EConstr.constr -val interp_casted_constr_evars : env -> evar_map ref -> - ?impls:internalization_env -> constr_expr -> EConstr.types -> EConstr.constr - -val interp_type_evars : env -> evar_map ref -> - ?impls:internalization_env -> constr_expr -> EConstr.types +val interp_type_evars : env -> evar_map -> + ?impls:internalization_env -> constr_expr -> evar_map * EConstr.types (** Accepting unresolved evars and giving back the manual implicit arguments *) -val interp_constr_evars_impls : env -> evar_map ref -> +val interp_constr_evars_impls : env -> evar_map -> ?impls:internalization_env -> constr_expr -> - EConstr.constr * Impargs.manual_implicits + evar_map * (EConstr.constr * Impargs.manual_implicits) -val interp_casted_constr_evars_impls : env -> evar_map ref -> +val interp_casted_constr_evars_impls : env -> evar_map -> ?impls:internalization_env -> constr_expr -> EConstr.types -> - EConstr.constr * Impargs.manual_implicits + evar_map * (EConstr.constr * Impargs.manual_implicits) -val interp_type_evars_impls : env -> evar_map ref -> +val interp_type_evars_impls : env -> evar_map -> ?impls:internalization_env -> constr_expr -> - EConstr.types * Impargs.manual_implicits + evar_map * (EConstr.types * Impargs.manual_implicits) (** Interprets constr patterns *) @@ -159,8 +158,8 @@ val interp_binder_evars : env -> evar_map ref -> Name.t -> constr_expr -> EConst val interp_context_evars : ?global_level:bool -> ?impl_env:internalization_env -> ?shift:int -> - env -> evar_map ref -> local_binder_expr list -> - internalization_env * ((env * EConstr.rel_context) * Impargs.manual_implicits) + env -> evar_map -> local_binder_expr list -> + evar_map * (internalization_env * ((env * EConstr.rel_context) * Impargs.manual_implicits)) (* val interp_context_gen : (env -> glob_constr -> unsafe_type_judgment Evd.in_evar_universe_context) -> *) (* (env -> Evarutil.type_constraint -> glob_constr -> unsafe_judgment Evd.in_evar_universe_context) -> *) diff --git a/interp/declare.ml b/interp/declare.ml index 0adad14198..8781c87192 100644 --- a/interp/declare.ml +++ b/interp/declare.ml @@ -31,64 +31,6 @@ type internal_flag = | InternalTacticRequest (* kernel action, no message is displayed *) | UserIndividualRequest (* user action, a message is displayed *) -(** Declaration of section variables and local definitions *) - -type section_variable_entry = - | SectionLocalDef of Safe_typing.private_constants definition_entry - | SectionLocalAssum of types Univ.in_universe_context_set * polymorphic * bool (** Implicit status *) - -type variable_declaration = DirPath.t * section_variable_entry * logical_kind - -let cache_variable ((sp,_),o) = - match o with - | Inl ctx -> Global.push_context_set false ctx - | Inr (id,(p,d,mk)) -> - (* Constr raisonne sur les noms courts *) - if variable_exists id then - alreadydeclared (Id.print id ++ str " already exists"); - - let impl,opaq,poly,ctx = match d with (* Fails if not well-typed *) - | SectionLocalAssum ((ty,ctx),poly,impl) -> - let () = Global.push_named_assum ((id,ty,poly),ctx) in - let impl = if impl then Implicit else Explicit in - impl, true, poly, ctx - | SectionLocalDef (de) -> - let univs = Global.push_named_def (id,de) in - let poly = match de.const_entry_universes with - | Monomorphic_const_entry _ -> false - | Polymorphic_const_entry _ -> true - in - Explicit, de.const_entry_opaque, - poly, univs in - Nametab.push (Nametab.Until 1) (restrict_path 0 sp) (VarRef id); - add_section_variable id impl poly ctx; - Dischargedhypsmap.set_discharged_hyps sp []; - add_variable_data id (p,opaq,ctx,poly,mk) - -let discharge_variable (_,o) = match o with - | Inr (id,_) -> - if variable_polymorphic id then None - else Some (Inl (variable_context id)) - | Inl _ -> Some o - -type variable_obj = - (Univ.ContextSet.t, Id.t * variable_declaration) union - -let inVariable : variable_obj -> obj = - declare_object { (default_object "VARIABLE") with - cache_function = cache_variable; - discharge_function = discharge_variable; - classify_function = (fun _ -> Dispose) } - -(* for initial declaration *) -let declare_variable id obj = - let oname = add_leaf id (inVariable (Inr (id,obj))) in - declare_var_implicits id; - Notation.declare_ref_arguments_scope (VarRef id); - Heads.declare_head (EvalVarRef id); - oname - - (** Declaration of constants and parameters *) type constant_obj = { @@ -195,6 +137,20 @@ let update_tables c = Heads.declare_head (EvalConstRef c); Notation.declare_ref_arguments_scope (ConstRef c) +let register_side_effect (c, role) = + let o = inConstant { + cst_decl = None; + cst_hyps = [] ; + cst_kind = IsProof Theorem; + cst_locl = false; + } in + let id = Label.to_id (pi3 (Constant.repr3 c)) in + ignore(add_leaf id o); + update_tables c; + match role with + | Safe_typing.Subproof -> () + | Safe_typing.Schema (ind, kind) -> !declare_scheme kind [|ind,c|] + let declare_constant_common id cst = let o = inConstant cst in let _, kn as oname = add_leaf id o in @@ -229,25 +185,11 @@ let declare_constant ?(internal = UserIndividualRequest) ?(local = false) id ?(e (** This globally defines the side-effects in the environment. We mark exported constants as being side-effect not to redeclare them at caching time. *) - let cd, export = Global.export_private_constants ~in_section cd in - export, ConstantEntry (PureEntry, cd) + let de, export = Global.export_private_constants ~in_section de in + export, ConstantEntry (PureEntry, DefinitionEntry de) | _ -> [], ConstantEntry (EffectEntry, cd) in - let iter_eff (c, role) = - let o = inConstant { - cst_decl = None; - cst_hyps = [] ; - cst_kind = IsProof Theorem; - cst_locl = false; - } in - let id = Label.to_id (pi3 (Constant.repr3 c)) in - ignore(add_leaf id o); - update_tables c; - match role with - | Safe_typing.Subproof -> () - | Safe_typing.Schema (ind, kind) -> !declare_scheme kind [|ind,c|] - in - let () = List.iter iter_eff export in + let () = List.iter register_side_effect export in let cst = { cst_decl = Some decl; cst_hyps = [] ; @@ -265,6 +207,65 @@ let declare_definition ?(internal=UserIndividualRequest) declare_constant ~internal ~local id (Entries.DefinitionEntry cb, Decl_kinds.IsDefinition kind) +(** Declaration of section variables and local definitions *) + +type section_variable_entry = + | SectionLocalDef of Safe_typing.private_constants definition_entry + | SectionLocalAssum of types Univ.in_universe_context_set * polymorphic * bool (** Implicit status *) + +type variable_declaration = DirPath.t * section_variable_entry * logical_kind + +let cache_variable ((sp,_),o) = + match o with + | Inl ctx -> Global.push_context_set false ctx + | Inr (id,(p,d,mk)) -> + (* Constr raisonne sur les noms courts *) + if variable_exists id then + alreadydeclared (Id.print id ++ str " already exists"); + + let impl,opaq,poly,ctx = match d with (* Fails if not well-typed *) + | SectionLocalAssum ((ty,ctx),poly,impl) -> + let () = Global.push_named_assum ((id,ty,poly),ctx) in + let impl = if impl then Implicit else Explicit in + impl, true, poly, ctx + | SectionLocalDef (de) -> + let (de, eff) = Global.export_private_constants ~in_section:true de in + let () = List.iter register_side_effect eff in + let univs = Global.push_named_def (id,de) in + let poly = match de.const_entry_universes with + | Monomorphic_const_entry _ -> false + | Polymorphic_const_entry _ -> true + in + Explicit, de.const_entry_opaque, + poly, univs in + Nametab.push (Nametab.Until 1) (restrict_path 0 sp) (VarRef id); + add_section_variable id impl poly ctx; + Dischargedhypsmap.set_discharged_hyps sp []; + add_variable_data id (p,opaq,ctx,poly,mk) + +let discharge_variable (_,o) = match o with + | Inr (id,_) -> + if variable_polymorphic id then None + else Some (Inl (variable_context id)) + | Inl _ -> Some o + +type variable_obj = + (Univ.ContextSet.t, Id.t * variable_declaration) union + +let inVariable : variable_obj -> obj = + declare_object { (default_object "VARIABLE") with + cache_function = cache_variable; + discharge_function = discharge_variable; + classify_function = (fun _ -> Dispose) } + +(* for initial declaration *) +let declare_variable id obj = + let oname = add_leaf id (inVariable (Inr (id,obj))) in + declare_var_implicits id; + Notation.declare_ref_arguments_scope (VarRef id); + Heads.declare_head (EvalVarRef id); + oname + (** Declaration of inductive blocks *) let declare_inductive_argument_scopes kn mie = diff --git a/kernel/constr.mli b/kernel/constr.mli index 21c477578c..98bf713082 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -203,7 +203,7 @@ type ('constr, 'types, 'sort, 'univs) kind_of_term = | Cast of 'constr * cast_kind * 'types | Prod of Name.t * 'types * 'types (** Concrete syntax ["forall A:B,C"] is represented as [Prod (A,B,C)]. *) | Lambda of Name.t * 'types * 'constr (** Concrete syntax ["fun A:B => C"] is represented as [Lambda (A,B,C)]. *) - | LetIn of Name.t * 'constr * 'types * 'constr (** Concrete syntax ["let A:B := C in D"] is represented as [LetIn (A,B,C,D)]. *) + | LetIn of Name.t * 'constr * 'types * 'constr (** Concrete syntax ["let A:C := B in D"] is represented as [LetIn (A,B,C,D)]. *) | App of 'constr * 'constr array (** Concrete syntax ["(F P1 P2 ... Pn)"] is represented as [App (F, [|P1; P2; ...; Pn|])]. The {!mkApp} constructor also enforces the following invariant: diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 5150ad4113..fa984515a7 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -383,8 +383,7 @@ let safe_push_named d env = let push_named_def (id,de) senv = let open Entries in - let trust = Term_typing.SideEffects senv.revstruct in - let c,typ,univs = Term_typing.translate_local_def trust senv.env id de in + let c,typ,univs = Term_typing.translate_local_def senv.env id de in let poly = match de.Entries.const_entry_universes with | Monomorphic_const_entry _ -> false | Polymorphic_const_entry _ -> true diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index a30bb37e64..fbc398a2aa 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -90,7 +90,7 @@ val push_named_assum : (** Returns the full universe context necessary to typecheck the definition (futures are forced) *) val push_named_def : - Id.t * private_constants Entries.definition_entry -> Univ.ContextSet.t safe_transformer + Id.t * unit Entries.definition_entry -> Univ.ContextSet.t safe_transformer (** Insertion of global axioms or definitions *) @@ -106,8 +106,8 @@ type exported_private_constant = Constant.t * private_constant_role val export_private_constants : in_section:bool -> - private_constants Entries.constant_entry -> - (unit Entries.constant_entry * exported_private_constant list) safe_transformer + private_constants Entries.definition_entry -> + (unit Entries.definition_entry * exported_private_constant list) safe_transformer (** returns the main constant plus a list of auxiliary constants (empty unless one requires the side effects to be exported) *) diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 70dd6438d4..761eab511a 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -533,14 +533,10 @@ type side_effect_role = type exported_side_effect = Constant.t * constant_body * side_effect_role -let export_side_effects mb env ce = - match ce with - | ParameterEntry e -> [], ParameterEntry e - | ProjectionEntry e -> [], ProjectionEntry e - | DefinitionEntry c -> +let export_side_effects mb env c = let { const_entry_body = body } = c in let _, eff = Future.force body in - let ce = DefinitionEntry { c with + let ce = { c with const_entry_body = Future.chain body (fun (b_ctx, _) -> b_ctx, ()) } in let not_exists (c,_,_,_) = @@ -609,9 +605,9 @@ let translate_recipe env kn r = let hcons = DirPath.is_empty dir in build_constant_declaration kn env (Cooking.cook_constant ~hcons env r) -let translate_local_def mb env id centry = +let translate_local_def env id centry = let open Cooking in - let decl = infer_declaration ~trust:mb env None (DefinitionEntry centry) in + let decl = infer_declaration ~trust:Pure env None (DefinitionEntry centry) in let typ = decl.cook_type in if Option.is_empty decl.cook_context && !Flags.record_aux_file then begin match decl.cook_body with diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli index 55da4197e2..c771452a19 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -18,7 +18,7 @@ type _ trust = | Pure : unit trust | SideEffects : structure_body -> side_effects trust -val translate_local_def : 'a trust -> env -> Id.t -> 'a definition_entry -> +val translate_local_def : env -> Id.t -> unit definition_entry -> constant_def * types * Univ.ContextSet.t val translate_local_assum : env -> types -> types @@ -62,8 +62,8 @@ type exported_side_effect = * be pushed in the safe_env by safe typing. The main constant entry * needs to be translated as usual after this step. *) val export_side_effects : - structure_body -> env -> side_effects constant_entry -> - exported_side_effect list * unit constant_entry + structure_body -> env -> side_effects definition_entry -> + exported_side_effect list * unit definition_entry val translate_mind : env -> MutInd.t -> mutual_inductive_entry -> mutual_inductive_body diff --git a/lib/cList.ml b/lib/cList.ml index ca69628af7..0ef7c3d8ba 100644 --- a/lib/cList.ml +++ b/lib/cList.ml @@ -96,6 +96,8 @@ sig val fold_right_map : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a val fold_left2_map : ('a -> 'b -> 'c -> 'a * 'd) -> 'a -> 'b list -> 'c list -> 'a * 'd list val fold_right2_map : ('b -> 'c -> 'a -> 'd * 'a) -> 'b list -> 'c list -> 'a -> 'd list * 'a + val fold_left3_map : ('a -> 'b -> 'c -> 'd -> 'a * 'e) -> 'a -> 'b list -> 'c list -> 'd list -> 'a * 'e list + val fold_left4_map : ('a -> 'b -> 'c -> 'd -> 'e -> 'a * 'r) -> 'a -> 'b list -> 'c list -> 'd list -> 'e list -> 'a * 'r list val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list val fold_map' : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a val map_assoc : ('a -> 'b) -> ('c * 'a) list -> ('c * 'b) list @@ -446,6 +448,12 @@ let rec fold_left3 f accu l1 l2 l3 = | (a1::l1, a2::l2, a3::l3) -> fold_left3 f (f accu a1 a2 a3) l1 l2 l3 | (_, _, _) -> invalid_arg "List.fold_left3" +let rec fold_left4 f accu l1 l2 l3 l4 = + match (l1, l2, l3, l4) with + ([], [], [], []) -> accu + | (a1::l1, a2::l2, a3::l3, a4::l4) -> fold_left4 f (f accu a1 a2 a3 a4) l1 l2 l3 l4 + | (_,_, _, _) -> invalid_arg "List.fold_left4" + (* [fold_right_and_left f [a1;...;an] hd = f (f (... (f (f hd an @@ -765,12 +773,13 @@ let share_tails l1 l2 = in shr_rev [] (List.rev l1, List.rev l2) +(* Poor man's monadic map *) let rec fold_left_map f e = function - | [] -> (e,[]) - | h::t -> - let e',h' = f e h in - let e'',t' = fold_left_map f e' t in - e'',h'::t' + | [] -> (e,[]) + | h::t -> + let e',h' = f e h in + let e'',t' = fold_left_map f e' t in + e'',h'::t' let fold_map = fold_left_map @@ -790,12 +799,26 @@ let fold_right_map f l e = let fold_map' = fold_right_map +let on_snd f (x,y) = (x,f y) + let fold_left2_map f e l l' = - List.fold_left2 (fun (e,l) x x' -> let (e,y) = f e x x' in (e,y::l)) (e,[]) l l' + on_snd List.rev @@ + List.fold_left2 (fun (e,l) x x' -> + let (e,y) = f e x x' in + (e, y::l) + ) (e, []) l l' let fold_right2_map f l l' e = List.fold_right2 (fun x x' (l,e) -> let (y,e) = f x x' e in (y::l,e)) l l' ([],e) +let fold_left3_map f e l l' l'' = + on_snd List.rev @@ + fold_left3 (fun (e,l) x x' x'' -> let (e,y) = f e x x' x'' in (e,y::l)) (e,[]) l l' l'' + +let fold_left4_map f e l1 l2 l3 l4 = + on_snd List.rev @@ + fold_left4 (fun (e,l) x1 x2 x3 x4 -> let (e,y) = f e x1 x2 x3 x4 in (e,y::l)) (e,[]) l1 l2 l3 l4 + let map_assoc f = List.map (fun (x,a) -> (x,f a)) let rec assoc_f f a = function diff --git a/lib/cList.mli b/lib/cList.mli index 8cb07da79c..f87db04cf4 100644 --- a/lib/cList.mli +++ b/lib/cList.mli @@ -211,7 +211,14 @@ sig val fold_right2_map : ('b -> 'c -> 'a -> 'd * 'a) -> 'b list -> 'c list -> 'a -> 'd list * 'a (** Same with two lists, folding on the right *) + val fold_left3_map : ('a -> 'b -> 'c -> 'd -> 'a * 'e) -> 'a -> 'b list -> 'c list -> 'd list -> 'a * 'e list + (** Same with three lists, folding on the left *) + + val fold_left4_map : ('a -> 'b -> 'c -> 'd -> 'e -> 'a * 'r) -> 'a -> 'b list -> 'c list -> 'd list -> 'e list -> 'a * 'r list + (** Same with four lists, folding on the left *) + val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list + (* [@@ocaml.deprecated "Same as [fold_left_map]"] *) (** @deprecated Same as [fold_left_map] *) val fold_map' : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a diff --git a/library/global.mli b/library/global.mli index 324181e79e..2a646386e7 100644 --- a/library/global.mli +++ b/library/global.mli @@ -32,11 +32,11 @@ val set_typing_flags : Declarations.typing_flags -> unit (** Variables, Local definitions, constants, inductive types *) val push_named_assum : (Id.t * Constr.types * bool) Univ.in_universe_context_set -> unit -val push_named_def : (Id.t * Safe_typing.private_constants Entries.definition_entry) -> Univ.ContextSet.t +val push_named_def : (Id.t * unit Entries.definition_entry) -> Univ.ContextSet.t val export_private_constants : in_section:bool -> - Safe_typing.private_constants Entries.constant_entry -> - unit Entries.constant_entry * Safe_typing.exported_private_constant list + Safe_typing.private_constants Entries.definition_entry -> + unit Entries.definition_entry * Safe_typing.exported_private_constant list val add_constant : DirPath.t -> Id.t -> Safe_typing.global_declaration -> Constant.t diff --git a/library/nametab.ml b/library/nametab.ml index 84225f8639..08881d6d7a 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -81,8 +81,9 @@ struct Module F (X : S). Module X. The argument X of the functor F is masked by the inner module X. *) - let masking_absolute n = - Flags.if_verbose Feedback.msg_info (str ("Trying to mask the absolute name \"" ^ U.to_string n ^ "\"!")) + let warn_masking_absolute = + CWarnings.create ~name:"masking-absolute-name" ~category:"deprecated" + (fun n -> str ("Trying to mask the absolute name \"" ^ U.to_string n ^ "\"!")) type user_name = U.t @@ -121,7 +122,7 @@ struct | Absolute (n,_) -> (* This is an absolute name, we must keep it otherwise it may become unaccessible forever *) - masking_absolute n; tree.path + warn_masking_absolute n; tree.path | Nothing | Relative _ -> Relative (uname,o) else tree.path @@ -154,7 +155,7 @@ let rec push_exactly uname o level tree = function | Absolute (n,_) -> (* This is an absolute name, we must keep it otherwise it may become unaccessible forever *) - masking_absolute n; tree.path + warn_masking_absolute n; tree.path | Nothing | Relative _ -> Relative (uname,o) in diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index fb65a8639a..c8c4c2dad9 100644 --- a/plugins/derive/derive.ml +++ b/plugins/derive/derive.ml @@ -38,9 +38,8 @@ let start_deriving f suchthat lemma = let f_type = EConstr.Unsafe.to_constr f_type in let ef = EConstr.Unsafe.to_constr ef in let env' = Environ.push_named (LocalDef (f, ef, f_type)) env in - let evdref = ref sigma in - let suchthat = Constrintern.interp_type_evars env' evdref suchthat in - TCons ( env' , !evdref , suchthat , (fun sigma _ -> + let sigma, suchthat = Constrintern.interp_type_evars env' sigma suchthat in + TCons ( env' , sigma , suchthat , (fun sigma _ -> TNil sigma)))))) in diff --git a/plugins/extraction/g_extraction.ml4 b/plugins/extraction/g_extraction.ml4 index 23452febdc..24c70bccfb 100644 --- a/plugins/extraction/g_extraction.ml4 +++ b/plugins/extraction/g_extraction.ml4 @@ -42,14 +42,20 @@ ARGUMENT EXTEND int_or_id END let pr_language = function - | Ocaml -> str "Ocaml" + | Ocaml -> str "OCaml" | Haskell -> str "Haskell" | Scheme -> str "Scheme" | JSON -> str "JSON" +let warn_deprecated_ocaml_spelling = + CWarnings.create ~name:"deprecated-ocaml-spelling" ~category:"deprecated" + (fun () -> + strbrk ("The spelling \"OCaml\" should be used instead of \"Ocaml\".")) + VERNAC ARGUMENT EXTEND language PRINTED BY pr_language -| [ "Ocaml" ] -> [ Ocaml ] +| [ "Ocaml" ] -> [ let _ = warn_deprecated_ocaml_spelling () in Ocaml ] +| [ "OCaml" ] -> [ Ocaml ] | [ "Haskell" ] -> [ Haskell ] | [ "Scheme" ] -> [ Scheme ] | [ "JSON" ] -> [ JSON ] diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index fa43536304..889c064b24 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -1497,7 +1497,7 @@ let do_build_inductive let _time2 = System.get_time () in try with_full_print - (Flags.silently (Command.do_mutual_inductive rel_inds (Flags.is_universe_polymorphism ()) false false)) + (Flags.silently (ComInductive.do_mutual_inductive rel_inds (Flags.is_universe_polymorphism ()) false false)) Decl_kinds.Finite with | UserError(s,msg) as e -> diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 9e22ad3063..071599d9c5 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -158,8 +158,8 @@ let build_newrecursive (fun (env,impls) (((_,recname),_),bl,arityc,_) -> let arityc = Constrexpr_ops.mkCProdN bl arityc in let arity,ctx = Constrintern.interp_type env0 sigma arityc in - let evdref = ref (Evd.from_env env0) in - let _, (_, impls') = Constrintern.interp_context_evars env evdref bl in + let evd = Evd.from_env env0 in + let evd, (_, (_, impls')) = Constrintern.interp_context_evars env evd bl in let impl = Constrintern.compute_internalization_data env0 Constrintern.Recursive arity impls' in let open Context.Named.Declaration in (Environ.push_named (LocalAssum (recname,arity)) env, Id.Map.add recname impl impls)) @@ -406,7 +406,8 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp match fixpoint_exprl with | [(((_,fname),pl),_,bl,ret_type,body),_] when not is_rec -> let body = match body with | Some body -> body | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in - Command.do_definition + ComDefinition.do_definition + ~program_mode:false fname (Decl_kinds.Global,(Flags.is_universe_polymorphism ()),Decl_kinds.Definition) pl bl None body (Some ret_type) (Lemmas.mk_hook (fun _ _ -> ())); @@ -426,7 +427,7 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp in evd,List.rev rev_pconstants | _ -> - Command.do_fixpoint Global (Flags.is_universe_polymorphism ()) fixpoint_exprl; + ComFixpoint.do_fixpoint Global (Flags.is_universe_polymorphism ()) fixpoint_exprl; let evd,rev_pconstants = List.fold_left (fun (evd,l) ((((_,fname),_),_,_,_,_),_) -> @@ -616,8 +617,8 @@ and rebuild_nal aux bk bl' nal typ = let rebuild_bl aux bl typ = rebuild_bl aux bl typ let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = - let fixl,ntns = Command.extract_fixpoint_components false fixpoint_exprl in - let ((_,_,typel),_,ctx,_) = Command.interp_fixpoint fixl ntns in + let fixl,ntns = ComFixpoint.extract_fixpoint_components false fixpoint_exprl in + let ((_,_,typel),_,ctx,_) = ComFixpoint.interp_fixpoint ~cofix:false fixl ntns in let constr_expr_typel = with_full_print (List.map (fun c -> Constrextern.extern_constr false (Global.env ()) (Evd.from_ctx ctx) (EConstr.of_constr c))) typel in let fixpoint_exprl_with_new_bl = diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index 9e2774ff32..9fcb35f89e 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -889,11 +889,11 @@ let merge_inductive (ind1: inductive) (ind2: inductive) } in *) let indexpr = glob_constr_list_to_inductive_expr prms1 prms2 mib1 mib2 shift_prm rawlist in (* Declare inductive *) - let indl,_,_ = Command.extract_mutual_inductive_declaration_components [(indexpr,[])] in - let mie,pl,impls = Command.interp_mutual_inductive indl [] + let indl,_,_ = ComInductive.extract_mutual_inductive_declaration_components [(indexpr,[])] in + let mie,pl,impls = ComInductive.interp_mutual_inductive indl [] false (* non-cumulative *) false (*FIXMEnon-poly *) false (* means not private *) Decl_kinds.Finite (* means: not coinductive *) in (* Declare the mutual inductive block with its associated schemes *) - ignore (Command.declare_mutual_inductive_with_eliminations mie pl impls) + ignore (ComInductive.declare_mutual_inductive_with_eliminations mie pl impls) (* Find infos on identifier id. *) diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 766adfc63a..363ad5dfc9 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -1427,7 +1427,7 @@ let com_terminate nb_args ctx hook = let start_proof ctx (tac_start:tactic) (tac_end:tactic) = - let evmap, env = Pfedit.get_current_context () in + let evd, env = Pfedit.get_current_context () in Lemmas.start_proof thm_name (Global, false (* FIXME *), Proof Lemma) ~sign:(Environ.named_context_val env) ctx (EConstr.of_constr (compute_terminate_type nb_args fonctional_ref)) hook; @@ -1479,13 +1479,13 @@ let (com_eqn : int -> Id.t -> | ConstRef c -> is_opaque_constant c | _ -> anomaly ~label:"terminate_lemma" (Pp.str "not a constant.") in - let evmap, env = Pfedit.get_current_context () in - let evmap = Evd.from_ctx (Evd.evar_universe_context evmap) in + let evd, env = Pfedit.get_current_context () in + let evd = Evd.from_ctx (Evd.evar_universe_context evd) in let f_constr = constr_of_global f_ref in let equation_lemma_type = subst1 f_constr equation_lemma_type in (Lemmas.start_proof eq_name (Global, false, Proof Lemma) ~sign:(Environ.named_context_val env) - evmap + evd (EConstr.of_constr equation_lemma_type) (Lemmas.mk_hook (fun _ _ -> ())); ignore (by @@ -1528,14 +1528,14 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let open Constr in let open CVars in let env = Global.env() in - let evd = ref (Evd.from_env env) in - let function_type = interp_type_evars env evd type_of_f in + let evd = Evd.from_env env in + let evd, function_type = interp_type_evars env evd type_of_f in let function_type = EConstr.Unsafe.to_constr function_type in let env = push_named (Context.Named.Declaration.LocalAssum (function_name,function_type)) env in (* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *) - let ty = interp_type_evars env evd ~impls:rec_impls eq in + let evd, ty = interp_type_evars env evd ~impls:rec_impls eq in let ty = EConstr.Unsafe.to_constr ty in - let evm, nf = Evarutil.nf_evars_and_universes !evd in + let evd, nf = Evarutil.nf_evars_and_universes evd in let equation_lemma_type = nf_betaiotazeta (EConstr.of_constr (nf ty)) in let function_type = nf function_type in let equation_lemma_type = EConstr.Unsafe.to_constr equation_lemma_type in @@ -1560,16 +1560,16 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let functional_id = add_suffix function_name "_F" in let term_id = add_suffix function_name "_terminate" in let functional_ref = - let univs = Entries.Monomorphic_const_entry (Evd.universe_context_set evm) in + let univs = Entries.Monomorphic_const_entry (Evd.universe_context_set evd) in declare_fun functional_id (IsDefinition Decl_kinds.Definition) ~univs res in (* Refresh the global universes, now including those of _F *) - let evm = Evd.from_env (Global.env ()) in + let evd = Evd.from_env (Global.env ()) in let env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> LocalAssum (x,t)) pre_rec_args) env in let relation, evuctx = - interp_constr env_with_pre_rec_args evm r + interp_constr env_with_pre_rec_args evd r in - let evm = Evd.from_ctx evuctx in + let evd = Evd.from_ctx evuctx in let tcc_lemma_name = add_suffix function_name "_tcc" in let tcc_lemma_constr = ref Undefined in (* let _ = Pp.msgnl (str "relation := " ++ Printer.pr_lconstr_env env_with_pre_rec_args relation) in *) @@ -1599,7 +1599,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num and functional_ref = destConst (constr_of_global functional_ref) and eq_ref = destConst (constr_of_global eq_ref) in generate_induction_principle f_ref tcc_lemma_constr - functional_ref eq_ref rec_arg_num (EConstr.of_constr rec_arg_type) (nb_prod evm (EConstr.of_constr res)) (EConstr.of_constr relation); + functional_ref eq_ref rec_arg_num (EConstr.of_constr rec_arg_type) (nb_prod evd (EConstr.of_constr res)) (EConstr.of_constr relation); Flags.if_verbose msgnl (h 1 (Ppconstr.pr_id function_name ++ spc () ++ str"is defined" )++ fnl () ++ @@ -1618,5 +1618,5 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num term_id using_lemmas (List.length res_vars) - evm (Lemmas.mk_hook hook)) + evd (Lemmas.mk_hook hook)) () diff --git a/plugins/ltac/profile_ltac.ml b/plugins/ltac/profile_ltac.ml index 5225420dc4..1615465281 100644 --- a/plugins/ltac/profile_ltac.ml +++ b/plugins/ltac/profile_ltac.ml @@ -289,7 +289,7 @@ let rec find_in_stack what acc = function | { name } as x :: rest when String.equal name what -> Some(acc, x, rest) | { name } as x :: rest -> find_in_stack what (x :: acc) rest -let exit_tactic start_time c = +let exit_tactic ~count_call start_time c = let diff = time () -. start_time in match Local.(!stack) with | [] | [_] -> @@ -304,7 +304,7 @@ let exit_tactic start_time c = let node = { node with total = node.total +. diff; local = node.local +. diff; - ncalls = node.ncalls + 1; + ncalls = node.ncalls + (if count_call then 1 else 0); max_total = max node.max_total diff; } in (* updating the stack *) @@ -341,7 +341,7 @@ let tclFINALLY tac (finally : unit Proofview.tactic) = (fun v -> finally <*> Proofview.tclUNIT v) (fun (exn, info) -> finally <*> Proofview.tclZERO ~info exn) -let do_profile s call_trace tac = +let do_profile s call_trace ?(count_call=true) tac = let open Proofview.Notations in Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> if !is_profiling then @@ -359,7 +359,7 @@ let do_profile s call_trace tac = tac (Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> (match call_trace with - | (_, c) :: _ -> exit_tactic start_time c + | (_, c) :: _ -> exit_tactic ~count_call start_time c | [] -> ())))) | None -> tac @@ -397,6 +397,27 @@ let reset_profile () = reset_profile_tmp (); data := SM.empty +(* ****************************** Named timers ****************************** *) + +let timer_data = ref M.empty + +let timer_name = function + | Some v -> v + | None -> "" + +let restart_timer name = + timer_data := M.add (timer_name name) (System.get_time ()) !timer_data + +let get_timer name = + try M.find (timer_name name) !timer_data + with Not_found -> System.get_time () + +let finish_timing ~prefix name = + let tend = System.get_time () in + let tstart = get_timer name in + Feedback.msg_info(str prefix ++ pr_opt str name ++ str " ran for " ++ + System.fmt_time_difference tstart tend) + (* ******************** *) let print_results_filter ~cutoff ~filter = diff --git a/plugins/ltac/profile_ltac.mli b/plugins/ltac/profile_ltac.mli index 52827cb36b..adedf7ee91 100644 --- a/plugins/ltac/profile_ltac.mli +++ b/plugins/ltac/profile_ltac.mli @@ -9,9 +9,39 @@ (** Ltac profiling primitives *) +(* Note(JasonGross): Ltac semantics are a bit insane. There isn't + really a good notion of how many times a tactic has been "called", + because tactics can be partially evaluated, and it's unclear + whether the number of "calls" should be the number of times the + body is fetched and unfolded, or the number of times the code is + executed to a value, etc. The logic in [Tacinterp.eval_tactic] + gives a decent approximation, which I believe roughly corresponds + to the number of times that the engine runs the tactic value which + results from evaluating the tactic expression bound to the name + we're considering. However, this is a poor approximation of the + time spent in the tactic; we want to consider time spent evaluating + a tactic expression to a tactic value to be time spent in the + expression, not just time spent in the caller of the expression. + So we need to wrap some nodes in additional profiling calls which + don't count towards to total call count. Whether or not a call + "counts" is indicated by the [count_call] boolean argument. + + Unfortunately, at present, we can get very strange call graphs when + a named tactic expression never runs as a tactic value: if we have + [Ltac t0 := t.] and [Ltac t1 := t0.], then [t1] is considered to + run 0(!) times. It evaluates to [t] during tactic expression + evaluation, and although the call trace records the fact that it + was called by [t0] which was called by [t1], the tactic running + phase never sees this. Thus we get one call tree (from expression + evaluation) that has [t1] calls [t0] calls [t], and another call + tree which says that the caller of [t1] calls [t] directly; the + expression evaluation time goes in the first tree, and the call + count and tactic running time goes in the second tree. Alas, I + suspect that fixing this requires a redesign of how the profiler + hooks into the tactic engine. *) val do_profile : string -> ('a * Tacexpr.ltac_call_kind) list -> - 'b Proofview.tactic -> 'b Proofview.tactic + ?count_call:bool -> 'b Proofview.tactic -> 'b Proofview.tactic val set_profiling : bool -> unit @@ -22,6 +52,10 @@ val print_results_tactic : string -> unit val reset_profile : unit -> unit +val restart_timer : string option -> unit + +val finish_timing : prefix:string -> string option -> unit + val do_print_results_at_close : unit -> unit (* The collected statistics for a tactic. The timing data is collected over all @@ -46,4 +80,3 @@ type treenode = { (* Returns the profiling results known by the current process *) val get_local_profiling_results : unit -> treenode val feedback_results : treenode -> unit - diff --git a/plugins/ltac/profile_ltac_tactics.ml4 b/plugins/ltac/profile_ltac_tactics.ml4 index f095660638..9864ffeb65 100644 --- a/plugins/ltac/profile_ltac_tactics.ml4 +++ b/plugins/ltac/profile_ltac_tactics.ml4 @@ -18,6 +18,21 @@ DECLARE PLUGIN "ltac_plugin" let tclSET_PROFILING b = Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> set_profiling b)) +let tclRESET_PROFILE = + Proofview.tclLIFT (Proofview.NonLogical.make reset_profile) + +let tclSHOW_PROFILE ~cutoff = + Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> print_results ~cutoff)) + +let tclSHOW_PROFILE_TACTIC s = + Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> print_results_tactic s)) + +let tclRESTART_TIMER s = + Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> restart_timer s)) + +let tclFINISH_TIMING ?(prefix="Timer") (s : string option) = + Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> finish_timing ~prefix s)) + TACTIC EXTEND start_ltac_profiling | [ "start" "ltac" "profiling" ] -> [ tclSET_PROFILING true ] END @@ -26,8 +41,27 @@ TACTIC EXTEND stop_ltac_profiling | [ "stop" "ltac" "profiling" ] -> [ tclSET_PROFILING false ] END +TACTIC EXTEND reset_ltac_profile +| [ "reset" "ltac" "profile" ] -> [ tclRESET_PROFILE ] +END + +TACTIC EXTEND show_ltac_profile +| [ "show" "ltac" "profile" ] -> [ tclSHOW_PROFILE ~cutoff:!Flags.profile_ltac_cutoff ] +| [ "show" "ltac" "profile" "cutoff" int(n) ] -> [ tclSHOW_PROFILE ~cutoff:(float_of_int n) ] +| [ "show" "ltac" "profile" string(s) ] -> [ tclSHOW_PROFILE_TACTIC s ] +END + +TACTIC EXTEND restart_timer +| [ "restart_timer" string_opt(s) ] -> [ tclRESTART_TIMER s ] +END + +TACTIC EXTEND finish_timing +| [ "finish_timing" string_opt(s) ] -> [ tclFINISH_TIMING ~prefix:"Timer" s ] +| [ "finish_timing" "(" string(prefix) ")" string_opt(s) ] -> [ tclFINISH_TIMING ~prefix s ] +END + VERNAC COMMAND EXTEND ResetLtacProfiling CLASSIFIED AS SIDEFF - [ "Reset" "Ltac" "Profile" ] -> [ reset_profile() ] + [ "Reset" "Ltac" "Profile" ] -> [ reset_profile () ] END VERNAC COMMAND EXTEND ShowLtacProfile CLASSIFIED AS QUERY diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 2e14243d8a..a698b05dd7 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -1781,7 +1781,9 @@ let declare_an_instance n s args = let declare_instance a aeq n s = declare_an_instance n s [a;aeq] let anew_instance global binders instance fields = - new_instance (Flags.is_universe_polymorphism ()) + let program_mode = Flags.is_program_mode () in + let poly = Flags.is_universe_polymorphism () in + new_instance ~program_mode poly binders instance (Some (true, CAst.make @@ CRecord (fields))) ~global ~generalize:false ~refine:false Hints.empty_hint_info @@ -2012,9 +2014,10 @@ let add_morphism glob binders m s n = [cHole; s; m])) in let tac = Tacinterp.interp (make_tactic "add_morphism_tactic") in - ignore(new_instance ~global:glob poly binders instance - (Some (true, CAst.make @@ CRecord [])) - ~generalize:false ~tac ~hook:(declare_projection n instance_id) Hints.empty_hint_info) + let program_mode = Flags.is_program_mode () in + ignore(new_instance ~program_mode ~global:glob poly binders instance + (Some (true, CAst.make @@ CRecord [])) + ~generalize:false ~tac ~hook:(declare_projection n instance_id) Hints.empty_hint_info) (** Bind to "rewrite" too *) diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index ded902a8fb..ccded44179 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -1158,10 +1158,14 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with Proofview.V82.tactic begin tclSHOWHYPS (Proofview.V82.of_tactic (interp_tactic ist tac)) end - | TacAbstract (tac,ido) -> + | TacAbstract (t,ido) -> + let call = LtacMLCall tac in + push_trace(None,call) ist >>= fun trace -> + Profile_ltac.do_profile "eval_tactic:TacAbstract" trace + (catch_error_tac trace begin Proofview.Goal.enter begin fun gl -> Tactics.tclABSTRACT - (Option.map (interp_ident ist (pf_env gl) (project gl)) ido) (interp_tactic ist tac) - end + (Option.map (interp_ident ist (pf_env gl) (project gl)) ido) (interp_tactic ist t) + end end) | TacThen (t1,t) -> Tacticals.New.tclTHEN (interp_tactic ist t1) (interp_tactic ist t) | TacDispatch tl -> @@ -1272,7 +1276,8 @@ and interp_ltac_reference ?loc' mustbetac ist r : Val.t Ftactic.t = let extra = TacStore.set extra f_trace trace in let ist = { lfun = Id.Map.empty; extra = extra; } in let appl = GlbAppl[r,[]] in - val_interp ~appl ist (Tacenv.interp_ltac r) + Profile_ltac.do_profile "interp_ltac_reference" trace ~count_call:false + (val_interp ~appl ist (Tacenv.interp_ltac r)) and interp_tacarg ist arg : Val.t Ftactic.t = match arg with @@ -1338,7 +1343,8 @@ and interp_app loc ist fv largs : Val.t Ftactic.t = let ist = { lfun = newlfun; extra = TacStore.set ist.extra f_trace []; } in - catch_error_tac trace (val_interp ist body) >>= fun v -> + Profile_ltac.do_profile "interp_app" trace ~count_call:false + (catch_error_tac trace (val_interp ist body)) >>= fun v -> Ftactic.return (name_vfun (push_appl appl largs) v) end begin fun (e, info) -> diff --git a/plugins/micromega/MExtraction.v b/plugins/micromega/MExtraction.v index e5b5854f0a..362cc3a597 100644 --- a/plugins/micromega/MExtraction.v +++ b/plugins/micromega/MExtraction.v @@ -49,16 +49,13 @@ Extract Constant Rmult => "( * )". Extract Constant Ropp => "fun x -> - x". Extract Constant Rinv => "fun x -> 1 / x". -(** We now extract to stdout, see comment in Makefile.build *) - -(*Extraction "plugins/micromega/micromega.ml" *) -Recursive Extraction - List.map simpl_cone (*map_cone indexes*) - denorm Qpower vm_add - n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. - - - +(** In order to avoid annoying build dependencies the actual + extraction is only performed as a test in the test suite. *) +(* Extraction "plugins/micromega/micromega.ml" *) +(* Recursive Extraction *) +(* List.map simpl_cone (*map_cone indexes*) *) +(* denorm Qpower vm_add *) +(* n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. *) (* Local Variables: *) (* coding: utf-8 *) diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index cb88446236..f7a3789a21 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -218,6 +218,8 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) = let t' = EConstr.of_constr t' in let t' = subst_univs_level_constr subst t' in let bs' = List.map (EConstr.of_constr %> subst_univs_level_constr subst) bs in + let params = List.map (fun c -> subst_univs_level_constr subst c) params in + let us = List.map (fun c -> subst_univs_level_constr subst c) us in let h, _ = decompose_app_vect sigma t' in ctx',(h, t2),c',bs',(Stack.append_app_list params Stack.empty,params1), (Stack.append_app_list us Stack.empty,us2),(extra_args1,extra_args2),c1, diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 1ae3577edb..01065868d4 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -249,11 +249,11 @@ let add_inversion_lemma name env sigma t sort dep inv_op = let add_inversion_lemma_exn na com comsort bool tac = let env = Global.env () in - let evd = ref (Evd.from_env env) in - let c = Constrintern.interp_type_evars env evd com in - let evd, sort = Evd.fresh_sort_in_family ~rigid:univ_rigid env !evd comsort in + let sigma = Evd.from_env env in + let sigma, c = Constrintern.interp_type_evars env sigma com in + let sigma, sort = Evd.fresh_sort_in_family ~rigid:univ_rigid env sigma comsort in try - add_inversion_lemma na env evd c sort bool tac + add_inversion_lemma na env sigma c sort bool tac with | UserError (Some "Case analysis",s) -> (* Reference to Indrec *) user_err ~hdr:"Inv needs Nodep Prop Set" s diff --git a/test-suite/Makefile b/test-suite/Makefile index 6865dcc768..de669218ce 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -177,7 +177,7 @@ summary.log: report: summary.log $(HIDE)bash save-logs.sh $(HIDE)if [ -n "${TRAVIS}" ]; then find logs/ -name '*.log' -not -name 'summary.log' -exec 'bash' '-c' 'echo "travis_fold:start:coq.logs.$$(echo '{}' | sed s,/,.,g)"' ';' -exec cat '{}' ';' -exec 'bash' '-c' 'echo "travis_fold:end:coq.logs.$$(echo '{}' | sed s,/,.,g)"' ';'; fi - $(HIDE)if [ -n "${APPVEYOR}" ]; then find logs/ -name '*.log' -not -name 'summary.log' -exec 'bash' '-c' 'echo {}' ';' -exec cat '{}' ';' -exec 'bash' '-c' 'echo' ';'; fi + $(HIDE)if [ "(" -n "${APPVEYOR}" ")" -o "(" -n "${CIRCLECI}" ")" ]; then find logs/ -name '*.log' -not -name 'summary.log' -exec 'bash' '-c' 'echo {}' ';' -exec cat '{}' ';' -exec 'bash' '-c' 'echo' ';'; fi $(HIDE)if grep -q -F 'Error!' summary.log ; then echo FAILURES; grep -F 'Error!' summary.log; false; else echo NO FAILURES; fi ####################################################################### @@ -312,6 +312,13 @@ $(addsuffix .log,$(wildcard output/*.v)): %.v.log: %.v %.out $(PREREQUISITELOG) rm $$tmpoutput; \ } > "$@" +# the expected output for the MExtraction test is +# /plugins/micromega/micromega.ml except with additional newline +output/MExtraction.out: ../plugins/micromega/micromega.ml + $(SHOW) GEN $@ + $(HIDE) cp $< $@ + $(HIDE) echo >> $@ + $(addsuffix .log,$(wildcard output-modulo-time/*.v)): %.v.log: %.v %.out @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ diff --git a/test-suite/bugs/closed/5368.v b/test-suite/bugs/closed/5368.v new file mode 100644 index 0000000000..410fe1707d --- /dev/null +++ b/test-suite/bugs/closed/5368.v @@ -0,0 +1,6 @@ +Set Universe Polymorphism. + +Record cantype := {T:Type; op:T -> unit}. +Canonical Structure test (P:Type) := {| T := P -> Type; op := fun _ => tt|}. + +Check (op _ ((fun (_:unit) => Set):_)). diff --git a/test-suite/bugs/closed/6378.v b/test-suite/bugs/closed/6378.v index d0ef090d08..68ae7961dd 100644 --- a/test-suite/bugs/closed/6378.v +++ b/test-suite/bugs/closed/6378.v @@ -1,4 +1,18 @@ +Require Import Coq.ZArith.ZArith. +Ltac profile_constr tac := + let dummy := match goal with _ => reset ltac profile; start ltac profiling end in + let ret := match goal with _ => tac () end in + let dummy := match goal with _ => stop ltac profiling; show ltac profile end in + pose 1. + +Ltac slow _ := eval vm_compute in (Z.div_eucl, Z.div_eucl, Z.div_eucl, Z.div_eucl, Z.div_eucl). + Goal True. start ltac profiling. + reset ltac profile. + reset ltac profile. stop ltac profiling. + time profile_constr slow. + show ltac profile cutoff 0. + show ltac profile "slow". Abort. diff --git a/test-suite/coq-makefile/timing/after/time-of-build-after.log.desired b/test-suite/coq-makefile/timing/after/time-of-build-after.log.desired index 729de2f366..7900c034da 100644 --- a/test-suite/coq-makefile/timing/after/time-of-build-after.log.desired +++ b/test-suite/coq-makefile/timing/after/time-of-build-after.log.desired @@ -1,7 +1,6 @@ Makefile:69: warning: undefined variable '*' Makefile:204: warning: undefined variable 'DSTROOT' -COQDEP Fast.v -COQDEP Slow.v +COQDEP VFILES Makefile:69: warning: undefined variable '*' Makefile:204: warning: undefined variable 'DSTROOT' Makefile:69: warning: undefined variable '*' diff --git a/test-suite/coq-makefile/timing/after/time-of-build-before.log.desired b/test-suite/coq-makefile/timing/after/time-of-build-before.log.desired index b25bc3683c..7ab0bc75d9 100644 --- a/test-suite/coq-makefile/timing/after/time-of-build-before.log.desired +++ b/test-suite/coq-makefile/timing/after/time-of-build-before.log.desired @@ -1,7 +1,6 @@ Makefile:69: warning: undefined variable '*' Makefile:204: warning: undefined variable 'DSTROOT' -COQDEP Fast.v -COQDEP Slow.v +COQDEP VFILES Makefile:69: warning: undefined variable '*' Makefile:204: warning: undefined variable 'DSTROOT' Makefile:69: warning: undefined variable '*' diff --git a/test-suite/output-modulo-time/ltacprof.out b/test-suite/output-modulo-time/ltacprof.out index cc04c2c9bd..5553e1b38d 100644 --- a/test-suite/output-modulo-time/ltacprof.out +++ b/test-suite/output-modulo-time/ltacprof.out @@ -1,12 +1,15 @@ -total time: 1.528s +total time: 1.032s - tactic local total calls max + tactic local total calls max ────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ -─sleep' -------------------------------- 100.0% 100.0% 1 1.528s +─sleep' -------------------------------- 100.0% 100.0% 1 1.032s +─sleep --------------------------------- 0.0% 0.0% 0 0.000s ─constructor --------------------------- 0.0% 0.0% 1 0.000s - tactic local total calls max + tactic local total calls max ────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ -─sleep' -------------------------------- 100.0% 100.0% 1 1.528s +─sleep' -------------------------------- 100.0% 100.0% 1 1.032s +─sleep --------------------------------- 0.0% 0.0% 0 0.000s +â””sleep' -------------------------------- 0.0% 0.0% 0 0.000s ─constructor --------------------------- 0.0% 0.0% 1 0.000s diff --git a/test-suite/output-modulo-time/ltacprof_abstract.out b/test-suite/output-modulo-time/ltacprof_abstract.out new file mode 100644 index 0000000000..fef4fa248d --- /dev/null +++ b/test-suite/output-modulo-time/ltacprof_abstract.out @@ -0,0 +1,17 @@ +total time: 0.922s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─abstract (sleep; constructor) --------- 0.0% 100.0% 1 0.922s +─sleep' -------------------------------- 100.0% 100.0% 1 0.922s +─constructor --------------------------- 0.0% 0.0% 1 0.000s +─sleep --------------------------------- 0.0% 0.0% 0 0.000s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─abstract (sleep; constructor) --------- 0.0% 100.0% 1 0.922s + ├─sleep' ------------------------------ 100.0% 100.0% 1 0.922s + ├─constructor ------------------------- 0.0% 0.0% 1 0.000s + └─sleep ------------------------------- 0.0% 0.0% 0 0.000s + â””sleep' ------------------------------ 0.0% 0.0% 0 0.000s + diff --git a/test-suite/output-modulo-time/ltacprof_abstract.v b/test-suite/output-modulo-time/ltacprof_abstract.v new file mode 100644 index 0000000000..10a76309e3 --- /dev/null +++ b/test-suite/output-modulo-time/ltacprof_abstract.v @@ -0,0 +1,8 @@ +(* -*- coq-prog-args: ("-profile-ltac-cutoff" "0.0") -*- *) +Ltac sleep' := do 100 (do 100 (do 100 idtac)). +Ltac sleep := sleep'. + +Theorem x : True. +Proof. + idtac. idtac. abstract (sleep; constructor). +Defined. diff --git a/test-suite/output-modulo-time/ltacprof_cutoff.out b/test-suite/output-modulo-time/ltacprof_cutoff.out index 0cd5777ccf..d91a38bb54 100644 --- a/test-suite/output-modulo-time/ltacprof_cutoff.out +++ b/test-suite/output-modulo-time/ltacprof_cutoff.out @@ -1,31 +1,37 @@ -total time: 1.584s +total time: 1.632s tactic local total calls max ────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ -─foo2 ---------------------------------- 0.0% 100.0% 1 1.584s -─sleep --------------------------------- 100.0% 100.0% 3 0.572s -─foo1 ---------------------------------- 0.0% 63.9% 1 1.012s +─sleep --------------------------------- 100.0% 100.0% 3 0.584s +─foo2 ---------------------------------- 0.0% 100.0% 1 1.632s +─foo1 ---------------------------------- 0.0% 64.2% 1 1.048s tactic local total calls max ────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ -─foo2 ---------------------------------- 0.0% 100.0% 1 1.584s -â””foo1 ---------------------------------- 0.0% 63.9% 1 1.012s +─foo2 ---------------------------------- 0.0% 100.0% 1 1.632s +â””foo1 ---------------------------------- 0.0% 64.2% 1 1.048s -total time: 1.584s +total time: 0.520s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─foo2 ---------------------------------- 0.0% 100.0% 1 0.520s +─sleep --------------------------------- 99.2% 99.2% 52 0.016s +─foo1 ---------------------------------- 0.0% 97.7% 1 0.508s +─foo0 ---------------------------------- 0.8% 96.2% 1 0.500s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─foo2 ---------------------------------- 0.0% 100.0% 1 0.520s +â””foo1 ---------------------------------- 0.0% 97.7% 1 0.508s +â””foo0 ---------------------------------- 0.8% 96.2% 1 0.500s +â””sleep --------------------------------- 95.4% 95.4% 50 0.016s + +total time: 0.000s tactic local total calls max ────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ -─sleep --------------------------------- 100.0% 100.0% 3 0.572s -─foo2 ---------------------------------- 0.0% 100.0% 1 1.584s -─foo1 ---------------------------------- 0.0% 63.9% 1 1.012s -─foo0 ---------------------------------- 0.0% 31.3% 1 0.496s tactic local total calls max ────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ -─foo2 ---------------------------------- 0.0% 100.0% 1 1.584s - ├─foo1 -------------------------------- 0.0% 63.9% 1 1.012s - │ ├─sleep ----------------------------- 32.6% 32.6% 1 0.516s - │ └─foo0 ------------------------------ 0.0% 31.3% 1 0.496s - │ â””sleep ----------------------------- 31.3% 31.3% 1 0.496s - └─sleep ------------------------------- 36.1% 36.1% 1 0.572s diff --git a/test-suite/output-modulo-time/ltacprof_cutoff.v b/test-suite/output-modulo-time/ltacprof_cutoff.v index 3dad6271af..ae5d51bae8 100644 --- a/test-suite/output-modulo-time/ltacprof_cutoff.v +++ b/test-suite/output-modulo-time/ltacprof_cutoff.v @@ -1,12 +1,28 @@ (* -*- coq-prog-args: ("-profile-ltac") -*- *) Require Coq.ZArith.BinInt. -Ltac sleep := do 50 (idtac; let sleep := (eval vm_compute in Coq.ZArith.BinInt.Z.div_eucl) in idtac). +Module WithIdTac. + Ltac sleep := do 50 (idtac; let sleep := (eval vm_compute in Coq.ZArith.BinInt.Z.div_eucl) in idtac). -Ltac foo0 := idtac; sleep. -Ltac foo1 := sleep; foo0. -Ltac foo2 := sleep; foo1. -Goal True. - foo2. - Show Ltac Profile CutOff 47. - constructor. -Qed. + Ltac foo0 := idtac; sleep. + Ltac foo1 := sleep; foo0. + Ltac foo2 := sleep; foo1. + Goal True. + foo2. + Show Ltac Profile CutOff 47. + constructor. + Qed. +End WithIdTac. + +Module TestEval. + Ltac sleep := let sleep := (eval vm_compute in Coq.ZArith.BinInt.Z.div_eucl) in idtac. + + Ltac foo0 := idtac; do 50 (idtac; sleep). + Ltac foo1 := sleep; foo0. + Ltac foo2 := sleep; foo1. + Goal True. + Reset Ltac Profile. + foo2. + Show Ltac Profile CutOff 47. + constructor. + Qed. +End TestEval. diff --git a/test-suite/output/MExtraction.v b/test-suite/output/MExtraction.v new file mode 100644 index 0000000000..352e422cf7 --- /dev/null +++ b/test-suite/output/MExtraction.v @@ -0,0 +1,12 @@ +Require Import micromega.MExtraction. +Require Import RingMicromega. +Require Import QArith. +Require Import VarMap. +Require Import ZMicromega. +Require Import QMicromega. +Require Import RMicromega. + +Recursive Extraction + List.map RingMicromega.simpl_cone (*map_cone indexes*) + denorm Qpower vm_add + n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. diff --git a/test-suite/output/bug5778.out b/test-suite/output/bug5778.out new file mode 100644 index 0000000000..91ceb1b583 --- /dev/null +++ b/test-suite/output/bug5778.out @@ -0,0 +1,4 @@ +The command has indeed failed with message: +In nested Ltac calls to "c", "abs" and "abstract b ltac:(())", last call +failed. +The term "I" has type "True" which should be Set, Prop or Type. diff --git a/test-suite/output/bug5778.v b/test-suite/output/bug5778.v new file mode 100644 index 0000000000..0dcd76aeff --- /dev/null +++ b/test-suite/output/bug5778.v @@ -0,0 +1,7 @@ +Ltac a _ := pose (I : I). +Ltac b _ := a (). +Ltac abs _ := abstract b (). +Ltac c _ := abs (). +Goal True. + Fail c (). +Abort. diff --git a/test-suite/success/extraction.v b/test-suite/success/extraction.v index 0ee2232502..83726bfdc5 100644 --- a/test-suite/success/extraction.v +++ b/test-suite/success/extraction.v @@ -635,6 +635,6 @@ Recursive Extraction Everything. Require Import ZArith. -Extraction Language Ocaml. +Extraction Language OCaml. Recursive Extraction Z_modulo_2 Zdiv_eucl_exist. Extraction TestCompile Z_modulo_2 Zdiv_eucl_exist. diff --git a/theories/Init/Tactics.v b/theories/Init/Tactics.v index 5d0e7602a9..47a971ef09 100644 --- a/theories/Init/Tactics.v +++ b/theories/Init/Tactics.v @@ -306,3 +306,10 @@ Ltac inversion_sigma_step := => induction_sigma_in_using H @eq_sigT2_rect end. Ltac inversion_sigma := repeat inversion_sigma_step. + +(** A version of [time] that works for constrs *) +Ltac time_constr tac := + let eval_early := match goal with _ => restart_timer end in + let ret := tac () in + let eval_early := match goal with _ => finish_timing ( "Tactic evaluation" ) end in + ret. diff --git a/tools/CoqMakefile.in b/tools/CoqMakefile.in index 2b56c63a0c..33a2f8593e 100644 --- a/tools/CoqMakefile.in +++ b/tools/CoqMakefile.in @@ -227,8 +227,9 @@ COQTOPINSTALL = $(call concat_path,$(DESTDIR),$(COQLIB)toploop) # We here define a bunch of variables about the files being part of the # Coq project in order to ease the writing of build target and build rules +VDFILE := .coqdeps + ALLSRCFILES := \ - $(VFILES) \ $(ML4FILES) \ $(MLFILES) \ $(MLPACKFILES) \ @@ -308,7 +309,7 @@ else DO_NATDYNLINK = endif -ALLDFILES = $(addsuffix .d,$(ALLSRCFILES)) +ALLDFILES = $(addsuffix .d,$(ALLSRCFILES) $(VDFILE)) # Compilation targets ######################################################### @@ -713,9 +714,9 @@ $(addsuffix .d,$(MLPACKFILES)): %.mlpack.d: %.mlpack $(SHOW)'COQDEP $<' $(HIDE)$(COQDEP) $(OCAMLLIBS) -c "$<" $(redir_if_ok) -$(addsuffix .d,$(VFILES)): %.v.d: %.v - $(SHOW)'COQDEP $<' - $(HIDE)$(COQDEP) $(COQLIBS) -dyndep var -c "$<" $(redir_if_ok) +$(VDFILE).d: $(VFILES) + $(SHOW)'COQDEP VFILES' + $(HIDE)$(COQDEP) $(COQLIBS) -dyndep var -c $(VFILES) $(redir_if_ok) # Misc ######################################################################## diff --git a/vernac/classes.ml b/vernac/classes.ml index fd43c60410..c2e9a5ab44 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -82,18 +82,18 @@ let mismatched_props env n m = mismatched_ctx_inst env Properties n m let type_ctx_instance env sigma ctx inst subst = let open Vars in - let rec aux (subst, instctx) l = function + let rec aux (sigma, subst, instctx) l = function decl :: ctx -> let t' = substl subst (RelDecl.get_type decl) in - let c', l = + let (sigma, c'), l = match decl with | LocalAssum _ -> interp_casted_constr_evars env sigma (List.hd l) t', List.tl l - | LocalDef (_,b,_) -> substl subst b, l + | LocalDef (_,b,_) -> (sigma, substl subst b), l in let d = RelDecl.get_name decl, Some c', t' in - aux (c' :: subst, d :: instctx) l ctx - | [] -> subst - in aux (subst, []) inst (List.rev ctx) + aux (sigma, c' :: subst, d :: instctx) l ctx + | [] -> sigma, subst + in aux (sigma, subst, []) inst (List.rev ctx) let id_of_class cl = match cl.cl_impl with @@ -130,7 +130,7 @@ let declare_instance_constant k info global imps ?hook id decl poly sigma term t id let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) - poly ctx (instid, bk, cl) props ?(generalize=true) + ~program_mode poly ctx (instid, bk, cl) props ?(generalize=true) ?(tac:unit Proofview.tactic option) ?hook pri = let env = Global.env() in let ((loc, instid), pl) = instid in @@ -153,10 +153,8 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) else tclass in let sigma, k, u, cty, ctx', ctx, len, imps, subst = - let _evd = ref sigma in - let impls, ((env', ctx), imps) = interp_context_evars env _evd ctx in - let c', imps' = interp_type_evars_impls ~impls env' _evd tclass in - let sigma = !_evd in + let sigma, (impls, ((env', ctx), imps)) = interp_context_evars env sigma ctx in + let sigma, (c', imps') = interp_type_evars_impls ~impls env' sigma tclass in let len = List.length ctx in let imps = imps @ Impargs.lift_implicits len imps' in let ctx', c = decompose_prod_assum sigma c' in @@ -217,7 +215,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) Some (Inl fs) | Some (_, t) -> Some (Inr t) | None -> - if Flags.is_program_mode () then Some (Inl []) + if program_mode then Some (Inl []) else None in let subst, sigma = @@ -225,9 +223,8 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) | None -> (if List.is_empty k.cl_props then Some (Inl subst) else None), sigma | Some (Inr term) -> - let _evd = ref sigma in - let c = interp_casted_constr_evars env' _evd term cty in - Some (Inr (c, subst)), !_evd + let sigma, c = interp_casted_constr_evars env' sigma term cty in + Some (Inr (c, subst)), sigma | Some (Inl props) -> let get_id = function @@ -265,9 +262,8 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) unbound_method env' k.cl_impl (get_id n) | _ -> let kcl_props = List.map (Termops.map_rel_decl of_constr) k.cl_props in - let _evd = ref sigma in - let r_term = type_ctx_instance (push_rel_context ctx' env') _evd kcl_props props subst in - Some (Inl r_term), !_evd + let sigma, res = type_ctx_instance (push_rel_context ctx' env') sigma kcl_props props subst in + Some (Inl res), sigma in let term, termtype = match subst with @@ -301,9 +297,9 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) if not (Evd.has_undefined sigma) && not (Option.is_empty term) then declare_instance_constant k pri global imps ?hook id decl poly sigma (Option.get term) termtype - else if Flags.is_program_mode () || refine || Option.is_empty term then begin + else if program_mode || refine || Option.is_empty term then begin let kind = Decl_kinds.Global, poly, Decl_kinds.DefinitionBody Decl_kinds.Instance in - if Flags.is_program_mode () then + if program_mode then let hook vis gr _ = let cst = match gr with ConstRef kn -> kn | _ -> assert false in Impargs.declare_manual_implicits false gr ~enriching:false [imps]; @@ -367,9 +363,7 @@ let named_of_rel_context l = let context poly l = let env = Global.env() in let sigma = Evd.from_env env in - let _evd = ref sigma in - let _, ((env', fullctx), impls) = interp_context_evars env _evd l in - let sigma = !_evd in + let sigma, (_, ((env', fullctx), impls)) = interp_context_evars env sigma l in (* Note, we must use the normalized evar from now on! *) let sigma,_ = Evarutil.nf_evars_and_universes sigma in let ce t = Pretyping.check_evars env Evd.empty sigma t in @@ -417,7 +411,7 @@ let context poly l = in let nstatus = match b with | None -> - pi3 (Command.declare_assumption false decl (t, univs) Universes.empty_binders [] impl + pi3 (ComAssumption.declare_assumption false decl (t, univs) Universes.empty_binders [] impl Vernacexpr.NoInline (Loc.tag id)) | Some b -> let decl = (Discharge, poly, Definition) in diff --git a/vernac/classes.mli b/vernac/classes.mli index c0f03227c4..d47c6a6f81 100644 --- a/vernac/classes.mli +++ b/vernac/classes.mli @@ -41,6 +41,7 @@ val new_instance : ?abstract:bool -> (** Not abstract by default. *) ?global:bool -> (** Not global by default. *) ?refine:bool -> (** Allow refinement *) + program_mode:bool -> Decl_kinds.polymorphic -> local_binder_expr list -> Vernacexpr.typeclass_constraint -> diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml new file mode 100644 index 0000000000..5d7adb24a5 --- /dev/null +++ b/vernac/comAssumption.ml @@ -0,0 +1,182 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Pp +open CErrors +open Util +open Vars +open Environ +open Declare +open Names +open Globnames +open Constrexpr_ops +open Constrintern +open Impargs +open Decl_kinds +open Pretyping +open Vernacexpr +open Entries + +(* 2| Variable/Hypothesis/Parameter/Axiom declarations *) + +let axiom_into_instance = ref false + +let _ = + let open Goptions in + declare_bool_option + { optdepr = false; + optname = "automatically declare axioms whose type is a typeclass as instances"; + optkey = ["Typeclasses";"Axioms";"Are";"Instances"]; + optread = (fun _ -> !axiom_into_instance); + optwrite = (:=) axiom_into_instance; } + +let should_axiom_into_instance = function + | Discharge -> + (* The typeclass behaviour of Variable and Context doesn't depend + on section status *) + true + | Global | Local -> !axiom_into_instance + +let declare_assumption is_coe (local,p,kind) (c,ctx) pl imps impl nl (_,ident) = +match local with +| Discharge when Lib.sections_are_opened () -> + let ctx = match ctx with + | Monomorphic_const_entry ctx -> ctx + | Polymorphic_const_entry ctx -> Univ.ContextSet.of_context ctx + in + let decl = (Lib.cwd(), SectionLocalAssum ((c,ctx),p,impl), IsAssumption kind) in + let _ = declare_variable ident decl in + let () = assumption_message ident in + let () = + if not !Flags.quiet && Proof_global.there_are_pending_proofs () then + Feedback.msg_info (str"Variable" ++ spc () ++ Id.print ident ++ + strbrk " is not visible from current goals") + in + let r = VarRef ident in + let () = Typeclasses.declare_instance None true r in + let () = if is_coe then Class.try_add_new_coercion r ~local:true false in + (r,Univ.Instance.empty,true) + +| Global | Local | Discharge -> + let do_instance = should_axiom_into_instance local in + let local = DeclareDef.get_locality ident ~kind:"axiom" local in + let inl = match nl with + | NoInline -> None + | DefaultInline -> Some (Flags.get_inline_level()) + | InlineAt i -> Some i + in + let decl = (ParameterEntry (None,(c,ctx),inl), IsAssumption kind) in + let kn = declare_constant ident ~local decl in + let gr = ConstRef kn in + let () = maybe_declare_manual_implicits false gr imps in + let () = Declare.declare_univ_binders gr pl in + let () = assumption_message ident in + let () = if do_instance then Typeclasses.declare_instance None false gr in + let () = if is_coe then Class.try_add_new_coercion gr ~local p in + let inst = match ctx with + | Polymorphic_const_entry ctx -> Univ.UContext.instance ctx + | Monomorphic_const_entry _ -> Univ.Instance.empty + in + (gr,inst,Lib.is_modtype_strict ()) + +let interp_assumption sigma env impls bl c = + let c = mkCProdN ?loc:(local_binders_loc bl) bl c in + let sigma, (ty, impls) = interp_type_evars_impls env sigma ~impls c in + let ty = EConstr.Unsafe.to_constr ty in + sigma, (ty, impls) + +(* When monomorphic the universe constraints are declared with the first declaration only. *) +let next_uctx = + let empty_uctx = Monomorphic_const_entry Univ.ContextSet.empty in + function + | Polymorphic_const_entry _ as uctx -> uctx + | Monomorphic_const_entry _ -> empty_uctx + +let declare_assumptions idl is_coe k (c,uctx) pl imps nl = + let refs, status, _ = + List.fold_left (fun (refs,status,uctx) id -> + let ref',u',status' = + declare_assumption is_coe k (c,uctx) pl imps false nl id in + (ref',u')::refs, status' && status, next_uctx uctx) + ([],true,uctx) idl + in + List.rev refs, status + + +let maybe_error_many_udecls = function + | ((loc,id), Some _) -> + user_err ?loc ~hdr:"many_universe_declarations" + Pp.(str "When declaring multiple axioms in one command, " ++ + str "only the first is allowed a universe binder " ++ + str "(which will be shared by the whole block).") + | (_, None) -> () + +let process_assumptions_udecls kind l = + let udecl, first_id = match l with + | (coe, ((id, udecl)::rest, c))::rest' -> + List.iter maybe_error_many_udecls rest; + List.iter (fun (coe, (idl, c)) -> List.iter maybe_error_many_udecls idl) rest'; + udecl, id + | (_, ([], _))::_ | [] -> assert false + in + let () = match kind, udecl with + | (Discharge, _, _), Some _ when Lib.sections_are_opened () -> + let loc = fst first_id in + let msg = Pp.str "Section variables cannot be polymorphic." in + user_err ?loc msg + | _ -> () + in + udecl, List.map (fun (coe, (idl, c)) -> coe, (List.map fst idl, c)) l + +let do_assumptions kind nl l = + let open Context.Named.Declaration in + let env = Global.env () in + let udecl, l = process_assumptions_udecls kind l in + let sigma, udecl = Univdecls.interp_univ_decl_opt env udecl in + let l = + if pi2 kind (* poly *) then + (* Separate declarations so that A B : Type puts A and B in different levels. *) + List.fold_right (fun (is_coe,(idl,c)) acc -> + List.fold_right (fun id acc -> + (is_coe, ([id], c)) :: acc) idl acc) + l [] + else l + in + (* We intepret all declarations in the same evar_map, i.e. as a telescope. *) + let (sigma,_,_),l = List.fold_left_map (fun (sigma,env,ienv) (is_coe,(idl,c)) -> + let sigma,(t,imps) = interp_assumption sigma env ienv [] c in + let env = + push_named_context (List.map (fun (_,id) -> LocalAssum (id,t)) idl) env in + let ienv = List.fold_right (fun (_,id) ienv -> + let impls = compute_internalization_data env Variable t imps in + Id.Map.add id impls ienv) idl ienv in + ((sigma,env,ienv),((is_coe,idl),t,imps))) + (sigma,env,empty_internalization_env) 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 nf_evar c = EConstr.to_constr sigma (EConstr.of_constr c) in + let uvars, l = List.fold_left_map (fun uvars (coe,t,imps) -> + let t = nf_evar t in + let uvars = Univ.LSet.union uvars (Univops.universes_of_constr env t) in + uvars, (coe,t,imps)) + Univ.LSet.empty l + in + let sigma = Evd.restrict_universe_context sigma uvars in + let uctx = Evd.check_univ_decl ~poly:(pi2 kind) sigma udecl in + let ubinders = Evd.universe_binders sigma in + pi2 (List.fold_left (fun (subst,status,uctx) ((is_coe,idl),t,imps) -> + let t = replace_vars subst t in + let refs, status' = declare_assumptions idl is_coe kind (t,uctx) ubinders imps nl in + let subst' = List.map2 + (fun (_,id) (c,u) -> (id, Universes.constr_of_global_univ (c,u))) + idl refs + in + subst'@subst, status' && status, next_uctx uctx) + ([], true, uctx) l) diff --git a/vernac/comAssumption.mli b/vernac/comAssumption.mli new file mode 100644 index 0000000000..2fa156abd8 --- /dev/null +++ b/vernac/comAssumption.mli @@ -0,0 +1,34 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open Constr +open Entries +open Globnames +open Vernacexpr +open Constrexpr +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 + +(************************************************************************) +(** Internal API *) +(************************************************************************) + +(** Exported for Classes *) + +(** returns [false] if the assumption is neither local to a section, + nor in a module type and meant to be instantiated. *) +val declare_assumption : coercion_flag -> assumption_kind -> + types in_constant_universes_entry -> + Universes.universe_binders -> Impargs.manual_implicits -> + bool (** implicit *) -> Vernacexpr.inline -> variable Loc.located -> + global_reference * Univ.Instance.t * bool diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml new file mode 100644 index 0000000000..883121479f --- /dev/null +++ b/vernac/comDefinition.ml @@ -0,0 +1,131 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2018 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Pp +open Util +open Constr +open Environ +open Entries +open Termops +open Redexpr +open Declare +open Constrintern +open Pretyping + +open Context.Rel.Declaration + +(* Commands of the interface: Constant definitions *) + +let rec under_binders env sigma f n c = + if Int.equal n 0 then f env sigma (EConstr.of_constr c) else + match Constr.kind c with + | Lambda (x,t,c) -> + mkLambda (x,t,under_binders (push_rel (LocalAssum (x,t)) env) sigma f (n-1) c) + | LetIn (x,b,t,c) -> + mkLetIn (x,b,t,under_binders (push_rel (LocalDef (x,b,t)) env) sigma f (n-1) c) + | _ -> assert false + +let red_constant_entry n ce sigma = function + | None -> ce + | Some red -> + let proof_out = ce.const_entry_body in + let env = Global.env () in + let (redfun, _) = reduction_of_red_expr env red in + let redfun env sigma c = + let (_, c) = redfun env sigma c in + EConstr.Unsafe.to_constr c + in + { ce with const_entry_body = Future.chain proof_out + (fun ((body,ctx),eff) -> (under_binders env sigma redfun n body,ctx),eff) } + +let warn_implicits_in_term = + CWarnings.create ~name:"implicits-in-term" ~category:"implicits" + (fun () -> + strbrk "Implicit arguments declaration relies on type." ++ spc () ++ + strbrk "The term declares more implicits than the type here.") + +let interp_definition pl bl poly red_option c ctypopt = + let env = Global.env() in + let evd, decl = Univdecls.interp_univ_decl_opt env pl in + let evd, (impls, ((env_bl, ctx), imps1)) = interp_context_evars env evd bl in + let ctx = List.map (fun d -> map_rel_decl EConstr.Unsafe.to_constr d) ctx in + let nb_args = Context.Rel.nhyps ctx in + let evd,imps,ce = + match ctypopt with + None -> + let evd, subst = Evd.nf_univ_variables evd in + let ctx = Context.Rel.map (Vars.subst_univs_constr subst) ctx in + let env_bl = push_rel_context ctx env in + let evd, (c, imps2) = interp_constr_evars_impls ~impls env_bl evd c in + let c = EConstr.Unsafe.to_constr c in + let evd,nf = Evarutil.nf_evars_and_universes evd in + let body = nf (it_mkLambda_or_LetIn c ctx) in + let vars = EConstr.universes_of_constr env evd (EConstr.of_constr body) in + let evd = Evd.restrict_universe_context evd vars in + let uctx = Evd.check_univ_decl ~poly evd decl in + evd, imps1@(Impargs.lift_implicits nb_args imps2), + definition_entry ~univs:uctx body + | Some ctyp -> + let evd, (ty, impsty) = interp_type_evars_impls ~impls env_bl evd ctyp in + let evd, subst = Evd.nf_univ_variables evd in + let ctx = Context.Rel.map (Vars.subst_univs_constr subst) ctx in + let env_bl = push_rel_context ctx env in + let evd, (c, imps2) = interp_casted_constr_evars_impls ~impls env_bl evd c ty in + let c = EConstr.Unsafe.to_constr c in + let evd, nf = Evarutil.nf_evars_and_universes evd in + let body = nf (it_mkLambda_or_LetIn c ctx) in + let ty = EConstr.Unsafe.to_constr ty in + let typ = nf (Term.it_mkProd_or_LetIn ty ctx) in + let beq b1 b2 = if b1 then b2 else not b2 in + let impl_eq (x,y,z) (x',y',z') = beq x x' && beq y y' && beq z z' in + (* Check that all implicit arguments inferable from the term + are inferable from the type *) + let chk (key,va) = + impl_eq (List.assoc_f Pervasives.(=) key impsty) va (* FIXME *) + in + if not (try List.for_all chk imps2 with Not_found -> false) + then warn_implicits_in_term (); + let bodyvars = EConstr.universes_of_constr env evd (EConstr.of_constr body) in + let tyvars = EConstr.universes_of_constr env evd (EConstr.of_constr ty) in + let vars = Univ.LSet.union bodyvars tyvars in + let evd = Evd.restrict_universe_context evd vars in + let uctx = Evd.check_univ_decl ~poly evd decl in + evd, imps1@(Impargs.lift_implicits nb_args impsty), + definition_entry ~types:typ ~univs:uctx body + in + (red_constant_entry (Context.Rel.length ctx) ce evd red_option, evd, decl, imps) + +let check_definition (ce, evd, _, imps) = + check_evars_are_solved (Global.env ()) evd Evd.empty; + ce + +let do_definition ~program_mode ident k univdecl bl red_option c ctypopt hook = + let (ce, evd, univdecl, imps as def) = + interp_definition univdecl bl (pi2 k) red_option c ctypopt + in + if program_mode then + let env = Global.env () in + let (c,ctx), sideff = Future.force ce.const_entry_body in + assert(Safe_typing.empty_private_constants = sideff); + assert(Univ.ContextSet.is_empty ctx); + let typ = match ce.const_entry_type with + | Some t -> t + | None -> EConstr.to_constr evd (Retyping.get_type_of env evd (EConstr.of_constr c)) + in + Obligations.check_evars env evd; + let obls, _, c, cty = + Obligations.eterm_obligations env ident evd 0 c typ + in + let ctx = Evd.evar_universe_context evd in + let hook = Lemmas.mk_hook (fun l r _ -> Lemmas.call_hook (fun exn -> exn) hook l r) in + ignore(Obligations.add_definition + ident ~term:c cty ctx ~univdecl ~implicits:imps ~kind:k ~hook obls) + else let ce = check_definition def in + ignore(DeclareDef.declare_definition ident k ce (Evd.universe_binders evd) imps + (Lemmas.mk_hook + (fun l r -> Lemmas.call_hook (fun exn -> exn) hook l r;r))) diff --git a/vernac/comDefinition.mli b/vernac/comDefinition.mli new file mode 100644 index 0000000000..4a65c1e915 --- /dev/null +++ b/vernac/comDefinition.mli @@ -0,0 +1,30 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2018 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open Entries +open Decl_kinds +open Redexpr +open Constrexpr + +(** {6 Definitions/Let} *) + +val do_definition : program_mode:bool -> + Id.t -> definition_kind -> Vernacexpr.universe_decl_expr option -> + local_binder_expr list -> red_expr option -> constr_expr -> + constr_expr option -> unit Lemmas.declaration_hook -> unit + +(************************************************************************) +(** Internal API *) +(************************************************************************) + +(** Not used anywhere. *) +val interp_definition : + Vernacexpr.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 new file mode 100644 index 0000000000..d648e293aa --- /dev/null +++ b/vernac/comFixpoint.ml @@ -0,0 +1,356 @@ +open Pp +open CErrors +open Util +open Constr +open Vars +open Termops +open Declare +open Names +open Constrexpr +open Constrexpr_ops +open Constrintern +open Decl_kinds +open Pretyping +open Evarutil +open Evarconv +open Misctypes +open Vernacexpr + +module RelDecl = Context.Rel.Declaration + +(* 3c| Fixpoints and co-fixpoints *) + +(* An (unoptimized) function that maps preorders to partial orders... + + Input: a list of associations (x,[y1;...;yn]), all yi distincts + and different of x, meaning x<=y1, ..., x<=yn + + Output: a list of associations (x,Inr [y1;...;yn]), collecting all + distincts yi greater than x, _or_, (x, Inl y) meaning that + x is in the same class as y (in which case, x occurs + nowhere else in the association map) + + partial_order : ('a * 'a list) list -> ('a * ('a,'a list) union) list +*) + +let rec partial_order cmp = function + | [] -> [] + | (x,xge)::rest -> + let rec browse res xge' = function + | [] -> + let res = List.map (function + | (z, Inr zge) when List.mem_f cmp x zge -> + (z, Inr (List.union cmp zge xge')) + | r -> r) res in + (x,Inr xge')::res + | y::xge -> + let rec link y = + try match List.assoc_f cmp y res with + | Inl z -> link z + | Inr yge -> + if List.mem_f cmp x yge then + let res = List.remove_assoc_f cmp y res in + let res = List.map (function + | (z, Inl t) -> + if cmp t y then (z, Inl x) else (z, Inl t) + | (z, Inr zge) -> + if List.mem_f cmp y zge then + (z, Inr (List.add_set cmp x (List.remove cmp y zge))) + else + (z, Inr zge)) res in + browse ((y,Inl x)::res) xge' (List.union cmp xge (List.remove cmp x yge)) + else + browse res (List.add_set cmp y (List.union cmp xge' yge)) xge + with Not_found -> browse res (List.add_set cmp y xge') xge + in link y + in browse (partial_order cmp rest) [] xge + +let non_full_mutual_message x xge y yge isfix rest = + let reason = + if Id.List.mem x yge then + Id.print y ++ str " depends on " ++ Id.print x ++ strbrk " but not conversely" + else if Id.List.mem y xge then + Id.print x ++ str " depends on " ++ Id.print y ++ strbrk " but not conversely" + else + Id.print y ++ str " and " ++ Id.print x ++ strbrk " are not mutually dependent" in + let e = if List.is_empty rest then reason else strbrk "e.g., " ++ reason in + let k = if isfix then "fixpoint" else "cofixpoint" in + let w = + if isfix + then strbrk "Well-foundedness check may fail unexpectedly." ++ fnl() + else mt () in + strbrk "Not a fully mutually defined " ++ str k ++ fnl () ++ + str "(" ++ e ++ str ")." ++ fnl () ++ w + +let warn_non_full_mutual = + CWarnings.create ~name:"non-full-mutual" ~category:"fixpoints" + (fun (x,xge,y,yge,isfix,rest) -> + non_full_mutual_message x xge y yge isfix rest) + +let check_mutuality env evd isfix fixl = + let names = List.map fst fixl in + let preorder = + List.map (fun (id,def) -> + (id, List.filter (fun id' -> not (Id.equal id id') && occur_var env evd id' (EConstr.of_constr def)) names)) + fixl in + let po = partial_order Id.equal preorder in + match List.filter (function (_,Inr _) -> true | _ -> false) po with + | (x,Inr xge)::(y,Inr yge)::rest -> + warn_non_full_mutual (x,xge,y,yge,isfix,rest) + | _ -> () + +type structured_fixpoint_expr = { + fix_name : Id.t; + fix_univs : universe_decl_expr option; + fix_annot : Id.t Loc.located option; + fix_binders : local_binder_expr list; + fix_body : constr_expr option; + fix_type : constr_expr +} + +let interp_fix_context ~cofix env sigma fix = + let before, after = if not cofix then split_at_annot fix.fix_binders fix.fix_annot else [], fix.fix_binders in + let sigma, (impl_env, ((env', ctx), imps)) = interp_context_evars env sigma before in + let sigma, (impl_env', ((env'', ctx'), imps')) = interp_context_evars ~impl_env ~shift:(Context.Rel.nhyps ctx) env' sigma after in + let annot = Option.map (fun _ -> List.length (assums_of_rel_context ctx)) fix.fix_annot in + sigma, ((env'', ctx' @ ctx), (impl_env',imps @ imps'), annot) + +let interp_fix_ccl sigma impls (env,_) fix = + interp_type_evars_impls ~impls env sigma fix.fix_type + +let interp_fix_body env_rec sigma impls (_,ctx) fix ccl = + let open EConstr in + Option.cata (fun body -> + let env = push_rel_context ctx env_rec in + let sigma, body = interp_casted_constr_evars env sigma ~impls body ccl in + sigma, Some (it_mkLambda_or_LetIn body ctx)) (sigma, None) fix.fix_body + +let build_fix_type (_,ctx) ccl = EConstr.it_mkProd_or_LetIn ccl ctx + +let prepare_recursive_declaration fixnames fixtypes fixdefs = + let defs = List.map (subst_vars (List.rev fixnames)) fixdefs in + let names = List.map (fun id -> Name id) fixnames in + (Array.of_list names, Array.of_list fixtypes, Array.of_list defs) + +(* Jump over let-bindings. *) + +let compute_possible_guardness_evidences (ctx,_,recindex) = + (* A recursive index is characterized by the number of lambdas to + skip before finding the relevant inductive argument *) + match recindex with + | Some i -> [i] + | None -> + (* If recursive argument was not given by user, we try all args. + An earlier approach was to look only for inductive arguments, + but doing it properly involves delta-reduction, and it finally + doesn't seem to worth the effort (except for huge mutual + fixpoints ?) *) + List.interval 0 (Context.Rel.nhyps ctx - 1) + +type recursive_preentry = + Id.t list * constr option list * types list + +(* Wellfounded definition *) + +let contrib_name = "Program" +let subtac_dir = [contrib_name] +let tactics_module = subtac_dir @ ["Tactics"] + +let init_constant dir s sigma = + Evarutil.new_global sigma (Coqlib.coq_reference "Command" dir s) + +let fix_proto = init_constant tactics_module "fix_proto" + +let interp_recursive ~program_mode ~cofix fixl notations = + let open Context.Named.Declaration in + let open EConstr in + let env = Global.env() in + let fixnames = List.map (fun fix -> fix.fix_name) fixl in + + (* Interp arities allowing for unresolved types *) + let all_universes = + List.fold_right (fun sfe acc -> + match sfe.fix_univs , acc with + | None , acc -> acc + | x , None -> x + | Some ls , Some us -> + let lsu = ls.univdecl_instance and usu = us.univdecl_instance in + if not (CList.for_all2eq (fun x y -> Id.equal (snd x) (snd y)) lsu usu) then + user_err Pp.(str "(co)-recursive definitions should all have the same universe binders"); + Some us) fixl None in + let sigma, decl = Univdecls.interp_univ_decl_opt env all_universes in + let sigma, (fixctxs, fiximppairs, fixannots) = + on_snd List.split3 @@ + List.fold_left_map (fun sigma -> interp_fix_context env sigma ~cofix) sigma fixl in + let fixctximpenvs, fixctximps = List.split fiximppairs in + let sigma, (fixccls,fixcclimps) = + on_snd List.split @@ + List.fold_left3_map interp_fix_ccl sigma fixctximpenvs fixctxs fixl in + let fixtypes = List.map2 build_fix_type fixctxs fixccls in + let fixtypes = List.map (fun c -> nf_evar sigma c) fixtypes in + let fiximps = List.map3 + (fun ctximps cclimps (_,ctx) -> ctximps@(Impargs.lift_implicits (Context.Rel.nhyps ctx) cclimps)) + fixctximps fixcclimps fixctxs in + let sigma, rec_sign = + List.fold_left2 + (fun (sigma, env') id t -> + if program_mode then + let sigma, sort = Typing.type_of ~refresh:true env sigma t in + let sigma, fixprot = + try + let sigma, h_term = fix_proto sigma in + let app = mkApp (h_term, [|sort; t|]) in + let _evd = ref sigma in + let res = Typing.e_solve_evars env _evd app in + !_evd, res + with e when CErrors.noncritical e -> sigma, t + in + sigma, LocalAssum (id,fixprot) :: env' + else sigma, LocalAssum (id,t) :: env') + (sigma,[]) fixnames fixtypes + in + let env_rec = push_named_context rec_sign env in + + (* Get interpretation metadatas *) + let fixtypes = List.map EConstr.Unsafe.to_constr fixtypes in + let impls = compute_internalization_env env Recursive fixnames fixtypes fiximps in + + (* Interp bodies with rollback because temp use of notations/implicit *) + let sigma, fixdefs = + Metasyntax.with_syntax_protection (fun () -> + List.iter (Metasyntax.set_notation_for_interpretation env_rec impls) notations; + List.fold_left4_map + (fun sigma fixctximpenv -> interp_fix_body env_rec sigma (Id.Map.fold Id.Map.add fixctximpenv impls)) + sigma fixctximpenvs fixctxs fixl fixccls) + () in + + (* Instantiate evars and check all are resolved *) + let sigma = solve_unif_constraints_with_heuristics env_rec sigma in + let sigma, nf = nf_evars_and_universes sigma in + let fixdefs = List.map (fun c -> Option.map EConstr.Unsafe.to_constr c) fixdefs in + let fixdefs = List.map (Option.map nf) fixdefs in + let fixtypes = List.map nf fixtypes in + let fixctxs = List.map (fun (_,ctx) -> ctx) fixctxs in + + (* Build the fix declaration block *) + (env,rec_sign,decl,sigma), (fixnames,fixdefs,fixtypes), List.combine3 fixctxs fiximps fixannots + +let check_recursive isfix env evd (fixnames,fixdefs,_) = + check_evars_are_solved env evd Evd.empty; + if List.for_all Option.has_some fixdefs then begin + let fixdefs = List.map Option.get fixdefs in + check_mutuality env evd isfix (List.combine fixnames fixdefs) + end + +let interp_fixpoint ~cofix l ntns = + let (env,_,pl,evd),fix,info = interp_recursive ~program_mode:false ~cofix l ntns in + check_recursive true env evd fix; + (fix,pl,Evd.evar_universe_context evd,info) + +let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) indexes ntns = + if List.exists Option.is_empty fixdefs then + (* Some bodies to define by proof *) + let thms = + List.map3 (fun id t (ctx,imps,_) -> (id,(EConstr.of_constr t,(List.map RelDecl.get_name ctx,imps)))) + fixnames fixtypes fiximps in + let init_tac = + Some (List.map (Option.cata (EConstr.of_constr %> Tactics.exact_no_check) Tacticals.New.tclIDTAC) + fixdefs) in + let evd = Evd.from_ctx ctx in + Lemmas.start_proof_with_initialization (Global,poly,DefinitionBody Fixpoint) + evd pl (Some(false,indexes,init_tac)) thms None (Lemmas.mk_hook (fun _ _ -> ())) + else begin + (* We shortcut the proof process *) + let fixdefs = List.map Option.get fixdefs in + let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in + let env = Global.env() in + let indexes = search_guard env indexes fixdecls in + let fiximps = List.map (fun (n,r,p) -> r) fiximps in + let vars = Univops.universes_of_constr env (mkFix ((indexes,0),fixdecls)) in + let fixdecls = + List.map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 fixnames in + let evd = Evd.from_ctx ctx in + let evd = Evd.restrict_universe_context evd vars in + let ctx = Evd.check_univ_decl ~poly evd pl in + let pl = Evd.universe_binders evd in + let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in + ignore (List.map4 (DeclareDef.declare_fix (local, poly, Fixpoint) pl ctx) + fixnames fixdecls fixtypes fiximps); + (* Declare the recursive definitions *) + fixpoint_message (Some indexes) fixnames; + end; + (* Declare notations *) + List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns + +let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) ntns = + if List.exists Option.is_empty fixdefs then + (* Some bodies to define by proof *) + let thms = + List.map3 (fun id t (ctx,imps,_) -> (id,(EConstr.of_constr t,(List.map RelDecl.get_name ctx,imps)))) + fixnames fixtypes fiximps in + let init_tac = + Some (List.map (Option.cata (EConstr.of_constr %> Tactics.exact_no_check) Tacticals.New.tclIDTAC) + fixdefs) in + let evd = Evd.from_ctx ctx in + Lemmas.start_proof_with_initialization (Global,poly, DefinitionBody CoFixpoint) + evd pl (Some(true,[],init_tac)) thms None (Lemmas.mk_hook (fun _ _ -> ())) + else begin + (* We shortcut the proof process *) + let fixdefs = List.map Option.get fixdefs in + let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in + let fixdecls = List.map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 fixnames in + let env = Global.env () in + let vars = Univops.universes_of_constr env (List.hd fixdecls) in + let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in + let fiximps = List.map (fun (len,imps,idx) -> imps) fiximps in + let evd = Evd.from_ctx ctx in + let evd = Evd.restrict_universe_context evd vars in + let ctx = Evd.check_univ_decl ~poly evd pl in + let pl = Evd.universe_binders evd in + ignore (List.map4 (DeclareDef.declare_fix (local, poly, CoFixpoint) pl ctx) + fixnames fixdecls fixtypes fiximps); + (* Declare the recursive definitions *) + cofixpoint_message fixnames + end; + (* Declare notations *) + List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns + +let extract_decreasing_argument limit = function + | (na,CStructRec) -> na + | (na,_) when not limit -> na + | _ -> user_err Pp.(str + "Only structural decreasing is supported for a non-Program Fixpoint") + +let extract_fixpoint_components limit l = + let fixl, ntnl = List.split l in + let fixl = List.map (fun (((_,id),pl),ann,bl,typ,def) -> + let ann = extract_decreasing_argument limit ann in + {fix_name = id; fix_annot = ann; fix_univs = pl; + fix_binders = bl; fix_body = def; fix_type = typ}) fixl in + fixl, List.flatten ntnl + +let extract_cofixpoint_components l = + let fixl, ntnl = List.split l in + List.map (fun (((_,id),pl),bl,typ,def) -> + {fix_name = id; fix_annot = None; fix_univs = pl; + fix_binders = bl; fix_body = def; fix_type = typ}) fixl, + List.flatten ntnl + +let check_safe () = + let open Declarations in + let flags = Environ.typing_flags (Global.env ()) in + flags.check_universes && flags.check_guarded + +let do_fixpoint local poly l = + let fixl, ntns = extract_fixpoint_components true l in + let (_, _, _, info as fix) = interp_fixpoint ~cofix:false fixl ntns in + let possible_indexes = + List.map compute_possible_guardness_evidences info in + declare_fixpoint local poly fix possible_indexes ntns; + if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else () + +let do_cofixpoint local poly l = + let fixl,ntns = extract_cofixpoint_components l in + let cofix = interp_fixpoint ~cofix:true fixl ntns in + declare_cofixpoint local poly cofix ntns; + if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else () diff --git a/vernac/comFixpoint.mli b/vernac/comFixpoint.mli new file mode 100644 index 0000000000..2c84bd84d5 --- /dev/null +++ b/vernac/comFixpoint.mli @@ -0,0 +1,93 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2018 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open Constr +open Decl_kinds +open Constrexpr +open Vernacexpr + +(** {6 Fixpoints and cofixpoints} *) + +(** Entry points for the vernacular commands Fixpoint and CoFixpoint *) + +val do_fixpoint : + (* When [false], assume guarded. *) + locality -> polymorphic -> (fixpoint_expr * decl_notation list) list -> unit + +val do_cofixpoint : + (* When [false], assume guarded. *) + locality -> polymorphic -> (cofixpoint_expr * decl_notation list) list -> unit + +(************************************************************************) +(** Internal API *) +(************************************************************************) + +type structured_fixpoint_expr = { + fix_name : Id.t; + fix_univs : Vernacexpr.universe_decl_expr option; + fix_annot : Id.t Loc.located option; + fix_binders : local_binder_expr list; + fix_body : constr_expr option; + fix_type : constr_expr +} + +(** Typing global fixpoints and cofixpoint_expr *) + +(** Exported for Program *) +val interp_recursive : + (* Misc arguments *) + program_mode:bool -> cofix:bool -> + (* Notations of the fixpoint / should that be folded in the previous argument? *) + structured_fixpoint_expr list -> decl_notation list -> + + (* env / signature / univs / evar_map *) + (Environ.env * EConstr.named_context * Univdecls.universe_decl * Evd.evar_map) * + (* names / defs / types *) + (Id.t list * Constr.constr option list * Constr.types list) * + (* ctx per mutual def / implicits / struct annotations *) + (EConstr.rel_context * Impargs.manual_explicitation list * int option) list + +(** Exported for Funind *) + +(** Extracting the semantical components out of the raw syntax of + (co)fixpoints declarations *) + +val extract_fixpoint_components : bool -> + (fixpoint_expr * decl_notation list) list -> + structured_fixpoint_expr list * decl_notation list + +val extract_cofixpoint_components : + (cofixpoint_expr * decl_notation list) list -> + structured_fixpoint_expr list * decl_notation list + +type recursive_preentry = + Id.t list * constr option list * types list + +val interp_fixpoint : + cofix:bool -> + structured_fixpoint_expr list -> decl_notation list -> + recursive_preentry * Univdecls.universe_decl * UState.t * + (EConstr.rel_context * Impargs.manual_implicits * int option) list + +(** Registering fixpoints and cofixpoints in the environment *) +(** [Not used so far] *) +val declare_fixpoint : + locality -> polymorphic -> + recursive_preentry * Univdecls.universe_decl * UState.t * + (Context.Rel.t * Impargs.manual_implicits * int option) list -> + Proof_global.lemma_possible_guards -> decl_notation list -> unit + +val declare_cofixpoint : locality -> polymorphic -> + recursive_preentry * Univdecls.universe_decl * UState.t * + (Context.Rel.t * Impargs.manual_implicits * int option) list -> + decl_notation list -> unit + +(** Very private function, do not use *) +val compute_possible_guardness_evidences : + ('a, 'b) Context.Rel.pt * 'c * int option -> int list diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml new file mode 100644 index 0000000000..f3f50f41dd --- /dev/null +++ b/vernac/comInductive.ml @@ -0,0 +1,456 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Pp +open CErrors +open Sorts +open Util +open Constr +open Termops +open Environ +open Declare +open Names +open Libnames +open Globnames +open Nameops +open Constrexpr +open Constrexpr_ops +open Constrintern +open Nametab +open Impargs +open Reductionops +open Indtypes +open Decl_kinds +open Pretyping +open Evarutil +open Indschemes +open Misctypes +open Context.Rel.Declaration +open Entries + +module RelDecl = Context.Rel.Declaration + +(* 3b| Mutual inductive definitions *) + +let rec complete_conclusion a cs = CAst.map_with_loc (fun ?loc -> function + | CProdN (bl,c) -> CProdN (bl,complete_conclusion a cs c) + | CLetIn (na,b,t,c) -> CLetIn (na,b,t,complete_conclusion a cs c) + | CHole (k, _, _) -> + let (has_no_args,name,params) = a in + if not has_no_args then + user_err ?loc + (strbrk"Cannot infer the non constant arguments of the conclusion of " + ++ Id.print cs ++ str "."); + let args = List.map (fun id -> CAst.make ?loc @@ CRef(Ident(loc,id),None)) params in + CAppExpl ((None,Ident(loc,name),None),List.rev args) + | c -> c + ) + +let push_types env idl tl = + List.fold_left2 (fun env id t -> Environ.push_rel (LocalAssum (Name id,t)) env) + env idl tl + +type structured_one_inductive_expr = { + ind_name : Id.t; + ind_univs : Vernacexpr.universe_decl_expr option; + ind_arity : constr_expr; + ind_lc : (Id.t * constr_expr) list +} + +type structured_inductive_expr = + local_binder_expr list * structured_one_inductive_expr list + +let minductive_message warn = function + | [] -> user_err Pp.(str "No inductive definition.") + | [x] -> (Id.print x ++ str " is defined" ++ + if warn then str " as a non-primitive record" else mt()) + | l -> hov 0 (prlist_with_sep pr_comma Id.print l ++ + spc () ++ str "are defined") + +let check_all_names_different indl = + let ind_names = List.map (fun ind -> ind.ind_name) indl in + let cstr_names = List.map_append (fun ind -> List.map fst ind.ind_lc) indl in + let l = List.duplicates Id.equal ind_names in + let () = match l with + | [] -> () + | t :: _ -> raise (InductiveError (SameNamesTypes t)) + in + let l = List.duplicates Id.equal cstr_names in + let () = match l with + | [] -> () + | c :: _ -> raise (InductiveError (SameNamesConstructors (List.hd l))) + in + let l = List.intersect Id.equal ind_names cstr_names in + match l with + | [] -> () + | _ -> raise (InductiveError (SameNamesOverlap l)) + +let mk_mltype_data sigma env assums arity indname = + let is_ml_type = is_sort env sigma (EConstr.of_constr arity) in + (is_ml_type,indname,assums) + +let prepare_param = function + | LocalAssum (na,t) -> Name.get_id na, LocalAssumEntry t + | LocalDef (na,b,_) -> Name.get_id na, LocalDefEntry b + +(** Make the arity conclusion flexible to avoid generating an upper bound universe now, + only if the universe does not appear anywhere else. + This is really a hack to stay compatible with the semantics of template polymorphic + inductives which are recognized when a "Type" appears at the end of the conlusion in + the source syntax. *) + +let rec check_anonymous_type ind = + let open Glob_term in + match DAst.get ind with + | GSort (GType []) -> true + | GProd ( _, _, _, e) + | GLetIn (_, _, _, e) + | GLambda (_, _, _, e) + | GApp (e, _) + | GCast (e, _) -> check_anonymous_type e + | _ -> false + +let make_conclusion_flexible sigma ty poly = + if poly && Term.isArity ty then + let _, concl = Term.destArity ty in + match concl with + | Type u -> + (match Univ.universe_level u with + | Some u -> + Evd.make_flexible_variable sigma ~algebraic:true u + | None -> sigma) + | _ -> sigma + else sigma + +let is_impredicative env u = + u = Prop Null || (is_impredicative_set env && u = Prop Pos) + +let interp_ind_arity env sigma ind = + let c = intern_gen IsType env ind.ind_arity in + let impls = Implicit_quantifiers.implicits_of_glob_constr ~with_products:true c in + let sigma,t = understand_tcc env sigma ~expected_type:IsType c in + let pseudo_poly = check_anonymous_type c in + let () = if not (Reductionops.is_arity env sigma t) then + user_err ?loc:(constr_loc ind.ind_arity) (str "Not an arity") + in + let t = EConstr.Unsafe.to_constr t in + sigma, (t, pseudo_poly, impls) + +let interp_cstrs env sigma impls mldata arity ind = + let cnames,ctyps = List.split ind.ind_lc in + (* Complete conclusions of constructor types if given in ML-style syntax *) + let ctyps' = List.map2 (complete_conclusion mldata) cnames ctyps in + (* Interpret the constructor types *) + let sigma, (ctyps'', cimpls) = + on_snd List.split @@ + List.fold_left_map (fun sigma l -> + on_snd (on_fst EConstr.Unsafe.to_constr) @@ + interp_type_evars_impls env sigma ~impls l) sigma ctyps' in + sigma, (cnames, ctyps'', cimpls) + +let sign_level env evd sign = + fst (List.fold_right + (fun d (lev,env) -> + match d with + | LocalDef _ -> lev, push_rel d env + | LocalAssum _ -> + let s = destSort (Reduction.whd_all env + (EConstr.Unsafe.to_constr (nf_evar evd (Retyping.get_type_of env evd (EConstr.of_constr (RelDecl.get_type d)))))) + in + let u = univ_of_sort s in + (Univ.sup u lev, push_rel d env)) + sign (Univ.type0m_univ,env)) + +let sup_list min = List.fold_left Univ.sup min + +let extract_level env evd min tys = + let sorts = List.map (fun ty -> + let ctx, concl = Reduction.dest_prod_assum env ty in + sign_level env evd (LocalAssum (Anonymous, concl) :: ctx)) tys + in sup_list min sorts + +let is_flexible_sort evd u = + match Univ.Universe.level u with + | Some l -> Evd.is_flexible_level evd l + | None -> false + +let inductive_levels env evd poly arities inds = + let destarities = List.map (fun x -> x, Reduction.dest_arity env x) arities in + let levels = List.map (fun (x,(ctx,a)) -> + if a = Prop Null then None + else Some (univ_of_sort a)) destarities + in + let cstrs_levels, min_levels, sizes = + CList.split3 + (List.map2 (fun (_,tys,_) (arity,(ctx,du)) -> + let len = List.length tys in + let minlev = Sorts.univ_of_sort du in + let minlev = + if len > 1 && not (is_impredicative env du) then + Univ.sup minlev Univ.type0_univ + else minlev + in + let minlev = + (** Indices contribute. *) + if Indtypes.is_indices_matter () && List.length ctx > 0 then ( + let ilev = sign_level env evd ctx in + Univ.sup ilev minlev) + else minlev + in + let clev = extract_level env evd minlev tys in + (clev, minlev, len)) inds destarities) + in + (* Take the transitive closure of the system of constructors *) + (* level constraints and remove the recursive dependencies *) + let levels' = Universes.solve_constraints_system (Array.of_list levels) + (Array.of_list cstrs_levels) (Array.of_list min_levels) + in + let evd, arities = + CList.fold_left3 (fun (evd, arities) cu (arity,(ctx,du)) len -> + if is_impredicative env du then + (** Any product is allowed here. *) + evd, arity :: arities + else (** If in a predicative sort, or asked to infer the type, + we take the max of: + - indices (if in indices-matter mode) + - constructors + - Type(1) if there is more than 1 constructor + *) + (** Constructors contribute. *) + let evd = + if Sorts.is_set du then + if not (Evd.check_leq evd cu Univ.type0_univ) then + raise (Indtypes.InductiveError Indtypes.LargeNonPropInductiveNotInType) + else evd + else evd + (* Evd.set_leq_sort env evd (Type cu) du *) + in + let evd = + if len >= 2 && Univ.is_type0m_univ cu then + (** "Polymorphic" type constraint and more than one constructor, + should not land in Prop. Add constraint only if it would + land in Prop directly (no informative arguments as well). *) + Evd.set_leq_sort env evd (Prop Pos) du + else evd + in + let duu = Sorts.univ_of_sort du in + let evd = + if not (Univ.is_small_univ duu) && Univ.Universe.equal cu duu then + if is_flexible_sort evd duu && not (Evd.check_leq evd Univ.type0_univ duu) then + Evd.set_eq_sort env evd (Prop Null) du + else evd + else Evd.set_eq_sort env evd (Type cu) du + in + (evd, arity :: arities)) + (evd,[]) (Array.to_list levels') destarities sizes + in evd, List.rev arities + +let check_named (loc, na) = match na with +| Name _ -> () +| Anonymous -> + let msg = str "Parameters must be named." in + user_err ?loc msg + + +let check_param = function +| CLocalDef (na, _, _) -> check_named na +| CLocalAssum (nas, Default _, _) -> List.iter check_named nas +| CLocalAssum (nas, Generalized _, _) -> () +| CLocalPattern (loc,_) -> + Loc.raise ?loc (Stream.Error "pattern with quote not allowed here.") + +let interp_mutual_inductive (paramsl,indl) notations cum poly prv finite = + check_all_names_different indl; + List.iter check_param paramsl; + let env0 = Global.env() in + let pl = (List.hd indl).ind_univs in + let sigma, decl = Univdecls.interp_univ_decl_opt env0 pl in + let sigma, (impls, ((env_params, ctx_params), userimpls)) = + interp_context_evars env0 sigma paramsl + in + let ctx_params = List.map (fun d -> map_rel_decl EConstr.Unsafe.to_constr d) ctx_params in + let indnames = List.map (fun ind -> ind.ind_name) indl in + + (* Names of parameters as arguments of the inductive type (defs removed) *) + let assums = List.filter is_local_assum ctx_params in + let params = List.map (RelDecl.get_name %> Name.get_id) assums in + + (* Interpret the arities *) + let sigma, arities = List.fold_left_map (fun sigma -> interp_ind_arity env_params sigma) sigma indl in + + let fullarities = List.map (fun (c, _, _) -> Term.it_mkProd_or_LetIn c ctx_params) arities in + let env_ar = push_types env0 indnames fullarities in + let env_ar_params = push_rel_context ctx_params env_ar in + + (* Compute interpretation metadatas *) + let indimpls = List.map (fun (_, _, impls) -> userimpls @ + lift_implicits (Context.Rel.nhyps ctx_params) impls) arities in + let arities = List.map pi1 arities and aritypoly = List.map pi2 arities in + let impls = compute_internalization_env env0 ~impls (Inductive (params,true)) indnames fullarities indimpls in + let ntn_impls = compute_internalization_env env0 (Inductive (params,true)) indnames fullarities indimpls in + let mldatas = List.map2 (mk_mltype_data sigma env_params params) arities indnames in + + let sigma, constructors = + Metasyntax.with_syntax_protection (fun () -> + (* Temporary declaration of notations and scopes *) + List.iter (Metasyntax.set_notation_for_interpretation env_params ntn_impls) notations; + (* Interpret the constructor types *) + List.fold_left3_map (fun sigma -> interp_cstrs env_ar_params sigma impls) sigma mldatas arities indl) + () in + + (* Try further to solve evars, and instantiate them *) + let sigma = solve_remaining_evars all_and_fail_flags env_params sigma Evd.empty in + (* Compute renewed arities *) + let sigma, nf = nf_evars_and_universes sigma in + let arities = List.map nf arities in + let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map nf cl,impsl)) constructors in + let sigma = List.fold_left2 (fun sigma ty poly -> make_conclusion_flexible sigma ty poly) sigma arities aritypoly in + let sigma, arities = inductive_levels env_ar_params sigma poly arities constructors in + let sigma, nf' = nf_evars_and_universes sigma in + let nf x = nf' (nf x) in + let arities = List.map nf' arities in + let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map nf' cl,impsl)) constructors in + let ctx_params = Context.Rel.map nf ctx_params in + let uctx = Evd.check_univ_decl ~poly sigma decl in + List.iter (fun c -> check_evars env_params Evd.empty sigma (EConstr.of_constr c)) arities; + Context.Rel.iter (fun c -> check_evars env0 Evd.empty sigma (EConstr.of_constr c)) ctx_params; + List.iter (fun (_,ctyps,_) -> + List.iter (fun c -> check_evars env_ar_params Evd.empty sigma (EConstr.of_constr c)) ctyps) + constructors; + + (* Build the inductive entries *) + let entries = List.map4 (fun ind arity template (cnames,ctypes,cimpls) -> { + mind_entry_typename = ind.ind_name; + mind_entry_arity = arity; + mind_entry_template = template; + mind_entry_consnames = cnames; + mind_entry_lc = ctypes + }) indl arities aritypoly constructors in + let impls = + let len = Context.Rel.nhyps ctx_params in + List.map2 (fun indimpls (_,_,cimpls) -> + indimpls, List.map (fun impls -> + userimpls @ (lift_implicits len impls)) cimpls) indimpls constructors + in + let univs = + match uctx with + | Polymorphic_const_entry uctx -> + if cum then + Cumulative_ind_entry (Universes.univ_inf_ind_from_universe_context uctx) + else Polymorphic_ind_entry uctx + | Monomorphic_const_entry uctx -> + Monomorphic_ind_entry uctx + in + (* Build the mutual inductive entry *) + let mind_ent = + { mind_entry_params = List.map prepare_param ctx_params; + mind_entry_record = None; + mind_entry_finite = finite; + mind_entry_inds = entries; + mind_entry_private = if prv then Some false else None; + mind_entry_universes = univs; + } + in + (if poly && cum then + Inductiveops.infer_inductive_subtyping env_ar sigma mind_ent + else mind_ent), Evd.universe_binders sigma, impls + +(* Very syntactical equality *) +let eq_local_binders bl1 bl2 = + List.equal local_binder_eq bl1 bl2 + +let extract_coercions indl = + let mkqid (_,((_,id),_)) = qualid_of_ident id in + let extract lc = List.filter (fun (iscoe,_) -> iscoe) lc in + List.map mkqid (List.flatten(List.map (fun (_,_,_,lc) -> extract lc) indl)) + +let extract_params indl = + let paramsl = List.map (fun (_,params,_,_) -> params) indl in + match paramsl with + | [] -> anomaly (Pp.str "empty list of inductive types.") + | params::paramsl -> + if not (List.for_all (eq_local_binders params) paramsl) then user_err Pp.(str + "Parameters should be syntactically the same for each inductive type."); + params + +let extract_inductive indl = + List.map (fun (((_,indname),pl),_,ar,lc) -> { + ind_name = indname; ind_univs = pl; + ind_arity = Option.cata (fun x -> x) (CAst.make @@ CSort (GType [])) ar; + ind_lc = List.map (fun (_,((_,id),t)) -> (id,t)) lc + }) indl + +let extract_mutual_inductive_declaration_components indl = + let indl,ntnl = List.split indl in + let params = extract_params indl in + let coes = extract_coercions indl in + let indl = extract_inductive indl in + (params,indl), coes, List.flatten ntnl + +let is_recursive mie = + let rec is_recursive_constructor lift typ = + match Constr.kind typ with + | Prod (_,arg,rest) -> + not (EConstr.Vars.noccurn Evd.empty (** FIXME *) lift (EConstr.of_constr arg)) || + is_recursive_constructor (lift+1) rest + | LetIn (na,b,t,rest) -> is_recursive_constructor (lift+1) rest + | _ -> false + in + match mie.mind_entry_inds with + | [ind] -> + let nparams = List.length mie.mind_entry_params in + List.exists (fun t -> is_recursive_constructor (nparams+1) t) ind.mind_entry_lc + | _ -> false + +let declare_mutual_inductive_with_eliminations mie pl impls = + (* spiwack: raises an error if the structure is supposed to be non-recursive, + but isn't *) + begin match mie.mind_entry_finite with + | BiFinite when is_recursive mie -> + if Option.has_some mie.mind_entry_record then + user_err Pp.(str "Records declared with the keywords Record or Structure cannot be recursive. You can, however, define recursive records using the Inductive or CoInductive command.") + else + user_err Pp.(str ("Types declared with the keyword Variant cannot be recursive. Recursive types are defined with the Inductive and CoInductive command.")) + | _ -> () + end; + let names = List.map (fun e -> e.mind_entry_typename) mie.mind_entry_inds in + let (_, kn), prim = declare_mind mie in + let mind = Global.mind_of_delta_kn kn in + List.iteri (fun i (indimpls, constrimpls) -> + let ind = (mind,i) in + let gr = IndRef ind in + maybe_declare_manual_implicits false gr indimpls; + Declare.declare_univ_binders gr pl; + List.iteri + (fun j impls -> + maybe_declare_manual_implicits false + (ConstructRef (ind, succ j)) impls) + constrimpls) + impls; + let warn_prim = match mie.mind_entry_record with Some (Some _) -> not prim | _ -> false in + Flags.if_verbose Feedback.msg_info (minductive_message warn_prim names); + if mie.mind_entry_private == None + then declare_default_schemes mind; + mind + +type one_inductive_impls = + Impargs.manual_explicitation list (* for inds *)* + Impargs.manual_explicitation list list (* for constrs *) + +let do_mutual_inductive indl cum poly prv finite = + let indl,coes,ntns = extract_mutual_inductive_declaration_components indl in + (* Interpret the types *) + let mie,pl,impls = interp_mutual_inductive indl ntns cum poly prv finite in + (* Declare the mutual inductive block with its associated schemes *) + ignore (declare_mutual_inductive_with_eliminations mie pl impls); + (* Declare the possible notations of inductive types *) + List.iter (Metasyntax.add_notation_interpretation (Global.env ())) ntns; + (* Declare the coercions *) + List.iter (fun qid -> Class.try_add_new_coercion (locate qid) ~local:false poly) coes; + (* If positivity is assumed declares itself as unsafe. *) + if Environ.deactivated_guard (Global.env ()) then Feedback.feedback Feedback.AddedAxiom else () diff --git a/vernac/comInductive.mli b/vernac/comInductive.mli new file mode 100644 index 0000000000..82ea131e1c --- /dev/null +++ b/vernac/comInductive.mli @@ -0,0 +1,65 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open Entries +open Libnames +open Vernacexpr +open Constrexpr +open Decl_kinds + +(** {6 Inductive and coinductive types} *) + +(** Entry points for the vernacular commands Inductive and CoInductive *) + +val do_mutual_inductive : + (one_inductive_expr * decl_notation list) list -> cumulative_inductive_flag -> + polymorphic -> private_flag -> Declarations.recursivity_kind -> unit + +(************************************************************************) +(** Internal API *) +(************************************************************************) + +(** Exported for Record and Funind *) + +(** Registering a mutual inductive definition together with its + associated schemes *) + +type one_inductive_impls = + Impargs.manual_implicits (** for inds *)* + Impargs.manual_implicits list (** for constrs *) + +val declare_mutual_inductive_with_eliminations : + mutual_inductive_entry -> Universes.universe_binders -> one_inductive_impls list -> + MutInd.t + +(** Exported for Funind *) + +(** Extracting the semantical components out of the raw syntax of mutual + inductive declarations *) + +type structured_one_inductive_expr = { + ind_name : Id.t; + ind_univs : Vernacexpr.universe_decl_expr option; + ind_arity : constr_expr; + ind_lc : (Id.t * constr_expr) list +} + +type structured_inductive_expr = + local_binder_expr list * structured_one_inductive_expr list + +val extract_mutual_inductive_declaration_components : + (one_inductive_expr * decl_notation list) list -> + structured_inductive_expr * (*coercions:*) qualid list * decl_notation list + +(** Typing mutual inductive definitions *) + +val interp_mutual_inductive : + structured_inductive_expr -> decl_notation list -> cumulative_inductive_flag -> + polymorphic -> private_flag -> Declarations.recursivity_kind -> + mutual_inductive_entry * Universes.universe_binders * one_inductive_impls list diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml new file mode 100644 index 0000000000..a9a91e3043 --- /dev/null +++ b/vernac/comProgramFixpoint.ml @@ -0,0 +1,342 @@ +open Pp +open CErrors +open Util +open Constr +open Entries +open Vars +open Declare +open Names +open Libnames +open Globnames +open Nameops +open Constrexpr +open Constrexpr_ops +open Constrintern +open Decl_kinds +open Evarutil +open Context.Rel.Declaration +open ComFixpoint + +module RelDecl = Context.Rel.Declaration + +(* Wellfounded definition *) + +open Coqlib + +let contrib_name = "Program" +let subtac_dir = [contrib_name] +let fixsub_module = subtac_dir @ ["Wf"] +(* let tactics_module = subtac_dir @ ["Tactics"] *) + +let init_reference dir s () = Coqlib.coq_reference "Command" dir s +let init_constant dir s sigma = + Evarutil.new_global sigma (Coqlib.coq_reference "Command" dir s) + +let make_ref l s = init_reference l s +(* let fix_proto = init_constant tactics_module "fix_proto" *) +let fix_sub_ref = make_ref fixsub_module "Fix_sub" +let measure_on_R_ref = make_ref fixsub_module "MR" +let well_founded = init_constant ["Init"; "Wf"] "well_founded" +let mkSubset sigma name typ prop = + let open EConstr in + let sigma, app_h = Evarutil.new_global sigma (delayed_force build_sigma).typ in + sigma, mkApp (app_h, [| typ; mkLambda (name, typ, prop) |]) + +let sigT = Lazy.from_fun build_sigma_type + +let make_qref s = Qualid (Loc.tag @@ qualid_of_string s) +let lt_ref = make_qref "Init.Peano.lt" + +let rec telescope sigma l = + let open EConstr in + let open Vars in + match l with + | [] -> assert false + | [LocalAssum (n, t)] -> + sigma, t, [LocalDef (n, mkRel 1, t)], mkRel 1 + | LocalAssum (n, t) :: tl -> + let sigma, ty, tys, (k, constr) = + List.fold_left + (fun (sigma, ty, tys, (k, constr)) decl -> + let t = RelDecl.get_type decl in + let pred = mkLambda (RelDecl.get_name decl, t, ty) in + let sigma, ty = Evarutil.new_global sigma (Lazy.force sigT).typ in + let sigma, intro = Evarutil.new_global sigma (Lazy.force sigT).intro in + let sigty = mkApp (ty, [|t; pred|]) in + let intro = mkApp (intro, [|lift k t; lift k pred; mkRel k; constr|]) in + (sigma, sigty, pred :: tys, (succ k, intro))) + (sigma, t, [], (2, mkRel 1)) tl + in + let sigma, last, subst = List.fold_right2 + (fun pred decl (sigma, prev, subst) -> + let t = RelDecl.get_type decl in + let sigma, p1 = Evarutil.new_global sigma (Lazy.force sigT).proj1 in + let sigma, p2 = Evarutil.new_global sigma (Lazy.force sigT).proj2 in + let proj1 = applist (p1, [t; pred; prev]) in + let proj2 = applist (p2, [t; pred; prev]) in + (sigma, lift 1 proj2, LocalDef (get_name decl, proj1, t) :: subst)) + (List.rev tys) tl (sigma, mkRel 1, []) + in sigma, ty, (LocalDef (n, last, t) :: subst), constr + + | LocalDef (n, b, t) :: tl -> + let sigma, ty, subst, term = telescope sigma tl in + sigma, ty, (LocalDef (n, b, t) :: subst), lift 1 term + +let nf_evar_context sigma ctx = + List.map (map_constr (fun c -> Evarutil.nf_evar sigma c)) ctx + +let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = + let open EConstr in + let open Vars in + let lift_rel_context n l = Termops.map_rel_context_with_binders (liftn n) l in + Coqlib.check_required_library ["Coq";"Program";"Wf"]; + let env = Global.env() in + let sigma, decl = Univdecls.interp_univ_decl_opt env pl in + let sigma, (_, ((env', binders_rel), impls)) = interp_context_evars env sigma bl in + let len = List.length binders_rel in + let top_env = push_rel_context binders_rel env in + let sigma, top_arity = interp_type_evars top_env sigma arityc in + let full_arity = it_mkProd_or_LetIn top_arity binders_rel in + let sigma, argtyp, letbinders, make = telescope sigma binders_rel in + let argname = Id.of_string "recarg" in + let arg = LocalAssum (Name argname, argtyp) in + let binders = letbinders @ [arg] in + let binders_env = push_rel_context binders_rel env in + let sigma, (rel, _) = interp_constr_evars_impls env sigma r in + let relty = Typing.unsafe_type_of env sigma rel in + let relargty = + let error () = + user_err ?loc:(constr_loc r) + ~hdr:"Command.build_wellfounded" + (Printer.pr_econstr_env env sigma rel ++ str " is not an homogeneous binary relation.") + in + try + let ctx, ar = Reductionops.splay_prod_n env sigma 2 relty in + match ctx, EConstr.kind sigma ar with + | [LocalAssum (_,t); LocalAssum (_,u)], Sort s + when Sorts.is_prop (ESorts.kind sigma s) && Reductionops.is_conv env sigma t u -> t + | _, _ -> error () + with e when CErrors.noncritical e -> error () + in + let sigma, measure = interp_casted_constr_evars binders_env sigma measure relargty in + let sigma, wf_rel, wf_rel_fun, measure_fn = + let measure_body, measure = + it_mkLambda_or_LetIn measure letbinders, + it_mkLambda_or_LetIn measure binders + in + let sigma, comb = Evarutil.new_global sigma (delayed_force measure_on_R_ref) in + let wf_rel = mkApp (comb, [| argtyp; relargty; rel; measure |]) in + let wf_rel_fun x y = + mkApp (rel, [| subst1 x measure_body; + subst1 y measure_body |]) + in sigma, wf_rel, wf_rel_fun, measure + in + let sigma, wf_term = well_founded sigma in + let wf_proof = mkApp (wf_term, [| argtyp ; wf_rel |]) in + let argid' = Id.of_string (Id.to_string argname ^ "'") in + let wfarg sigma len = + let sigma, ss_term = mkSubset sigma (Name argid') argtyp (wf_rel_fun (mkRel 1) (mkRel (len + 1))) in + sigma, LocalAssum (Name argid', ss_term) + in + let sigma, intern_bl = + let sigma, wfa = wfarg sigma 1 in + sigma, wfa :: [arg] + in + let _intern_env = push_rel_context intern_bl env in + let sigma, proj = Evarutil.new_global sigma (delayed_force build_sigma).Coqlib.proj1 in + let wfargpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel 3)) in + let projection = (* in wfarg :: arg :: before *) + mkApp (proj, [| argtyp ; wfargpred ; mkRel 1 |]) + in + let top_arity_let = it_mkLambda_or_LetIn top_arity letbinders in + let intern_arity = substl [projection] top_arity_let in + (* substitute the projection of wfarg for something, + now intern_arity is in wfarg :: arg *) + let sigma, wfa = wfarg sigma 1 in + let intern_fun_arity_prod = it_mkProd_or_LetIn intern_arity [wfa] in + let intern_fun_binder = LocalAssum (Name (add_suffix recname "'"), intern_fun_arity_prod) in + let sigma, curry_fun = + let wfpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel (2 * len + 4))) in + let sigma, intro = Evarutil.new_global sigma (delayed_force build_sigma).Coqlib.intro in + let arg = mkApp (intro, [| argtyp; wfpred; lift 1 make; mkRel 1 |]) in + let app = mkApp (mkRel (2 * len + 2 (* recproof + orig binders + current binders *)), [| arg |]) in + let rcurry = mkApp (rel, [| measure; lift len measure |]) in + let lam = LocalAssum (Name (Id.of_string "recproof"), rcurry) in + let body = it_mkLambda_or_LetIn app (lam :: binders_rel) in + let ty = it_mkProd_or_LetIn (lift 1 top_arity) (lam :: binders_rel) in + sigma, LocalDef (Name recname, body, ty) + in + let fun_bl = intern_fun_binder :: [arg] in + let lift_lets = lift_rel_context 1 letbinders in + let sigma, intern_body = + let ctx = LocalAssum (Name recname, get_type curry_fun) :: binders_rel in + let (r, l, impls, scopes) = + Constrintern.compute_internalization_data env + Constrintern.Recursive (EConstr.Unsafe.to_constr full_arity) impls + in + let newimpls = Id.Map.singleton recname + (r, l, impls @ [(Some (Id.of_string "recproof", Impargs.Manual, (true, false)))], + scopes @ [None]) in + interp_casted_constr_evars (push_rel_context ctx env) sigma + ~impls:newimpls body (lift 1 top_arity) + in + let intern_body_lam = it_mkLambda_or_LetIn intern_body (curry_fun :: lift_lets @ fun_bl) in + let prop = mkLambda (Name argname, argtyp, top_arity_let) in + (* XXX: Previous code did parallel evdref update, so possible old + weak ordering semantics may bite here. *) + let sigma, def = + let sigma, h_a_term = Evarutil.new_global sigma (delayed_force fix_sub_ref) in + let sigma, h_e_term = Evarutil.new_evar env sigma + ~src:(Loc.tag @@ Evar_kinds.QuestionMark (Evar_kinds.Define false,Anonymous)) wf_proof in + sigma, mkApp (h_a_term, [| argtyp ; wf_rel ; h_e_term; prop |]) + in + let _evd = ref sigma in + let def = Typing.e_solve_evars env _evd def in + let sigma = !_evd in + let sigma = Evarutil.nf_evar_map sigma in + let def = mkApp (def, [|intern_body_lam|]) in + let binders_rel = nf_evar_context sigma binders_rel in + let binders = nf_evar_context sigma binders in + let top_arity = Evarutil.nf_evar sigma top_arity in + let hook, recname, typ = + if List.length binders_rel > 1 then + let name = add_suffix recname "_func" in + (* XXX: Mutating the evar_map in the hook! *) + (* XXX: Likely the sigma is out of date when the hook is called .... *) + let hook sigma l gr _ = + let sigma, h_body = Evarutil.new_global sigma gr in + let body = it_mkLambda_or_LetIn (mkApp (h_body, [|make|])) binders_rel in + let ty = it_mkProd_or_LetIn top_arity binders_rel in + let ty = EConstr.Unsafe.to_constr ty in + let univs = Evd.check_univ_decl ~poly sigma decl in + (*FIXME poly? *) + let ce = definition_entry ~types:ty ~univs (EConstr.to_constr sigma body) in + (** FIXME: include locality *) + let c = Declare.declare_constant recname (DefinitionEntry ce, IsDefinition Definition) in + let gr = ConstRef c in + let () = Universes.register_universe_binders gr (Evd.universe_binders sigma) in + if Impargs.is_implicit_args () || not (List.is_empty impls) then + Impargs.declare_manual_implicits false gr [impls] + in + let typ = it_mkProd_or_LetIn top_arity binders in + hook, name, typ + else + let typ = it_mkProd_or_LetIn top_arity binders_rel in + let hook sigma l gr _ = + if Impargs.is_implicit_args () || not (List.is_empty impls) then + Impargs.declare_manual_implicits false gr [impls] + in hook, recname, typ + in + (* XXX: Capturing sigma here... bad bad *) + let hook = Lemmas.mk_hook (hook sigma) in + let fullcoqc = EConstr.to_constr sigma def in + let fullctyp = EConstr.to_constr sigma typ in + Obligations.check_evars env sigma; + let evars, _, evars_def, evars_typ = + Obligations.eterm_obligations env recname sigma 0 fullcoqc fullctyp + in + let ctx = Evd.evar_universe_context sigma in + ignore(Obligations.add_definition recname ~term:evars_def ~univdecl:decl + evars_typ ctx evars ~hook) + +let out_def = function + | Some def -> def + | None -> user_err Pp.(str "Program Fixpoint needs defined bodies.") + +let collect_evars_of_term evd c ty = + let evars = Evar.Set.union (Evd.evars_of_term c) (Evd.evars_of_term ty) in + Evar.Set.fold (fun ev acc -> Evd.add acc ev (Evd.find_undefined evd ev)) + evars (Evd.from_ctx (Evd.evar_universe_context evd)) + +let do_program_recursive local poly fixkind fixl ntns = + let cofix = fixkind = Obligations.IsCoFixpoint in + let (env, rec_sign, pl, evd), fix, info = + interp_recursive ~cofix ~program_mode:true fixl ntns + in + (* Program-specific code *) + (* Get the interesting evars, those that were not instanciated *) + let evd = Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~fail:true env evd in + (* Solve remaining evars *) + let evd = nf_evar_map_undefined evd in + let collect_evars id def typ imps = + (* Generalize by the recursive prototypes *) + let def = + EConstr.to_constr evd (Termops.it_mkNamedLambda_or_LetIn (EConstr.of_constr def) rec_sign) + and typ = + EConstr.to_constr evd (Termops.it_mkNamedProd_or_LetIn (EConstr.of_constr typ) rec_sign) + in + let evm = collect_evars_of_term evd def typ in + let evars, _, def, typ = + Obligations.eterm_obligations env id evm + (List.length rec_sign) def typ + in (id, def, typ, imps, evars) + in + let (fixnames,fixdefs,fixtypes) = fix in + let fiximps = List.map pi2 info in + let fixdefs = List.map out_def fixdefs in + let defs = List.map4 collect_evars fixnames fixdefs fixtypes fiximps in + let () = if not cofix then begin + let possible_indexes = List.map ComFixpoint.compute_possible_guardness_evidences info in + let fixdecls = Array.of_list (List.map (fun x -> Name x) fixnames), + Array.of_list fixtypes, + Array.of_list (List.map (subst_vars (List.rev fixnames)) fixdefs) + in + let indexes = + Pretyping.search_guard (Global.env ()) possible_indexes fixdecls in + List.iteri (fun i _ -> + Inductive.check_fix env + ((indexes,i),fixdecls)) + fixl + end in + let ctx = Evd.evar_universe_context evd in + let kind = match fixkind with + | Obligations.IsFixpoint _ -> (local, poly, Fixpoint) + | Obligations.IsCoFixpoint -> (local, poly, CoFixpoint) + in + Obligations.add_mutual_definitions defs ~kind ~univdecl:pl ctx ntns fixkind + +let do_program_fixpoint local poly l = + let g = List.map (fun ((_,wf,_,_,_),_) -> wf) l in + match g, l with + | [(n, CWfRec r)], [((((_,id),pl),_,bl,typ,def),ntn)] -> + let recarg = + match n with + | Some n -> mkIdentC (snd n) + | None -> + user_err ~hdr:"do_program_fixpoint" + (str "Recursive argument required for well-founded fixpoints") + in build_wellfounded (id, pl, n, bl, typ, out_def def) poly r recarg ntn + + | [(n, CMeasureRec (m, r))], [((((_,id),pl),_,bl,typ,def),ntn)] -> + build_wellfounded (id, pl, n, bl, typ, out_def def) poly + (Option.default (CAst.make @@ CRef (lt_ref,None)) r) m ntn + + | _, _ when List.for_all (fun (n, ro) -> ro == CStructRec) g -> + let fixl,ntns = extract_fixpoint_components true l in + let fixkind = Obligations.IsFixpoint g in + do_program_recursive local poly fixkind fixl ntns + + | _, _ -> + user_err ~hdr:"do_program_fixpoint" + (str "Well-founded fixpoints not allowed in mutually recursive blocks") + +let extract_cofixpoint_components l = + let fixl, ntnl = List.split l in + List.map (fun (((_,id),pl),bl,typ,def) -> + {fix_name = id; fix_annot = None; fix_univs = pl; + fix_binders = bl; fix_body = def; fix_type = typ}) fixl, + List.flatten ntnl + +let check_safe () = + let open Declarations in + let flags = Environ.typing_flags (Global.env ()) in + flags.check_universes && flags.check_guarded + +let do_fixpoint local poly l = + do_program_fixpoint local poly l; + if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else () + +let do_cofixpoint local poly l = + let fixl,ntns = extract_cofixpoint_components l in + do_program_recursive local poly Obligations.IsCoFixpoint fixl ntns; + if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else () diff --git a/vernac/comProgramFixpoint.mli b/vernac/comProgramFixpoint.mli new file mode 100644 index 0000000000..943cb8efe6 --- /dev/null +++ b/vernac/comProgramFixpoint.mli @@ -0,0 +1,12 @@ +open Decl_kinds +open Vernacexpr + +(** Special Fixpoint handling when command is activated. *) + +val do_fixpoint : + (* When [false], assume guarded. *) + locality -> polymorphic -> (fixpoint_expr * decl_notation list) list -> unit + +val do_cofixpoint : + (* When [false], assume guarded. *) + locality -> polymorphic -> (cofixpoint_expr * decl_notation list) list -> unit diff --git a/vernac/command.ml b/vernac/command.ml deleted file mode 100644 index 64412b20fe..0000000000 --- a/vernac/command.ml +++ /dev/null @@ -1,1361 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -open Pp -open CErrors -open Sorts -open Util -open Constr -open Vars -open Termops -open Environ -open Redexpr -open Declare -open Names -open Libnames -open Globnames -open Nameops -open Constrexpr -open Constrexpr_ops -open Constrintern -open Nametab -open Impargs -open Reductionops -open Indtypes -open Decl_kinds -open Pretyping -open Evarutil -open Evarconv -open Indschemes -open Misctypes -open Vernacexpr -open Context.Rel.Declaration -open Entries - -module RelDecl = Context.Rel.Declaration - -let do_universe poly l = Declare.do_universe poly l -let do_constraint poly l = Declare.do_constraint poly l - -let rec under_binders env sigma f n c = - if Int.equal n 0 then f env sigma (EConstr.of_constr c) else - match Constr.kind c with - | Lambda (x,t,c) -> - mkLambda (x,t,under_binders (push_rel (LocalAssum (x,t)) env) sigma f (n-1) c) - | LetIn (x,b,t,c) -> - mkLetIn (x,b,t,under_binders (push_rel (LocalDef (x,b,t)) env) sigma f (n-1) c) - | _ -> assert false - -let rec complete_conclusion a cs = CAst.map_with_loc (fun ?loc -> function - | CProdN (bl,c) -> CProdN (bl,complete_conclusion a cs c) - | CLetIn (na,b,t,c) -> CLetIn (na,b,t,complete_conclusion a cs c) - | CHole (k, _, _) -> - let (has_no_args,name,params) = a in - if not has_no_args then - user_err ?loc - (strbrk"Cannot infer the non constant arguments of the conclusion of " - ++ Id.print cs ++ str "."); - let args = List.map (fun id -> CAst.make ?loc @@ CRef(Ident(loc,id),None)) params in - CAppExpl ((None,Ident(loc,name),None),List.rev args) - | c -> c - ) - -(* Commands of the interface *) - -(* 1| Constant definitions *) - -let red_constant_entry n ce sigma = function - | None -> ce - | Some red -> - let proof_out = ce.const_entry_body in - let env = Global.env () in - let (redfun, _) = reduction_of_red_expr env red in - let redfun env sigma c = - let (_, c) = redfun env sigma c in - EConstr.Unsafe.to_constr c - in - { ce with const_entry_body = Future.chain proof_out - (fun ((body,ctx),eff) -> (under_binders env sigma redfun n body,ctx),eff) } - -let warn_implicits_in_term = - CWarnings.create ~name:"implicits-in-term" ~category:"implicits" - (fun () -> - strbrk "Implicit arguments declaration relies on type." ++ spc () ++ - strbrk "The term declares more implicits than the type here.") - -let interp_definition pl bl poly red_option c ctypopt = - let env = Global.env() in - let evd, decl = Univdecls.interp_univ_decl_opt env pl in - let evdref = ref evd in - let impls, ((env_bl, ctx), imps1) = interp_context_evars env evdref bl in - let ctx = List.map (fun d -> map_rel_decl EConstr.Unsafe.to_constr d) ctx in - let nb_args = Context.Rel.nhyps ctx in - let imps,ce = - match ctypopt with - None -> - let subst = evd_comb0 Evd.nf_univ_variables evdref in - let ctx = Context.Rel.map (Vars.subst_univs_constr subst) ctx in - let env_bl = push_rel_context ctx env in - let c, imps2 = interp_constr_evars_impls ~impls env_bl evdref c in - let c = EConstr.Unsafe.to_constr c in - let nf,subst = Evarutil.e_nf_evars_and_universes evdref in - let body = nf (it_mkLambda_or_LetIn c ctx) in - let vars = EConstr.universes_of_constr env !evdref (EConstr.of_constr body) in - let () = evdref := Evd.restrict_universe_context !evdref vars in - let uctx = Evd.check_univ_decl ~poly !evdref decl in - imps1@(Impargs.lift_implicits nb_args imps2), - definition_entry ~univs:uctx body - | Some ctyp -> - let ty, impsty = interp_type_evars_impls ~impls env_bl evdref ctyp in - let subst = evd_comb0 Evd.nf_univ_variables evdref in - let ctx = Context.Rel.map (Vars.subst_univs_constr subst) ctx in - let env_bl = push_rel_context ctx env in - let c, imps2 = interp_casted_constr_evars_impls ~impls env_bl evdref c ty in - let c = EConstr.Unsafe.to_constr c in - let nf, subst = Evarutil.e_nf_evars_and_universes evdref in - let body = nf (it_mkLambda_or_LetIn c ctx) in - let ty = EConstr.Unsafe.to_constr ty in - let typ = nf (Term.it_mkProd_or_LetIn ty ctx) in - let beq b1 b2 = if b1 then b2 else not b2 in - let impl_eq (x,y,z) (x',y',z') = beq x x' && beq y y' && beq z z' in - (* Check that all implicit arguments inferable from the term - are inferable from the type *) - let chk (key,va) = - impl_eq (List.assoc_f Pervasives.(=) key impsty) va (* FIXME *) - in - if not (try List.for_all chk imps2 with Not_found -> false) - then warn_implicits_in_term (); - let bodyvars = EConstr.universes_of_constr env !evdref (EConstr.of_constr body) in - let tyvars = EConstr.universes_of_constr env !evdref (EConstr.of_constr ty) in - let vars = Univ.LSet.union bodyvars tyvars in - let () = evdref := Evd.restrict_universe_context !evdref vars in - let uctx = Evd.check_univ_decl ~poly !evdref decl in - imps1@(Impargs.lift_implicits nb_args impsty), - definition_entry ~types:typ ~univs:uctx body - in - (red_constant_entry (Context.Rel.length ctx) ce !evdref red_option, !evdref, decl, imps) - -let check_definition (ce, evd, _, imps) = - check_evars_are_solved (Global.env ()) evd Evd.empty; - ce - -let do_definition ident k univdecl bl red_option c ctypopt hook = - let (ce, evd, univdecl, imps as def) = - interp_definition univdecl bl (pi2 k) red_option c ctypopt - in - if Flags.is_program_mode () then - let env = Global.env () in - let (c,ctx), sideff = Future.force ce.const_entry_body in - assert(Safe_typing.empty_private_constants = sideff); - assert(Univ.ContextSet.is_empty ctx); - let typ = match ce.const_entry_type with - | Some t -> t - | None -> EConstr.to_constr evd (Retyping.get_type_of env evd (EConstr.of_constr c)) - in - Obligations.check_evars env evd; - let obls, _, c, cty = - Obligations.eterm_obligations env ident evd 0 c typ - in - let ctx = Evd.evar_universe_context evd in - let hook = Lemmas.mk_hook (fun l r _ -> Lemmas.call_hook (fun exn -> exn) hook l r) in - ignore(Obligations.add_definition - ident ~term:c cty ctx ~univdecl ~implicits:imps ~kind:k ~hook obls) - else let ce = check_definition def in - ignore(DeclareDef.declare_definition ident k ce (Evd.universe_binders evd) imps - (Lemmas.mk_hook - (fun l r -> Lemmas.call_hook (fun exn -> exn) hook l r;r))) - -(* 2| Variable/Hypothesis/Parameter/Axiom declarations *) - -let axiom_into_instance = ref false - -let _ = - let open Goptions in - declare_bool_option - { optdepr = false; - optname = "automatically declare axioms whose type is a typeclass as instances"; - optkey = ["Typeclasses";"Axioms";"Are";"Instances"]; - optread = (fun _ -> !axiom_into_instance); - optwrite = (:=) axiom_into_instance; } - -let should_axiom_into_instance = function - | Discharge -> - (* The typeclass behaviour of Variable and Context doesn't depend - on section status *) - true - | Global | Local -> !axiom_into_instance - -let declare_assumption is_coe (local,p,kind) (c,ctx) pl imps impl nl (_,ident) = -match local with -| Discharge when Lib.sections_are_opened () -> - let ctx = match ctx with - | Monomorphic_const_entry ctx -> ctx - | Polymorphic_const_entry ctx -> Univ.ContextSet.of_context ctx - in - let decl = (Lib.cwd(), SectionLocalAssum ((c,ctx),p,impl), IsAssumption kind) in - let _ = declare_variable ident decl in - let () = assumption_message ident in - let () = - if not !Flags.quiet && Proof_global.there_are_pending_proofs () then - Feedback.msg_info (str"Variable" ++ spc () ++ Id.print ident ++ - strbrk " is not visible from current goals") - in - let r = VarRef ident in - let () = Typeclasses.declare_instance None true r in - let () = if is_coe then Class.try_add_new_coercion r ~local:true false in - (r,Univ.Instance.empty,true) - -| Global | Local | Discharge -> - let do_instance = should_axiom_into_instance local in - let local = DeclareDef.get_locality ident ~kind:"axiom" local in - let inl = match nl with - | NoInline -> None - | DefaultInline -> Some (Flags.get_inline_level()) - | InlineAt i -> Some i - in - let decl = (ParameterEntry (None,(c,ctx),inl), IsAssumption kind) in - let kn = declare_constant ident ~local decl in - let gr = ConstRef kn in - let () = maybe_declare_manual_implicits false gr imps in - let () = Declare.declare_univ_binders gr pl in - let () = assumption_message ident in - let () = if do_instance then Typeclasses.declare_instance None false gr in - let () = if is_coe then Class.try_add_new_coercion gr ~local p in - let inst = match ctx with - | Polymorphic_const_entry ctx -> Univ.UContext.instance ctx - | Monomorphic_const_entry _ -> Univ.Instance.empty - in - (gr,inst,Lib.is_modtype_strict ()) - -let interp_assumption evdref env impls bl c = - let c = mkCProdN ?loc:(local_binders_loc bl) bl c in - let ty, impls = interp_type_evars_impls env evdref ~impls c in - let ty = EConstr.Unsafe.to_constr ty in - (ty, impls) - -(* When monomorphic the universe constraints are declared with the first declaration only. *) -let next_uctx = - let empty_uctx = Monomorphic_const_entry Univ.ContextSet.empty in - function - | Polymorphic_const_entry _ as uctx -> uctx - | Monomorphic_const_entry _ -> empty_uctx - -let declare_assumptions idl is_coe k (c,uctx) pl imps nl = - let refs, status, _ = - List.fold_left (fun (refs,status,uctx) id -> - let ref',u',status' = - declare_assumption is_coe k (c,uctx) pl imps false nl id in - (ref',u')::refs, status' && status, next_uctx uctx) - ([],true,uctx) idl - in - List.rev refs, status - - -let maybe_error_many_udecls = function - | ((loc,id), Some _) -> - user_err ?loc ~hdr:"many_universe_declarations" - Pp.(str "When declaring multiple axioms in one command, " ++ - str "only the first is allowed a universe binder " ++ - str "(which will be shared by the whole block).") - | (_, None) -> () - -let process_assumptions_udecls kind l = - let udecl, first_id = match l with - | (coe, ((id, udecl)::rest, c))::rest' -> - List.iter maybe_error_many_udecls rest; - List.iter (fun (coe, (idl, c)) -> List.iter maybe_error_many_udecls idl) rest'; - udecl, id - | (_, ([], _))::_ | [] -> assert false - in - let () = match kind, udecl with - | (Discharge, _, _), Some _ when Lib.sections_are_opened () -> - let loc = fst first_id in - let msg = Pp.str "Section variables cannot be polymorphic." in - user_err ?loc msg - | _ -> () - in - udecl, List.map (fun (coe, (idl, c)) -> coe, (List.map fst idl, c)) l - -let do_assumptions kind nl l = - let open Context.Named.Declaration in - let env = Global.env () in - let udecl, l = process_assumptions_udecls kind l in - let evdref, udecl = - let evd, udecl = Univdecls.interp_univ_decl_opt env udecl in - ref evd, udecl - in - let l = - if pi2 kind (* poly *) then - (* Separate declarations so that A B : Type puts A and B in different levels. *) - List.fold_right (fun (is_coe,(idl,c)) acc -> - List.fold_right (fun id acc -> - (is_coe, ([id], c)) :: acc) idl acc) - l [] - else l - in - (* We intepret all declarations in the same evar_map, i.e. as a telescope. *) - let _,l = List.fold_left_map (fun (env,ienv) (is_coe,(idl,c)) -> - let t,imps = interp_assumption evdref env ienv [] c in - let env = - push_named_context (List.map (fun (_,id) -> LocalAssum (id,t)) idl) env in - let ienv = List.fold_right (fun (_,id) ienv -> - let impls = compute_internalization_data env Variable t imps in - Id.Map.add id impls ienv) idl ienv in - ((env,ienv),((is_coe,idl),t,imps))) - (env,empty_internalization_env) l - in - let evd = solve_remaining_evars all_and_fail_flags env !evdref Evd.empty in - (* The universe constraints come from the whole telescope. *) - let evd = Evd.nf_constraints evd in - let nf_evar c = EConstr.to_constr evd (EConstr.of_constr c) in - let uvars, l = List.fold_left_map (fun uvars (coe,t,imps) -> - let t = nf_evar t in - let uvars = Univ.LSet.union uvars (Univops.universes_of_constr env t) in - uvars, (coe,t,imps)) - Univ.LSet.empty l - in - let evd = Evd.restrict_universe_context evd uvars in - let uctx = Evd.check_univ_decl ~poly:(pi2 kind) evd udecl in - let ubinders = Evd.universe_binders evd in - pi2 (List.fold_left (fun (subst,status,uctx) ((is_coe,idl),t,imps) -> - let t = replace_vars subst t in - let refs, status' = declare_assumptions idl is_coe kind (t,uctx) ubinders imps nl in - let subst' = List.map2 - (fun (_,id) (c,u) -> (id, Universes.constr_of_global_univ (c,u))) - idl refs - in - subst'@subst, status' && status, next_uctx uctx) - ([], true, uctx) l) - -(* 3a| Elimination schemes for mutual inductive definitions *) - -(* 3b| Mutual inductive definitions *) - -let push_types env idl tl = - List.fold_left2 (fun env id t -> Environ.push_rel (LocalAssum (Name id,t)) env) - env idl tl - -type structured_one_inductive_expr = { - ind_name : Id.t; - ind_univs : Vernacexpr.universe_decl_expr option; - ind_arity : constr_expr; - ind_lc : (Id.t * constr_expr) list -} - -type structured_inductive_expr = - local_binder_expr list * structured_one_inductive_expr list - -let minductive_message warn = function - | [] -> user_err Pp.(str "No inductive definition.") - | [x] -> (Id.print x ++ str " is defined" ++ - if warn then str " as a non-primitive record" else mt()) - | l -> hov 0 (prlist_with_sep pr_comma Id.print l ++ - spc () ++ str "are defined") - -let check_all_names_different indl = - let ind_names = List.map (fun ind -> ind.ind_name) indl in - let cstr_names = List.map_append (fun ind -> List.map fst ind.ind_lc) indl in - let l = List.duplicates Id.equal ind_names in - let () = match l with - | [] -> () - | t :: _ -> raise (InductiveError (SameNamesTypes t)) - in - let l = List.duplicates Id.equal cstr_names in - let () = match l with - | [] -> () - | c :: _ -> raise (InductiveError (SameNamesConstructors (List.hd l))) - in - let l = List.intersect Id.equal ind_names cstr_names in - match l with - | [] -> () - | _ -> raise (InductiveError (SameNamesOverlap l)) - -let mk_mltype_data evdref env assums arity indname = - let is_ml_type = is_sort env !evdref (EConstr.of_constr arity) in - (is_ml_type,indname,assums) - -let prepare_param = function - | LocalAssum (na,t) -> Name.get_id na, LocalAssumEntry t - | LocalDef (na,b,_) -> Name.get_id na, LocalDefEntry b - -(** Make the arity conclusion flexible to avoid generating an upper bound universe now, - only if the universe does not appear anywhere else. - This is really a hack to stay compatible with the semantics of template polymorphic - inductives which are recognized when a "Type" appears at the end of the conlusion in - the source syntax. *) - -let rec check_anonymous_type ind = - let open Glob_term in - match DAst.get ind with - | GSort (GType []) -> true - | GProd ( _, _, _, e) - | GLetIn (_, _, _, e) - | GLambda (_, _, _, e) - | GApp (e, _) - | GCast (e, _) -> check_anonymous_type e - | _ -> false - -let make_conclusion_flexible evdref ty poly = - if poly && Term.isArity ty then - let _, concl = Term.destArity ty in - match concl with - | Type u -> - (match Univ.universe_level u with - | Some u -> - evdref := Evd.make_flexible_variable !evdref ~algebraic:true u - | None -> ()) - | _ -> () - else () - -let is_impredicative env u = - u = Prop Null || (is_impredicative_set env && u = Prop Pos) - -let interp_ind_arity env evdref ind = - let c = intern_gen IsType env ind.ind_arity in - let impls = Implicit_quantifiers.implicits_of_glob_constr ~with_products:true c in - let (evd,t) = understand_tcc env !evdref ~expected_type:IsType c in - evdref := evd; - let pseudo_poly = check_anonymous_type c in - let () = if not (Reductionops.is_arity env !evdref t) then - user_err ?loc:(constr_loc ind.ind_arity) (str "Not an arity") - in - let t = EConstr.Unsafe.to_constr t in - t, pseudo_poly, impls - -let interp_cstrs evdref env impls mldata arity ind = - let cnames,ctyps = List.split ind.ind_lc in - (* Complete conclusions of constructor types if given in ML-style syntax *) - let ctyps' = List.map2 (complete_conclusion mldata) cnames ctyps in - (* Interpret the constructor types *) - let ctyps'', cimpls = List.split (List.map (interp_type_evars_impls evdref env ~impls %> on_fst EConstr.Unsafe.to_constr) ctyps') in - (cnames, ctyps'', cimpls) - -let sign_level env evd sign = - fst (List.fold_right - (fun d (lev,env) -> - match d with - | LocalDef _ -> lev, push_rel d env - | LocalAssum _ -> - let s = destSort (Reduction.whd_all env - (EConstr.Unsafe.to_constr (nf_evar evd (Retyping.get_type_of env evd (EConstr.of_constr (RelDecl.get_type d)))))) - in - let u = univ_of_sort s in - (Univ.sup u lev, push_rel d env)) - sign (Univ.type0m_univ,env)) - -let sup_list min = List.fold_left Univ.sup min - -let extract_level env evd min tys = - let sorts = List.map (fun ty -> - let ctx, concl = Reduction.dest_prod_assum env ty in - sign_level env evd (LocalAssum (Anonymous, concl) :: ctx)) tys - in sup_list min sorts - -let is_flexible_sort evd u = - match Univ.Universe.level u with - | Some l -> Evd.is_flexible_level evd l - | None -> false - -let inductive_levels env evdref poly arities inds = - let destarities = List.map (fun x -> x, Reduction.dest_arity env x) arities in - let levels = List.map (fun (x,(ctx,a)) -> - if a = Prop Null then None - else Some (univ_of_sort a)) destarities - in - let cstrs_levels, min_levels, sizes = - CList.split3 - (List.map2 (fun (_,tys,_) (arity,(ctx,du)) -> - let len = List.length tys in - let minlev = Sorts.univ_of_sort du in - let minlev = - if len > 1 && not (is_impredicative env du) then - Univ.sup minlev Univ.type0_univ - else minlev - in - let minlev = - (** Indices contribute. *) - if Indtypes.is_indices_matter () && List.length ctx > 0 then ( - let ilev = sign_level env !evdref ctx in - Univ.sup ilev minlev) - else minlev - in - let clev = extract_level env !evdref minlev tys in - (clev, minlev, len)) inds destarities) - in - (* Take the transitive closure of the system of constructors *) - (* level constraints and remove the recursive dependencies *) - let levels' = Universes.solve_constraints_system (Array.of_list levels) - (Array.of_list cstrs_levels) (Array.of_list min_levels) - in - let evd, arities = - CList.fold_left3 (fun (evd, arities) cu (arity,(ctx,du)) len -> - if is_impredicative env du then - (** Any product is allowed here. *) - evd, arity :: arities - else (** If in a predicative sort, or asked to infer the type, - we take the max of: - - indices (if in indices-matter mode) - - constructors - - Type(1) if there is more than 1 constructor - *) - (** Constructors contribute. *) - let evd = - if Sorts.is_set du then - if not (Evd.check_leq evd cu Univ.type0_univ) then - raise (Indtypes.InductiveError Indtypes.LargeNonPropInductiveNotInType) - else evd - else evd - (* Evd.set_leq_sort env evd (Type cu) du *) - in - let evd = - if len >= 2 && Univ.is_type0m_univ cu then - (** "Polymorphic" type constraint and more than one constructor, - should not land in Prop. Add constraint only if it would - land in Prop directly (no informative arguments as well). *) - Evd.set_leq_sort env evd (Prop Pos) du - else evd - in - let duu = Sorts.univ_of_sort du in - let evd = - if not (Univ.is_small_univ duu) && Univ.Universe.equal cu duu then - if is_flexible_sort evd duu && not (Evd.check_leq evd Univ.type0_univ duu) then - Evd.set_eq_sort env evd (Prop Null) du - else evd - else Evd.set_eq_sort env evd (Type cu) du - in - (evd, arity :: arities)) - (!evdref,[]) (Array.to_list levels') destarities sizes - in evdref := evd; List.rev arities - -let check_named (loc, na) = match na with -| Name _ -> () -| Anonymous -> - let msg = str "Parameters must be named." in - user_err ?loc msg - - -let check_param = function -| CLocalDef (na, _, _) -> check_named na -| CLocalAssum (nas, Default _, _) -> List.iter check_named nas -| CLocalAssum (nas, Generalized _, _) -> () -| CLocalPattern (loc,_) -> - Loc.raise ?loc (Stream.Error "pattern with quote not allowed here.") - -let interp_mutual_inductive (paramsl,indl) notations cum poly prv finite = - check_all_names_different indl; - List.iter check_param paramsl; - let env0 = Global.env() in - let pl = (List.hd indl).ind_univs in - let evd, decl = Univdecls.interp_univ_decl_opt env0 pl in - let evdref = ref evd in - let impls, ((env_params, ctx_params), userimpls) = - interp_context_evars env0 evdref paramsl - in - let ctx_params = List.map (fun d -> map_rel_decl EConstr.Unsafe.to_constr d) ctx_params in - let indnames = List.map (fun ind -> ind.ind_name) indl in - - (* Names of parameters as arguments of the inductive type (defs removed) *) - let assums = List.filter is_local_assum ctx_params in - let params = List.map (RelDecl.get_name %> Name.get_id) assums in - - (* Interpret the arities *) - let arities = List.map (interp_ind_arity env_params evdref) indl in - - let fullarities = List.map (fun (c, _, _) -> Term.it_mkProd_or_LetIn c ctx_params) arities in - let env_ar = push_types env0 indnames fullarities in - let env_ar_params = push_rel_context ctx_params env_ar in - - (* Compute interpretation metadatas *) - let indimpls = List.map (fun (_, _, impls) -> userimpls @ - lift_implicits (Context.Rel.nhyps ctx_params) impls) arities in - let arities = List.map pi1 arities and aritypoly = List.map pi2 arities in - let impls = compute_internalization_env env0 ~impls (Inductive (params,true)) indnames fullarities indimpls in - let ntn_impls = compute_internalization_env env0 (Inductive (params,true)) indnames fullarities indimpls in - let mldatas = List.map2 (mk_mltype_data evdref env_params params) arities indnames in - - let constructors = - Metasyntax.with_syntax_protection (fun () -> - (* Temporary declaration of notations and scopes *) - List.iter (Metasyntax.set_notation_for_interpretation env_params ntn_impls) notations; - (* Interpret the constructor types *) - List.map3 (interp_cstrs env_ar_params evdref impls) mldatas arities indl) - () in - - (* Try further to solve evars, and instantiate them *) - let sigma = solve_remaining_evars all_and_fail_flags env_params !evdref Evd.empty in - evdref := sigma; - (* Compute renewed arities *) - let nf,_ = e_nf_evars_and_universes evdref in - let arities = List.map nf arities in - let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map nf cl,impsl)) constructors in - let _ = List.iter2 (fun ty poly -> make_conclusion_flexible evdref ty poly) arities aritypoly in - let arities = inductive_levels env_ar_params evdref poly arities constructors in - let nf',_ = e_nf_evars_and_universes evdref in - let nf x = nf' (nf x) in - let arities = List.map nf' arities in - let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map nf' cl,impsl)) constructors in - let ctx_params = Context.Rel.map nf ctx_params in - let evd = !evdref in - let uctx = Evd.check_univ_decl ~poly evd decl in - List.iter (fun c -> check_evars env_params Evd.empty evd (EConstr.of_constr c)) arities; - Context.Rel.iter (fun c -> check_evars env0 Evd.empty evd (EConstr.of_constr c)) ctx_params; - List.iter (fun (_,ctyps,_) -> - List.iter (fun c -> check_evars env_ar_params Evd.empty evd (EConstr.of_constr c)) ctyps) - constructors; - - (* Build the inductive entries *) - let entries = List.map4 (fun ind arity template (cnames,ctypes,cimpls) -> { - mind_entry_typename = ind.ind_name; - mind_entry_arity = arity; - mind_entry_template = template; - mind_entry_consnames = cnames; - mind_entry_lc = ctypes - }) indl arities aritypoly constructors in - let impls = - let len = Context.Rel.nhyps ctx_params in - List.map2 (fun indimpls (_,_,cimpls) -> - indimpls, List.map (fun impls -> - userimpls @ (lift_implicits len impls)) cimpls) indimpls constructors - in - let univs = - match uctx with - | Polymorphic_const_entry uctx -> - if cum then - Cumulative_ind_entry (Universes.univ_inf_ind_from_universe_context uctx) - else Polymorphic_ind_entry uctx - | Monomorphic_const_entry uctx -> - Monomorphic_ind_entry uctx - in - (* Build the mutual inductive entry *) - let mind_ent = - { mind_entry_params = List.map prepare_param ctx_params; - mind_entry_record = None; - mind_entry_finite = finite; - mind_entry_inds = entries; - mind_entry_private = if prv then Some false else None; - mind_entry_universes = univs; - } - in - (if poly && cum then - Inductiveops.infer_inductive_subtyping env_ar evd mind_ent - else mind_ent), Evd.universe_binders evd, impls - -(* Very syntactical equality *) -let eq_local_binders bl1 bl2 = - List.equal local_binder_eq bl1 bl2 - -let extract_coercions indl = - let mkqid (_,((_,id),_)) = qualid_of_ident id in - let extract lc = List.filter (fun (iscoe,_) -> iscoe) lc in - List.map mkqid (List.flatten(List.map (fun (_,_,_,lc) -> extract lc) indl)) - -let extract_params indl = - let paramsl = List.map (fun (_,params,_,_) -> params) indl in - match paramsl with - | [] -> anomaly (Pp.str "empty list of inductive types.") - | params::paramsl -> - if not (List.for_all (eq_local_binders params) paramsl) then user_err Pp.(str - "Parameters should be syntactically the same for each inductive type."); - params - -let extract_inductive indl = - List.map (fun (((_,indname),pl),_,ar,lc) -> { - ind_name = indname; ind_univs = pl; - ind_arity = Option.cata (fun x -> x) (CAst.make @@ CSort (GType [])) ar; - ind_lc = List.map (fun (_,((_,id),t)) -> (id,t)) lc - }) indl - -let extract_mutual_inductive_declaration_components indl = - let indl,ntnl = List.split indl in - let params = extract_params indl in - let coes = extract_coercions indl in - let indl = extract_inductive indl in - (params,indl), coes, List.flatten ntnl - -let is_recursive mie = - let rec is_recursive_constructor lift typ = - match Constr.kind typ with - | Prod (_,arg,rest) -> - not (EConstr.Vars.noccurn Evd.empty (** FIXME *) lift (EConstr.of_constr arg)) || - is_recursive_constructor (lift+1) rest - | LetIn (na,b,t,rest) -> is_recursive_constructor (lift+1) rest - | _ -> false - in - match mie.mind_entry_inds with - | [ind] -> - let nparams = List.length mie.mind_entry_params in - List.exists (fun t -> is_recursive_constructor (nparams+1) t) ind.mind_entry_lc - | _ -> false - -let declare_mutual_inductive_with_eliminations mie pl impls = - (* spiwack: raises an error if the structure is supposed to be non-recursive, - but isn't *) - begin match mie.mind_entry_finite with - | BiFinite when is_recursive mie -> - if Option.has_some mie.mind_entry_record then - user_err Pp.(str "Records declared with the keywords Record or Structure cannot be recursive. You can, however, define recursive records using the Inductive or CoInductive command.") - else - user_err Pp.(str ("Types declared with the keyword Variant cannot be recursive. Recursive types are defined with the Inductive and CoInductive command.")) - | _ -> () - end; - let names = List.map (fun e -> e.mind_entry_typename) mie.mind_entry_inds in - let (_, kn), prim = declare_mind mie in - let mind = Global.mind_of_delta_kn kn in - List.iteri (fun i (indimpls, constrimpls) -> - let ind = (mind,i) in - let gr = IndRef ind in - maybe_declare_manual_implicits false gr indimpls; - Declare.declare_univ_binders gr pl; - List.iteri - (fun j impls -> - maybe_declare_manual_implicits false - (ConstructRef (ind, succ j)) impls) - constrimpls) - impls; - let warn_prim = match mie.mind_entry_record with Some (Some _) -> not prim | _ -> false in - Flags.if_verbose Feedback.msg_info (minductive_message warn_prim names); - if mie.mind_entry_private == None - then declare_default_schemes mind; - mind - -type one_inductive_impls = - Impargs.manual_explicitation list (* for inds *)* - Impargs.manual_explicitation list list (* for constrs *) - -let do_mutual_inductive indl cum poly prv finite = - let indl,coes,ntns = extract_mutual_inductive_declaration_components indl in - (* Interpret the types *) - let mie,pl,impls = interp_mutual_inductive indl ntns cum poly prv finite in - (* Declare the mutual inductive block with its associated schemes *) - ignore (declare_mutual_inductive_with_eliminations mie pl impls); - (* Declare the possible notations of inductive types *) - List.iter (Metasyntax.add_notation_interpretation (Global.env ())) ntns; - (* Declare the coercions *) - List.iter (fun qid -> Class.try_add_new_coercion (locate qid) ~local:false poly) coes; - (* If positivity is assumed declares itself as unsafe. *) - if Environ.deactivated_guard (Global.env ()) then Feedback.feedback Feedback.AddedAxiom else () - -(* 3c| Fixpoints and co-fixpoints *) - -(* An (unoptimized) function that maps preorders to partial orders... - - Input: a list of associations (x,[y1;...;yn]), all yi distincts - and different of x, meaning x<=y1, ..., x<=yn - - Output: a list of associations (x,Inr [y1;...;yn]), collecting all - distincts yi greater than x, _or_, (x, Inl y) meaning that - x is in the same class as y (in which case, x occurs - nowhere else in the association map) - - partial_order : ('a * 'a list) list -> ('a * ('a,'a list) union) list -*) - -let rec partial_order cmp = function - | [] -> [] - | (x,xge)::rest -> - let rec browse res xge' = function - | [] -> - let res = List.map (function - | (z, Inr zge) when List.mem_f cmp x zge -> - (z, Inr (List.union cmp zge xge')) - | r -> r) res in - (x,Inr xge')::res - | y::xge -> - let rec link y = - try match List.assoc_f cmp y res with - | Inl z -> link z - | Inr yge -> - if List.mem_f cmp x yge then - let res = List.remove_assoc_f cmp y res in - let res = List.map (function - | (z, Inl t) -> - if cmp t y then (z, Inl x) else (z, Inl t) - | (z, Inr zge) -> - if List.mem_f cmp y zge then - (z, Inr (List.add_set cmp x (List.remove cmp y zge))) - else - (z, Inr zge)) res in - browse ((y,Inl x)::res) xge' (List.union cmp xge (List.remove cmp x yge)) - else - browse res (List.add_set cmp y (List.union cmp xge' yge)) xge - with Not_found -> browse res (List.add_set cmp y xge') xge - in link y - in browse (partial_order cmp rest) [] xge - -let non_full_mutual_message x xge y yge isfix rest = - let reason = - if Id.List.mem x yge then - Id.print y ++ str " depends on " ++ Id.print x ++ strbrk " but not conversely" - else if Id.List.mem y xge then - Id.print x ++ str " depends on " ++ Id.print y ++ strbrk " but not conversely" - else - Id.print y ++ str " and " ++ Id.print x ++ strbrk " are not mutually dependent" in - let e = if List.is_empty rest then reason else strbrk "e.g., " ++ reason in - let k = if isfix then "fixpoint" else "cofixpoint" in - let w = - if isfix - then strbrk "Well-foundedness check may fail unexpectedly." ++ fnl() - else mt () in - strbrk "Not a fully mutually defined " ++ str k ++ fnl () ++ - str "(" ++ e ++ str ")." ++ fnl () ++ w - -let warn_non_full_mutual = - CWarnings.create ~name:"non-full-mutual" ~category:"fixpoints" - (fun (x,xge,y,yge,isfix,rest) -> - non_full_mutual_message x xge y yge isfix rest) - -let check_mutuality env evd isfix fixl = - let names = List.map fst fixl in - let preorder = - List.map (fun (id,def) -> - (id, List.filter (fun id' -> not (Id.equal id id') && occur_var env evd id' (EConstr.of_constr def)) names)) - fixl in - let po = partial_order Id.equal preorder in - match List.filter (function (_,Inr _) -> true | _ -> false) po with - | (x,Inr xge)::(y,Inr yge)::rest -> - warn_non_full_mutual (x,xge,y,yge,isfix,rest) - | _ -> () - -type structured_fixpoint_expr = { - fix_name : Id.t; - fix_univs : universe_decl_expr option; - fix_annot : Id.t Loc.located option; - fix_binders : local_binder_expr list; - fix_body : constr_expr option; - fix_type : constr_expr -} - -let interp_fix_context env evdref isfix fix = - let before, after = if isfix then split_at_annot fix.fix_binders fix.fix_annot else [], fix.fix_binders in - let impl_env, ((env', ctx), imps) = interp_context_evars env evdref before in - let impl_env', ((env'', ctx'), imps') = interp_context_evars ~impl_env ~shift:(Context.Rel.nhyps ctx) env' evdref after in - let annot = Option.map (fun _ -> List.length (assums_of_rel_context ctx)) fix.fix_annot in - ((env'', ctx' @ ctx), (impl_env',imps @ imps'), annot) - -let interp_fix_ccl evdref impls (env,_) fix = - let (c, impl) = interp_type_evars_impls ~impls env evdref fix.fix_type in - (c, impl) - -let interp_fix_body env_rec evdref impls (_,ctx) fix ccl = - let open EConstr in - Option.map (fun body -> - let env = push_rel_context ctx env_rec in - let body = interp_casted_constr_evars env evdref ~impls body ccl in - it_mkLambda_or_LetIn body ctx) fix.fix_body - -let build_fix_type (_,ctx) ccl = EConstr.it_mkProd_or_LetIn ccl ctx - -let prepare_recursive_declaration fixnames fixtypes fixdefs = - let defs = List.map (subst_vars (List.rev fixnames)) fixdefs in - let names = List.map (fun id -> Name id) fixnames in - (Array.of_list names, Array.of_list fixtypes, Array.of_list defs) - -(* Jump over let-bindings. *) - -let compute_possible_guardness_evidences (ctx,_,recindex) = - (* A recursive index is characterized by the number of lambdas to - skip before finding the relevant inductive argument *) - match recindex with - | Some i -> [i] - | None -> - (* If recursive argument was not given by user, we try all args. - An earlier approach was to look only for inductive arguments, - but doing it properly involves delta-reduction, and it finally - doesn't seem to worth the effort (except for huge mutual - fixpoints ?) *) - List.interval 0 (Context.Rel.nhyps ctx - 1) - -type recursive_preentry = - Id.t list * constr option list * types list - -(* Wellfounded definition *) - -open Coqlib - -let contrib_name = "Program" -let subtac_dir = [contrib_name] -let fixsub_module = subtac_dir @ ["Wf"] -let tactics_module = subtac_dir @ ["Tactics"] - -let init_reference dir s () = Coqlib.coq_reference "Command" dir s -let init_constant dir s evdref = - let (sigma, c) = Evarutil.new_global !evdref (Coqlib.coq_reference "Command" dir s) - in evdref := sigma; c - -let make_ref l s = init_reference l s -let fix_proto = init_constant tactics_module "fix_proto" -let fix_sub_ref = make_ref fixsub_module "Fix_sub" -let measure_on_R_ref = make_ref fixsub_module "MR" -let well_founded = init_constant ["Init"; "Wf"] "well_founded" -let mkSubset evdref name typ prop = - let open EConstr in - mkApp (Evarutil.e_new_global evdref (delayed_force build_sigma).typ, - [| typ; mkLambda (name, typ, prop) |]) -let sigT = Lazy.from_fun build_sigma_type - -let make_qref s = Qualid (Loc.tag @@ qualid_of_string s) -let lt_ref = make_qref "Init.Peano.lt" - -let rec telescope evdref l = - let open EConstr in - let open Vars in - match l with - | [] -> assert false - | [LocalAssum (n, t)] -> t, [LocalDef (n, mkRel 1, t)], mkRel 1 - | LocalAssum (n, t) :: tl -> - let ty, tys, (k, constr) = - List.fold_left - (fun (ty, tys, (k, constr)) decl -> - let t = RelDecl.get_type decl in - let pred = mkLambda (RelDecl.get_name decl, t, ty) in - let ty = Evarutil.e_new_global evdref (Lazy.force sigT).typ in - let intro = Evarutil.e_new_global evdref (Lazy.force sigT).intro in - let sigty = mkApp (ty, [|t; pred|]) in - let intro = mkApp (intro, [|lift k t; lift k pred; mkRel k; constr|]) in - (sigty, pred :: tys, (succ k, intro))) - (t, [], (2, mkRel 1)) tl - in - let (last, subst) = List.fold_right2 - (fun pred decl (prev, subst) -> - let t = RelDecl.get_type decl in - let p1 = Evarutil.e_new_global evdref (Lazy.force sigT).proj1 in - let p2 = Evarutil.e_new_global evdref (Lazy.force sigT).proj2 in - let proj1 = applist (p1, [t; pred; prev]) in - let proj2 = applist (p2, [t; pred; prev]) in - (lift 1 proj2, LocalDef (get_name decl, proj1, t) :: subst)) - (List.rev tys) tl (mkRel 1, []) - in ty, (LocalDef (n, last, t) :: subst), constr - - | LocalDef (n, b, t) :: tl -> let ty, subst, term = telescope evdref tl in - ty, (LocalDef (n, b, t) :: subst), lift 1 term - -let nf_evar_context sigma ctx = - List.map (map_constr (fun c -> Evarutil.nf_evar sigma c)) ctx - -let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = - let open EConstr in - let open Vars in - let lift_rel_context n l = Termops.map_rel_context_with_binders (liftn n) l in - Coqlib.check_required_library ["Coq";"Program";"Wf"]; - let env = Global.env() in - let evd, decl = Univdecls.interp_univ_decl_opt env pl in - let evdref = ref evd in - let _, ((env', binders_rel), impls) = interp_context_evars env evdref bl in - let len = List.length binders_rel in - let top_env = push_rel_context binders_rel env in - let top_arity = interp_type_evars top_env evdref arityc in - let full_arity = it_mkProd_or_LetIn top_arity binders_rel in - let argtyp, letbinders, make = telescope evdref binders_rel in - let argname = Id.of_string "recarg" in - let arg = LocalAssum (Name argname, argtyp) in - let binders = letbinders @ [arg] in - let binders_env = push_rel_context binders_rel env in - let rel, _ = interp_constr_evars_impls env evdref r in - let relty = Typing.unsafe_type_of env !evdref rel in - let relargty = - let error () = - user_err ?loc:(constr_loc r) - ~hdr:"Command.build_wellfounded" - (Printer.pr_econstr_env env !evdref rel ++ str " is not an homogeneous binary relation.") - in - try - let ctx, ar = Reductionops.splay_prod_n env !evdref 2 relty in - match ctx, EConstr.kind !evdref ar with - | [LocalAssum (_,t); LocalAssum (_,u)], Sort s - when Sorts.is_prop (ESorts.kind !evdref s) && Reductionops.is_conv env !evdref t u -> t - | _, _ -> error () - with e when CErrors.noncritical e -> error () - in - let measure = interp_casted_constr_evars binders_env evdref measure relargty in - let wf_rel, wf_rel_fun, measure_fn = - let measure_body, measure = - it_mkLambda_or_LetIn measure letbinders, - it_mkLambda_or_LetIn measure binders - in - let comb = Evarutil.e_new_global evdref (delayed_force measure_on_R_ref) in - let wf_rel = mkApp (comb, [| argtyp; relargty; rel; measure |]) in - let wf_rel_fun x y = - mkApp (rel, [| subst1 x measure_body; - subst1 y measure_body |]) - in wf_rel, wf_rel_fun, measure - in - let wf_proof = mkApp (well_founded evdref, [| argtyp ; wf_rel |]) in - let argid' = Id.of_string (Id.to_string argname ^ "'") in - let wfarg len = LocalAssum (Name argid', - mkSubset evdref (Name argid') argtyp - (wf_rel_fun (mkRel 1) (mkRel (len + 1)))) - in - let intern_bl = wfarg 1 :: [arg] in - let _intern_env = push_rel_context intern_bl env in - let proj = Evarutil.e_new_global evdref (delayed_force build_sigma).Coqlib.proj1 in - let wfargpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel 3)) in - let projection = (* in wfarg :: arg :: before *) - mkApp (proj, [| argtyp ; wfargpred ; mkRel 1 |]) - in - let top_arity_let = it_mkLambda_or_LetIn top_arity letbinders in - let intern_arity = substl [projection] top_arity_let in - (* substitute the projection of wfarg for something, - now intern_arity is in wfarg :: arg *) - let intern_fun_arity_prod = it_mkProd_or_LetIn intern_arity [wfarg 1] in - let intern_fun_binder = LocalAssum (Name (add_suffix recname "'"), intern_fun_arity_prod) in - let curry_fun = - let wfpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel (2 * len + 4))) in - let intro = Evarutil.e_new_global evdref (delayed_force build_sigma).Coqlib.intro in - let arg = mkApp (intro, [| argtyp; wfpred; lift 1 make; mkRel 1 |]) in - let app = mkApp (mkRel (2 * len + 2 (* recproof + orig binders + current binders *)), [| arg |]) in - let rcurry = mkApp (rel, [| measure; lift len measure |]) in - let lam = LocalAssum (Name (Id.of_string "recproof"), rcurry) in - let body = it_mkLambda_or_LetIn app (lam :: binders_rel) in - let ty = it_mkProd_or_LetIn (lift 1 top_arity) (lam :: binders_rel) in - LocalDef (Name recname, body, ty) - in - let fun_bl = intern_fun_binder :: [arg] in - let lift_lets = lift_rel_context 1 letbinders in - let intern_body = - let ctx = LocalAssum (Name recname, get_type curry_fun) :: binders_rel in - let (r, l, impls, scopes) = - Constrintern.compute_internalization_data env - Constrintern.Recursive (EConstr.Unsafe.to_constr full_arity) impls - in - let newimpls = Id.Map.singleton recname - (r, l, impls @ [(Some (Id.of_string "recproof", Impargs.Manual, (true, false)))], - scopes @ [None]) in - interp_casted_constr_evars (push_rel_context ctx env) evdref - ~impls:newimpls body (lift 1 top_arity) - in - let intern_body_lam = it_mkLambda_or_LetIn intern_body (curry_fun :: lift_lets @ fun_bl) in - let prop = mkLambda (Name argname, argtyp, top_arity_let) in - let def = - mkApp (Evarutil.e_new_global evdref (delayed_force fix_sub_ref), - [| argtyp ; wf_rel ; - Evarutil.e_new_evar env evdref - ~src:(Loc.tag @@ Evar_kinds.QuestionMark (Evar_kinds.Define false,Anonymous)) wf_proof; - prop |]) - in - let def = Typing.e_solve_evars env evdref def in - let _ = evdref := Evarutil.nf_evar_map !evdref in - let def = mkApp (def, [|intern_body_lam|]) in - let binders_rel = nf_evar_context !evdref binders_rel in - let binders = nf_evar_context !evdref binders in - let top_arity = Evarutil.nf_evar !evdref top_arity in - let hook, recname, typ = - if List.length binders_rel > 1 then - let name = add_suffix recname "_func" in - let hook l gr _ = - let body = it_mkLambda_or_LetIn (mkApp (Evarutil.e_new_global evdref gr, [|make|])) binders_rel in - let ty = it_mkProd_or_LetIn top_arity binders_rel in - let ty = EConstr.Unsafe.to_constr ty in - let univs = Evd.check_univ_decl ~poly !evdref decl in - (*FIXME poly? *) - let ce = definition_entry ~types:ty ~univs (EConstr.to_constr !evdref body) in - (** FIXME: include locality *) - let c = Declare.declare_constant recname (DefinitionEntry ce, IsDefinition Definition) in - let gr = ConstRef c in - let () = Universes.register_universe_binders gr (Evd.universe_binders !evdref) in - if Impargs.is_implicit_args () || not (List.is_empty impls) then - Impargs.declare_manual_implicits false gr [impls] - in - let typ = it_mkProd_or_LetIn top_arity binders in - hook, name, typ - else - let typ = it_mkProd_or_LetIn top_arity binders_rel in - let hook l gr _ = - if Impargs.is_implicit_args () || not (List.is_empty impls) then - Impargs.declare_manual_implicits false gr [impls] - in hook, recname, typ - in - let hook = Lemmas.mk_hook hook in - let fullcoqc = EConstr.to_constr !evdref def in - let fullctyp = EConstr.to_constr !evdref typ in - Obligations.check_evars env !evdref; - let evars, _, evars_def, evars_typ = - Obligations.eterm_obligations env recname !evdref 0 fullcoqc fullctyp - in - let ctx = Evd.evar_universe_context !evdref in - ignore(Obligations.add_definition recname ~term:evars_def ~univdecl:decl - evars_typ ctx evars ~hook) - -let interp_recursive isfix fixl notations = - let open Context.Named.Declaration in - let open EConstr in - let env = Global.env() in - let fixnames = List.map (fun fix -> fix.fix_name) fixl in - - (* Interp arities allowing for unresolved types *) - let all_universes = - List.fold_right (fun sfe acc -> - match sfe.fix_univs , acc with - | None , acc -> acc - | x , None -> x - | Some ls , Some us -> - let lsu = ls.univdecl_instance and usu = us.univdecl_instance in - if not (CList.for_all2eq (fun x y -> Id.equal (snd x) (snd y)) lsu usu) then - user_err Pp.(str "(co)-recursive definitions should all have the same universe binders"); - Some us) fixl None in - let evd, decl = Univdecls.interp_univ_decl_opt env all_universes in - let evdref = ref evd in - let fixctxs, fiximppairs, fixannots = - List.split3 (List.map (interp_fix_context env evdref isfix) fixl) in - let fixctximpenvs, fixctximps = List.split fiximppairs in - let fixccls,fixcclimps = List.split (List.map3 (interp_fix_ccl evdref) fixctximpenvs fixctxs fixl) in - let fixtypes = List.map2 build_fix_type fixctxs fixccls in - let fixtypes = List.map (fun c -> nf_evar !evdref c) fixtypes in - let fiximps = List.map3 - (fun ctximps cclimps (_,ctx) -> ctximps@(Impargs.lift_implicits (Context.Rel.nhyps ctx) cclimps)) - fixctximps fixcclimps fixctxs in - let rec_sign = - List.fold_left2 - (fun env' id t -> - if Flags.is_program_mode () then - let sort = Evarutil.evd_comb1 (Typing.type_of ~refresh:true env) evdref t in - let fixprot = - try - let app = mkApp (fix_proto evdref, [|sort; t|]) in - Typing.e_solve_evars env evdref app - with e when CErrors.noncritical e -> t - in - LocalAssum (id,fixprot) :: env' - else LocalAssum (id,t) :: env') - [] fixnames fixtypes - in - let env_rec = push_named_context rec_sign env in - - (* Get interpretation metadatas *) - let fixtypes = List.map EConstr.Unsafe.to_constr fixtypes in - let impls = compute_internalization_env env Recursive fixnames fixtypes fiximps in - - (* Interp bodies with rollback because temp use of notations/implicit *) - let fixdefs = - Metasyntax.with_syntax_protection (fun () -> - List.iter (Metasyntax.set_notation_for_interpretation env_rec impls) notations; - List.map4 - (fun fixctximpenv -> interp_fix_body env_rec evdref (Id.Map.fold Id.Map.add fixctximpenv impls)) - fixctximpenvs fixctxs fixl fixccls) - () in - - (* Instantiate evars and check all are resolved *) - let evd = solve_unif_constraints_with_heuristics env_rec !evdref in - let evd, nf = nf_evars_and_universes evd in - let fixdefs = List.map (fun c -> Option.map EConstr.Unsafe.to_constr c) fixdefs in - let fixdefs = List.map (Option.map nf) fixdefs in - let fixtypes = List.map nf fixtypes in - let fixctxs = List.map (fun (_,ctx) -> ctx) fixctxs in - - (* Build the fix declaration block *) - (env,rec_sign,decl,evd), (fixnames,fixdefs,fixtypes), List.combine3 fixctxs fiximps fixannots - -let check_recursive isfix env evd (fixnames,fixdefs,_) = - check_evars_are_solved env evd Evd.empty; - if List.for_all Option.has_some fixdefs then begin - let fixdefs = List.map Option.get fixdefs in - check_mutuality env evd isfix (List.combine fixnames fixdefs) - end - -let interp_fixpoint l ntns = - let (env,_,pl,evd),fix,info = interp_recursive true l ntns in - check_recursive true env evd fix; - (fix,pl,Evd.evar_universe_context evd,info) - -let interp_cofixpoint l ntns = - let (env,_,pl,evd),fix,info = interp_recursive false l ntns in - check_recursive false env evd fix; - (fix,pl,Evd.evar_universe_context evd,info) - -let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) indexes ntns = - if List.exists Option.is_empty fixdefs then - (* Some bodies to define by proof *) - let thms = - List.map3 (fun id t (ctx,imps,_) -> (id,(t,(List.map RelDecl.get_name ctx,imps)))) - fixnames fixtypes fiximps in - let init_tac = - Some (List.map (Option.cata (EConstr.of_constr %> Tactics.exact_no_check) Tacticals.New.tclIDTAC) - fixdefs) in - let evd = Evd.from_ctx ctx in - Lemmas.start_proof_with_initialization (Global,poly,DefinitionBody Fixpoint) - evd pl (Some(false,indexes,init_tac)) thms None (Lemmas.mk_hook (fun _ _ -> ())) - else begin - (* We shortcut the proof process *) - let fixdefs = List.map Option.get fixdefs in - let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in - let env = Global.env() in - let indexes = search_guard env indexes fixdecls in - let fiximps = List.map (fun (n,r,p) -> r) fiximps in - let vars = Univops.universes_of_constr env (mkFix ((indexes,0),fixdecls)) in - let fixdecls = - List.map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 fixnames in - let evd = Evd.from_ctx ctx in - let evd = Evd.restrict_universe_context evd vars in - let ctx = Evd.check_univ_decl ~poly evd pl in - let pl = Evd.universe_binders evd in - let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in - ignore (List.map4 (DeclareDef.declare_fix (local, poly, Fixpoint) pl ctx) - fixnames fixdecls fixtypes fiximps); - (* Declare the recursive definitions *) - fixpoint_message (Some indexes) fixnames; - end; - (* Declare notations *) - List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns - -let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) ntns = - if List.exists Option.is_empty fixdefs then - (* Some bodies to define by proof *) - let thms = - List.map3 (fun id t (ctx,imps,_) -> (id,(t,(List.map RelDecl.get_name ctx,imps)))) - fixnames fixtypes fiximps in - let init_tac = - Some (List.map (Option.cata (EConstr.of_constr %> Tactics.exact_no_check) Tacticals.New.tclIDTAC) - fixdefs) in - let evd = Evd.from_ctx ctx in - Lemmas.start_proof_with_initialization (Global,poly, DefinitionBody CoFixpoint) - evd pl (Some(true,[],init_tac)) thms None (Lemmas.mk_hook (fun _ _ -> ())) - else begin - (* We shortcut the proof process *) - let fixdefs = List.map Option.get fixdefs in - let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in - let fixdecls = List.map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 fixnames in - let env = Global.env () in - let vars = Univops.universes_of_constr env (List.hd fixdecls) in - let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in - let fiximps = List.map (fun (len,imps,idx) -> imps) fiximps in - let evd = Evd.from_ctx ctx in - let evd = Evd.restrict_universe_context evd vars in - let ctx = Evd.check_univ_decl ~poly evd pl in - let pl = Evd.universe_binders evd in - ignore (List.map4 (DeclareDef.declare_fix (local, poly, CoFixpoint) pl ctx) - fixnames fixdecls fixtypes fiximps); - (* Declare the recursive definitions *) - cofixpoint_message fixnames - end; - (* Declare notations *) - List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns - -let extract_decreasing_argument limit = function - | (na,CStructRec) -> na - | (na,_) when not limit -> na - | _ -> user_err Pp.(str - "Only structural decreasing is supported for a non-Program Fixpoint") - -let extract_fixpoint_components limit l = - let fixl, ntnl = List.split l in - let fixl = List.map (fun (((_,id),pl),ann,bl,typ,def) -> - let ann = extract_decreasing_argument limit ann in - {fix_name = id; fix_annot = ann; fix_univs = pl; - fix_binders = bl; fix_body = def; fix_type = typ}) fixl in - fixl, List.flatten ntnl - -let extract_cofixpoint_components l = - let fixl, ntnl = List.split l in - List.map (fun (((_,id),pl),bl,typ,def) -> - {fix_name = id; fix_annot = None; fix_univs = pl; - fix_binders = bl; fix_body = def; fix_type = typ}) fixl, - List.flatten ntnl - -let out_def = function - | Some def -> def - | None -> user_err Pp.(str "Program Fixpoint needs defined bodies.") - -let collect_evars_of_term evd c ty = - let evars = Evar.Set.union (Evd.evars_of_term c) (Evd.evars_of_term ty) in - Evar.Set.fold (fun ev acc -> Evd.add acc ev (Evd.find_undefined evd ev)) - evars (Evd.from_ctx (Evd.evar_universe_context evd)) - -let do_program_recursive local poly fixkind fixl ntns = - let isfix = fixkind != Obligations.IsCoFixpoint in - let (env, rec_sign, pl, evd), fix, info = - interp_recursive isfix fixl ntns - in - (* Program-specific code *) - (* Get the interesting evars, those that were not instanciated *) - let evd = Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~fail:true env evd in - (* Solve remaining evars *) - let evd = nf_evar_map_undefined evd in - let collect_evars id def typ imps = - (* Generalize by the recursive prototypes *) - let def = - EConstr.to_constr evd (Termops.it_mkNamedLambda_or_LetIn (EConstr.of_constr def) rec_sign) - and typ = - EConstr.to_constr evd (Termops.it_mkNamedProd_or_LetIn (EConstr.of_constr typ) rec_sign) - in - let evm = collect_evars_of_term evd def typ in - let evars, _, def, typ = - Obligations.eterm_obligations env id evm - (List.length rec_sign) def typ - in (id, def, typ, imps, evars) - in - let (fixnames,fixdefs,fixtypes) = fix in - let fiximps = List.map pi2 info in - let fixdefs = List.map out_def fixdefs in - let defs = List.map4 collect_evars fixnames fixdefs fixtypes fiximps in - let () = if isfix then begin - let possible_indexes = List.map compute_possible_guardness_evidences info in - let fixdecls = Array.of_list (List.map (fun x -> Name x) fixnames), - Array.of_list fixtypes, - Array.of_list (List.map (subst_vars (List.rev fixnames)) fixdefs) - in - let indexes = - Pretyping.search_guard (Global.env ()) possible_indexes fixdecls in - List.iteri (fun i _ -> - Inductive.check_fix env - ((indexes,i),fixdecls)) - fixl - end in - let ctx = Evd.evar_universe_context evd in - let kind = match fixkind with - | Obligations.IsFixpoint _ -> (local, poly, Fixpoint) - | Obligations.IsCoFixpoint -> (local, poly, CoFixpoint) - in - Obligations.add_mutual_definitions defs ~kind ~univdecl:pl ctx ntns fixkind - -let do_program_fixpoint local poly l = - let g = List.map (fun ((_,wf,_,_,_),_) -> wf) l in - match g, l with - | [(n, CWfRec r)], [((((_,id),pl),_,bl,typ,def),ntn)] -> - let recarg = - match n with - | Some n -> mkIdentC (snd n) - | None -> - user_err ~hdr:"do_program_fixpoint" - (str "Recursive argument required for well-founded fixpoints") - in build_wellfounded (id, pl, n, bl, typ, out_def def) poly r recarg ntn - - | [(n, CMeasureRec (m, r))], [((((_,id),pl),_,bl,typ,def),ntn)] -> - build_wellfounded (id, pl, n, bl, typ, out_def def) poly - (Option.default (CAst.make @@ CRef (lt_ref,None)) r) m ntn - - | _, _ when List.for_all (fun (n, ro) -> ro == CStructRec) g -> - let fixl,ntns = extract_fixpoint_components true l in - let fixkind = Obligations.IsFixpoint g in - do_program_recursive local poly fixkind fixl ntns - - | _, _ -> - user_err ~hdr:"do_program_fixpoint" - (str "Well-founded fixpoints not allowed in mutually recursive blocks") - -let check_safe () = - let open Declarations in - let flags = Environ.typing_flags (Global.env ()) in - flags.check_universes && flags.check_guarded - -let do_fixpoint local poly l = - if Flags.is_program_mode () then do_program_fixpoint local poly l - else - let fixl, ntns = extract_fixpoint_components true l in - let (_, _, _, info as fix) = interp_fixpoint fixl ntns in - let possible_indexes = - List.map compute_possible_guardness_evidences info in - declare_fixpoint local poly fix possible_indexes ntns; - if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else () - -let do_cofixpoint local poly l = - let fixl,ntns = extract_cofixpoint_components l in - if Flags.is_program_mode () then - do_program_recursive local poly Obligations.IsCoFixpoint fixl ntns - else - let cofix = interp_cofixpoint fixl ntns in - declare_cofixpoint local poly cofix ntns; - if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else () diff --git a/vernac/command.mli b/vernac/command.mli deleted file mode 100644 index c7342e6da9..0000000000 --- a/vernac/command.mli +++ /dev/null @@ -1,163 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -open Names -open Constr -open Entries -open Libnames -open Globnames -open Vernacexpr -open Constrexpr -open Decl_kinds -open Redexpr - -(** This file is about the interpretation of raw commands into typed - ones and top-level declaration of the main Gallina objects *) - -val do_universe : polymorphic -> Id.t Loc.located list -> unit -val do_constraint : polymorphic -> - (Misctypes.glob_level * Univ.constraint_type * Misctypes.glob_level) list -> unit - -(** {6 Definitions/Let} *) - -val interp_definition : - Vernacexpr.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 - -val do_definition : Id.t -> definition_kind -> Vernacexpr.universe_decl_expr option -> - local_binder_expr list -> red_expr option -> constr_expr -> - constr_expr option -> unit Lemmas.declaration_hook -> unit - -(** {6 Parameters/Assumptions} *) - -(* val interp_assumption : env -> evar_map ref -> *) -(* local_binder_expr list -> constr_expr -> *) -(* types Univ.in_universe_context_set * Impargs.manual_implicits *) - -(** returns [false] if the assumption is neither local to a section, - nor in a module type and meant to be instantiated. *) -val declare_assumption : coercion_flag -> assumption_kind -> - types in_constant_universes_entry -> - Universes.universe_binders -> Impargs.manual_implicits -> - bool (** implicit *) -> Vernacexpr.inline -> variable Loc.located -> - global_reference * Univ.Instance.t * bool - -val do_assumptions : locality * polymorphic * assumption_object_kind -> - Vernacexpr.inline -> (Vernacexpr.ident_decl list * constr_expr) with_coercion list -> bool - -(* val declare_assumptions : variable Loc.located list -> *) -(* coercion_flag -> assumption_kind -> types Univ.in_universe_context_set -> *) -(* Impargs.manual_implicits -> bool -> Vernacexpr.inline -> bool *) - -(** {6 Inductive and coinductive types} *) - -(** Extracting the semantical components out of the raw syntax of mutual - inductive declarations *) - -type structured_one_inductive_expr = { - ind_name : Id.t; - ind_univs : Vernacexpr.universe_decl_expr option; - ind_arity : constr_expr; - ind_lc : (Id.t * constr_expr) list -} - -type structured_inductive_expr = - local_binder_expr list * structured_one_inductive_expr list - -val extract_mutual_inductive_declaration_components : - (one_inductive_expr * decl_notation list) list -> - structured_inductive_expr * (*coercions:*) qualid list * decl_notation list - -(** Typing mutual inductive definitions *) - -type one_inductive_impls = - Impargs.manual_implicits (** for inds *)* - Impargs.manual_implicits list (** for constrs *) - -val interp_mutual_inductive : - structured_inductive_expr -> decl_notation list -> cumulative_inductive_flag -> - polymorphic -> private_flag -> Declarations.recursivity_kind -> - mutual_inductive_entry * Universes.universe_binders * one_inductive_impls list - -(** Registering a mutual inductive definition together with its - associated schemes *) - -val declare_mutual_inductive_with_eliminations : - mutual_inductive_entry -> Universes.universe_binders -> one_inductive_impls list -> - MutInd.t - -(** Entry points for the vernacular commands Inductive and CoInductive *) - -val do_mutual_inductive : - (one_inductive_expr * decl_notation list) list -> cumulative_inductive_flag -> - polymorphic -> private_flag -> Declarations.recursivity_kind -> unit - -(** {6 Fixpoints and cofixpoints} *) - -type structured_fixpoint_expr = { - fix_name : Id.t; - fix_univs : Vernacexpr.universe_decl_expr option; - fix_annot : Id.t Loc.located option; - fix_binders : local_binder_expr list; - fix_body : constr_expr option; - fix_type : constr_expr -} - -(** Extracting the semantical components out of the raw syntax of - (co)fixpoints declarations *) - -val extract_fixpoint_components : bool -> - (fixpoint_expr * decl_notation list) list -> - structured_fixpoint_expr list * decl_notation list - -val extract_cofixpoint_components : - (cofixpoint_expr * decl_notation list) list -> - structured_fixpoint_expr list * decl_notation list - -(** Typing global fixpoints and cofixpoint_expr *) - -type recursive_preentry = - Id.t list * constr option list * types list - -val interp_fixpoint : - structured_fixpoint_expr list -> decl_notation list -> - recursive_preentry * Univdecls.universe_decl * UState.t * - (EConstr.rel_context * Impargs.manual_implicits * int option) list - -val interp_cofixpoint : - structured_fixpoint_expr list -> decl_notation list -> - recursive_preentry * Univdecls.universe_decl * UState.t * - (EConstr.rel_context * Impargs.manual_implicits * int option) list - -(** Registering fixpoints and cofixpoints in the environment *) - -val declare_fixpoint : - locality -> polymorphic -> - recursive_preentry * Univdecls.universe_decl * UState.t * - (Context.Rel.t * Impargs.manual_implicits * int option) list -> - Proof_global.lemma_possible_guards -> decl_notation list -> unit - -val declare_cofixpoint : locality -> polymorphic -> - recursive_preentry * Univdecls.universe_decl * UState.t * - (Context.Rel.t * Impargs.manual_implicits * int option) list -> - decl_notation list -> unit - -(** Entry points for the vernacular commands Fixpoint and CoFixpoint *) - -val do_fixpoint : - (* When [false], assume guarded. *) - locality -> polymorphic -> (fixpoint_expr * decl_notation list) list -> unit - -val do_cofixpoint : - (* When [false], assume guarded. *) - locality -> polymorphic -> (cofixpoint_expr * decl_notation list) list -> unit - -(** Utils *) - -val check_mutuality : Environ.env -> Evd.evar_map -> bool -> (Id.t * types) list -> unit diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 200c2260ed..27a680b9b6 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -13,12 +13,10 @@ open CErrors open Util open Pp open Names -open Term open Constr open Declarations open Declareops open Entries -open Environ open Nameops open Globnames open Decls @@ -88,28 +86,28 @@ let adjust_guardness_conditions const = function (mkFix ((indexes,0),fixdecls), ctx), eff | _ -> (body, ctx), eff) } -let find_mutually_recursive_statements thms = +let find_mutually_recursive_statements sigma thms = let n = List.length thms in let inds = List.map (fun (id,(t,impls)) -> - let (hyps,ccl) = decompose_prod_assum t in + let (hyps,ccl) = EConstr.decompose_prod_assum sigma t in let x = (id,(t,impls)) in - let whnf_hyp_hds = map_rel_context_in_env - (fun env c -> EConstr.Unsafe.to_constr (fst (whd_all_stack env Evd.empty (EConstr.of_constr c)))) + let whnf_hyp_hds = EConstr.map_rel_context_in_env + (fun env c -> fst (Reductionops.whd_all_stack env sigma c)) (Global.env()) hyps in let ind_hyps = List.flatten (List.map_i (fun i decl -> let t = RelDecl.get_type decl in - match Constr.kind t with + match EConstr.kind sigma t with | Ind ((kn,_ as ind),u) when let mind = Global.lookup_mind kn in mind.mind_finite <> Decl_kinds.CoFinite -> [ind,x,i] | _ -> - []) 0 (List.rev (List.filter RelDecl.is_local_assum whnf_hyp_hds))) in + []) 0 (List.rev (List.filter Context.Rel.Declaration.is_local_assum whnf_hyp_hds))) in let ind_ccl = - let cclenv = push_rel_context hyps (Global.env()) in - let whnf_ccl,_ = whd_all_stack cclenv Evd.empty (EConstr.of_constr ccl) in - match Constr.kind (EConstr.Unsafe.to_constr whnf_ccl) with + let cclenv = EConstr.push_rel_context hyps (Global.env()) in + let whnf_ccl,_ = whd_all_stack cclenv Evd.empty ccl in + match EConstr.kind sigma whnf_ccl with | Ind ((kn,_ as ind),u) when let mind = Global.lookup_mind kn in Int.equal mind.mind_ntypes n && mind.mind_finite == Decl_kinds.CoFinite -> @@ -163,14 +161,14 @@ let find_mutually_recursive_statements thms = in (finite,guard,None), ordered_inds -let look_for_possibly_mutual_statements = function +let look_for_possibly_mutual_statements sigma = function | [id,(t,impls)] -> (* One non recursively proved theorem *) None,[id,(t,impls)],None | _::_ as thms -> (* More than one statement and/or an explicit decreasing mark: *) (* we look for a common inductive hyp or a common coinductive conclusion *) - let recguard,ordered_inds = find_mutually_recursive_statements thms in + let recguard,ordered_inds = find_mutually_recursive_statements sigma thms in let thms = List.map pi2 ordered_inds in Some recguard,thms, Some (List.map (fun (_,_,i) -> succ i) ordered_inds) | [] -> anomaly (Pp.str "Empty list of theorems.") @@ -377,7 +375,7 @@ let start_proof_univs id ?pl kind sigma ?terminator ?sign c ?init_tac ?(compute_ let rec_tac_initializer finite guard thms snl = if finite then - match List.map (fun (id,(t,_)) -> (id,EConstr.of_constr t)) thms with + match List.map (fun (id,(t,_)) -> (id,t)) thms with | (id,_)::l -> Tactics.mutual_cofix id l 0 | _ -> assert false else @@ -385,11 +383,11 @@ let rec_tac_initializer finite guard thms snl = let nl = match snl with | None -> List.map succ (List.map List.last guard) | Some nl -> nl - in match List.map2 (fun (id,(t,_)) n -> (id,n, EConstr.of_constr t)) thms nl with + in match List.map2 (fun (id,(t,_)) n -> (id,n, t)) thms nl with | (id,n,_)::l -> Tactics.mutual_fix id n l 0 | _ -> assert false -let start_proof_with_initialization kind ctx decl recguard thms snl hook = +let start_proof_with_initialization kind sigma decl recguard thms snl hook = let intro_tac (_, (_, (ids, _))) = Tacticals.New.tclMAP (function | Name id -> Tactics.intro_mustbe_force id @@ -424,16 +422,15 @@ let start_proof_with_initialization kind ctx decl recguard thms snl hook = if List.is_empty other_thms then [] else (* there are several theorems defined mutually *) let body,opaq = retrieve_first_recthm ctx ref in - let subst = Evd.evar_universe_context_subst ctx in - let norm c = Universes.subst_opt_univs_constr subst c in - let body = Option.map norm body in + let norm c = EConstr.to_constr (Evd.from_ctx ctx) c in + let body = Option.map EConstr.of_constr body in let uctx = UState.check_univ_decl ~poly:(pi2 kind) ctx decl in List.map_i (save_remaining_recthms kind norm uctx body opaq) 1 other_thms in let thms_data = (strength,ref,imps)::other_thms_data in List.iter (fun (strength,ref,imps) -> maybe_declare_manual_implicits false ref imps; call_hook (fun exn -> exn) hook strength ref) thms_data in - start_proof_univs id ~pl:decl kind ctx (EConstr.of_constr t) ?init_tac (fun ctx -> mk_hook (hook ctx)) ~compute_guard:guard + start_proof_univs id ~pl:decl kind sigma t ?init_tac (fun ctx -> mk_hook (hook ctx)) ~compute_guard:guard let start_proof_com ?inference_hook kind thms hook = let env0 = Global.env () in @@ -442,22 +439,24 @@ let start_proof_com ?inference_hook kind thms hook = match decl with | None -> Evd.from_env env0, Univdecls.default_univ_decl | Some decl -> - Univdecls.interp_univ_decl_opt env0 (snd decl) in - let evdref = ref evd in - let thms = List.map (fun (sopt,(bl,t)) -> - let impls, ((env, ctx), imps) = interp_context_evars env0 evdref bl in - let t', imps' = interp_type_evars_impls ~impls env evdref t in + Univdecls.interp_univ_decl_opt env0 (snd decl) in + let evd, thms = List.fold_left_map (fun evd (sopt,(bl,t)) -> + let evd, (impls, ((env, ctx), imps)) = interp_context_evars env0 evd bl in + let evd, (t', imps') = interp_type_evars_impls ~impls env evd t in let flags = all_and_fail_flags in let flags = { flags with use_hook = inference_hook } in - evdref := solve_remaining_evars flags env !evdref Evd.empty; + let evd = solve_remaining_evars flags env evd Evd.empty in let ids = List.map RelDecl.get_name ctx in - (compute_proof_name (pi1 kind) sopt, - (EConstr.Unsafe.to_constr (nf_evar !evdref (EConstr.it_mkProd_or_LetIn t' ctx)), - (ids, imps @ lift_implicits (Context.Rel.nhyps ctx) imps')))) - thms in - let recguard,thms,snl = look_for_possibly_mutual_statements thms in - let evd, nf = Evarutil.nf_evars_and_universes !evdref in - let thms = List.map (fun (n, (t, info)) -> (n, (nf t, info))) thms in + (* XXX: The nf_evar is critical !! *) + evd, (compute_proof_name (pi1 kind) sopt, + (Evarutil.nf_evar evd (EConstr.it_mkProd_or_LetIn t' ctx), + (ids, imps @ lift_implicits (Context.Rel.nhyps ctx) imps')))) + evd thms in + let recguard,thms,snl = look_for_possibly_mutual_statements evd thms in + let evd, _nf = Evarutil.nf_evars_and_universes evd in + (* XXX: This nf_evar is critical too!! We are normalizing twice if + you look at the previous lines... *) + let thms = List.map (fun (n, (t, info)) -> (n, (nf_evar evd t, info))) thms in let () = let open Misctypes in if not (decl.univdecl_extensible_instance && decl.univdecl_extensible_constraints) then @@ -470,7 +469,6 @@ let start_proof_com ?inference_hook kind thms hook = in start_proof_with_initialization kind evd decl recguard thms snl hook - (* Saving a proof *) let keep_admitted_vars = ref true diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli index a4854b4a6b..ca92e856bc 100644 --- a/vernac/lemmas.mli +++ b/vernac/lemmas.mli @@ -7,7 +7,6 @@ (************************************************************************) open Names -open Constr open Decl_kinds type 'a declaration_hook @@ -37,11 +36,11 @@ val start_proof_com : goal_kind -> Vernacexpr.proof_expr list -> unit declaration_hook -> unit -val start_proof_with_initialization : +val start_proof_with_initialization : goal_kind -> Evd.evar_map -> Univdecls.universe_decl -> (bool * Proof_global.lemma_possible_guards * unit Proofview.tactic list option) option -> (Id.t (* name of thm *) * - (types (* type of thm *) * (Name.t list (* names to pre-introduce *) * Impargs.manual_explicitation list))) list + (EConstr.types (* type of thm *) * (Name.t list (* names to pre-introduce *) * Impargs.manual_explicitation list))) list -> int list option -> unit declaration_hook -> unit val universe_proof_terminator : diff --git a/vernac/obligations.ml b/vernac/obligations.ml index 181068089e..58e4b00fc7 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -1185,7 +1185,6 @@ let init_program () = Coqlib.check_required_library ["Coq";"Init";"Specif"]; Coqlib.check_required_library ["Coq";"Program";"Tactics"] - let set_program_mode c = if c then if !Flags.program_mode then () diff --git a/vernac/record.ml b/vernac/record.ml index 1cdc538b5b..114b55cb40 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -60,23 +60,25 @@ let _ = optread = (fun () -> !typeclasses_unique); optwrite = (fun b -> typeclasses_unique := b); } -let interp_fields_evars env evars impls_env nots l = +let interp_fields_evars env sigma impls_env nots l = List.fold_left2 - (fun (env, uimpls, params, impls) no ((loc, i), b, t) -> - let t', impl = interp_type_evars_impls env evars ~impls t in - let b' = Option.map (fun x -> fst (interp_casted_constr_evars_impls env evars ~impls x t')) b in + (fun (env, sigma, uimpls, params, impls) no ((loc, i), b, t) -> + let sigma, (t', impl) = interp_type_evars_impls env sigma ~impls t in + let sigma, b' = + Option.cata (fun x -> on_snd (fun x -> Some (fst x)) @@ + interp_casted_constr_evars_impls env sigma ~impls x t') (sigma,None) b in let impls = match i with | Anonymous -> impls - | Name id -> Id.Map.add id (compute_internalization_data env Constrintern.Method (EConstr.to_constr !evars t') impl) impls + | Name id -> Id.Map.add id (compute_internalization_data env Constrintern.Method (EConstr.to_constr sigma t') impl) impls in let d = match b' with | None -> LocalAssum (i,t') | Some b' -> LocalDef (i,b',t') in List.iter (Metasyntax.set_notation_for_interpretation env impls) no; - (EConstr.push_rel d env, impl :: uimpls, d::params, impls)) - (env, [], [], impls_env) nots l + (EConstr.push_rel d env, sigma, impl :: uimpls, d::params, impls)) + (env, sigma, [], [], impls_env) nots l let compute_constructor_level evars env l = List.fold_right (fun d (env, univ) -> @@ -97,10 +99,9 @@ let binders_of_decls = List.map binder_of_decl let typecheck_params_and_fields finite def id poly pl t ps nots fs = let env0 = Global.env () in - let evd, decl = Univdecls.interp_univ_decl_opt env0 pl in - let evars = ref evd in - let _ = - let error bk (loc, name) = + let sigma, decl = Univdecls.interp_univ_decl_opt env0 pl in + let _ = + let error bk (loc, name) = match bk, name with | Default _, Anonymous -> user_err ?loc ~hdr:"record" (str "Record parameters must be named") @@ -112,63 +113,65 @@ let typecheck_params_and_fields finite def id poly pl t ps nots fs = | CLocalPattern (loc,(_,_)) -> Loc.raise ?loc (Stream.Error "pattern with quote not allowed in record parameters.")) ps in - let impls_env, ((env1,newps), imps) = interp_context_evars env0 evars ps in - let typ, sort, template = match t with + let sigma, (impls_env, ((env1,newps), imps)) = interp_context_evars env0 sigma ps in + let sigma, typ, sort, template = match t with | Some t -> let env = EConstr.push_rel_context newps env0 in let poly = match t with | { CAst.v = CSort (Misctypes.GType []) } -> true | _ -> false in - let s = interp_type_evars env evars ~impls:empty_internalization_env t in - let sred = Reductionops.whd_all env !evars s in - (match EConstr.kind !evars sred with + let sigma, s = interp_type_evars env sigma ~impls:empty_internalization_env t in + let sred = Reductionops.whd_all env sigma s in + (match EConstr.kind sigma sred with | Sort s' -> - let s' = EConstr.ESorts.kind !evars s' in + let s' = EConstr.ESorts.kind sigma s' in (if poly then - match Evd.is_sort_variable !evars s' with - | Some l -> evars := Evd.make_flexible_variable !evars ~algebraic:true l; - s, s', true - | None -> s, s', false - else s, s', false) + match Evd.is_sort_variable sigma s' with + | Some l -> + let sigma = Evd.make_flexible_variable sigma ~algebraic:true l in + sigma, s, s', true + | None -> + sigma, s, s', false + else sigma, s, s', false) | _ -> user_err ?loc:(constr_loc t) (str"Sort expected.")) | None -> let uvarkind = Evd.univ_flexible_alg in - let s = Evarutil.evd_comb0 (Evd.new_sort_variable uvarkind) evars in - EConstr.mkSort s, s, true + let sigma, s = Evd.new_sort_variable uvarkind sigma in + sigma, EConstr.mkSort s, s, true in let arity = EConstr.it_mkProd_or_LetIn typ newps in let env_ar = EConstr.push_rel_context newps (EConstr.push_rel (LocalAssum (Name id,arity)) env0) in let assums = List.filter is_local_assum newps in let params = List.map (RelDecl.get_name %> Name.get_id) assums in let ty = Inductive (params,(finite != BiFinite)) in - let impls_env = compute_internalization_env env0 ~impls:impls_env ty [id] [EConstr.to_constr !evars arity] [imps] in - let env2,impls,newfs,data = - interp_fields_evars env_ar evars impls_env nots (binders_of_decls fs) + let impls_env = compute_internalization_env env0 ~impls:impls_env ty [id] [EConstr.to_constr sigma arity] [imps] in + let env2,sigma,impls,newfs,data = + interp_fields_evars env_ar sigma impls_env nots (binders_of_decls fs) in - let evars = - Pretyping.solve_remaining_evars Pretyping.all_and_fail_flags env_ar !evars Evd.empty in - let typ, evars = - let _, univ = compute_constructor_level evars env_ar newfs in + let sigma = + Pretyping.solve_remaining_evars Pretyping.all_and_fail_flags env_ar sigma Evd.empty in + let sigma, typ = + let _, univ = compute_constructor_level sigma env_ar newfs in if not def && (Sorts.is_prop sort || (Sorts.is_set sort && is_impredicative_set env0)) then - typ, evars + sigma, typ else - let evars = Evd.set_leq_sort env_ar evars (Type univ) sort in + let sigma = Evd.set_leq_sort env_ar sigma (Type univ) sort in if Univ.is_small_univ univ && - Option.cata (Evd.is_flexible_level evars) false (Evd.is_sort_variable evars sort) then + Option.cata (Evd.is_flexible_level sigma) false (Evd.is_sort_variable sigma sort) then (* We can assume that the level in aritysort is not constrained and clear it, if it is flexible *) - EConstr.mkSort (Sorts.sort_of_univ univ), - Evd.set_eq_sort env_ar evars (Prop Pos) sort - else typ, evars + Evd.set_eq_sort env_ar sigma (Prop Pos) sort, + EConstr.mkSort (Sorts.sort_of_univ univ) + else sigma, typ in - let evars, nf = Evarutil.nf_evars_and_universes evars in - let newfs = List.map (EConstr.to_rel_decl evars) newfs in - let newps = List.map (EConstr.to_rel_decl evars) newps in - let typ = EConstr.to_constr evars typ in - let ce t = Pretyping.check_evars env0 Evd.empty evars (EConstr.of_constr t) in - let univs = Evd.check_univ_decl ~poly evars decl in - let ubinders = Evd.universe_binders evars in + let sigma, _ = Evarutil.nf_evars_and_universes sigma in + let newfs = List.map (EConstr.to_rel_decl sigma) newfs in + let newps = List.map (EConstr.to_rel_decl sigma) newps in + let typ = EConstr.to_constr sigma typ in + let ce t = Pretyping.check_evars env0 Evd.empty sigma (EConstr.of_constr t) in + let univs = Evd.check_univ_decl ~poly sigma decl in + let ubinders = Evd.universe_binders sigma in List.iter (iter_constr ce) (List.rev newps); List.iter (iter_constr ce) (List.rev newfs); ubinders, univs, typ, template, imps, newps, impls, newfs @@ -430,7 +433,7 @@ let declare_structure finite ubinders univs id idbuild paramimpls params arity t | Monomorphic_const_entry _ -> mie in - let kn = Command.declare_mutual_inductive_with_eliminations mie ubinders [(paramimpls,[])] in + let kn = ComInductive.declare_mutual_inductive_with_eliminations mie ubinders [(paramimpls,[])] in let rsp = (kn,0) in (* This is ind path of idstruc *) let cstr = (rsp,1) in let kinds,sp_projs = declare_projections rsp ctx ~kind binder_name coers ubinders fieldimpls fields in diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib index 8673155e28..f001b572a5 100644 --- a/vernac/vernac.mllib +++ b/vernac/vernac.mllib @@ -11,7 +11,11 @@ Search Indschemes DeclareDef Obligations -Command +ComDefinition +ComAssumption +ComInductive +ComFixpoint +ComProgramFixpoint Classes Record Assumptions diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 161e0c5357..a581043ac1 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -18,7 +18,6 @@ open Tacmach open Constrintern open Prettyp open Printer -open Command open Goptions open Libnames open Globnames @@ -479,6 +478,7 @@ let vernac_definition ~atts discharge kind ((loc,id as lid),pl) def = | Discharge -> Dumpglob.dump_definition lid true "var" | Local | Global -> Dumpglob.dump_definition lid false "def" in + let program_mode = Flags.is_program_mode () in (match def with | ProveBody (bl,t) -> (* local binders, typ *) start_proof_and_print (local, atts.polymorphic, DefinitionBody kind) @@ -489,7 +489,7 @@ let vernac_definition ~atts discharge kind ((loc,id as lid),pl) def = | Some r -> let sigma, env = Pfedit.get_current_context () in Some (snd (Hook.get f_interp_redexp env sigma r)) in - do_definition id (local, atts.polymorphic, kind) pl bl red_option c typ_opt hook) + ComDefinition.do_definition ~program_mode id (local, atts.polymorphic, kind) pl bl red_option c typ_opt hook) let vernac_start_proof ~atts kind l = let local = enforce_locality_exp atts.locality NoDischarge in @@ -520,7 +520,7 @@ let vernac_assumption ~atts discharge kind l nl = List.iter (fun (lid, _) -> if global then Dumpglob.dump_definition lid false "ax" else Dumpglob.dump_definition lid true "var") idl) l; - let status = do_assumptions kind nl l in + let status = ComAssumption.do_assumptions kind nl l in if not status then Feedback.feedback Feedback.AddedAxiom let should_treat_as_cumulative cum poly = @@ -592,18 +592,29 @@ let vernac_inductive ~atts cum lo finite indl = | _ -> user_err Pp.(str "Cannot handle mutually (co)inductive records.") in let indl = List.map unpack indl in - do_mutual_inductive indl is_cumulative atts.polymorphic lo finite + ComInductive.do_mutual_inductive indl is_cumulative atts.polymorphic lo finite let vernac_fixpoint ~atts discharge l = let local = enforce_locality_exp atts.locality discharge in if Dumpglob.dump () then List.iter (fun (((lid,_), _, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; + (* XXX: Switch to the attribute system and match on ~atts *) + let do_fixpoint = if Flags.is_program_mode () then + ComProgramFixpoint.do_fixpoint + else + ComFixpoint.do_fixpoint + in do_fixpoint local atts.polymorphic l let vernac_cofixpoint ~atts discharge l = let local = enforce_locality_exp atts.locality discharge in if Dumpglob.dump () then List.iter (fun (((lid,_), _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; + let do_cofixpoint = if Flags.is_program_mode () then + ComProgramFixpoint.do_cofixpoint + else + ComFixpoint.do_cofixpoint + in do_cofixpoint local atts.polymorphic l let vernac_scheme l = @@ -627,14 +638,14 @@ let vernac_universe ~atts l = user_err ?loc:atts.loc ~hdr:"vernac_universe" (str"Polymorphic universes can only be declared inside sections, " ++ str "use Monomorphic Universe instead"); - do_universe atts.polymorphic l + Declare.do_universe atts.polymorphic l let vernac_constraint ~atts l = if atts.polymorphic && not (Lib.sections_are_opened ()) then user_err ?loc:atts.loc ~hdr:"vernac_constraint" (str"Polymorphic universe constraints can only be declared" ++ str " inside sections, use Monomorphic Constraint instead"); - do_constraint atts.polymorphic l + Declare.do_constraint atts.polymorphic l (**********************) (* Modules *) @@ -831,7 +842,8 @@ let vernac_identity_coercion ~atts id qids qidt = let vernac_instance ~atts abst sup inst props pri = let global = not (make_section_locality atts.locality) in Dumpglob.dump_constraint inst false "inst"; - ignore(Classes.new_instance ~abstract:abst ~global atts.polymorphic sup inst props pri) + let program_mode = Flags.is_program_mode () in + ignore(Classes.new_instance ~program_mode ~abstract:abst ~global atts.polymorphic sup inst props pri) let vernac_context ~atts l = if not (Classes.context atts.polymorphic l) then Feedback.feedback Feedback.AddedAxiom |