diff options
388 files changed, 2646 insertions, 2454 deletions
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 8beeffccac..ae55302d11 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -21,7 +21,7 @@ variables: COMPILER_BLEEDING_EDGE: "4.05.0" CAMLP5_VER_BLEEDING_EDGE: "7.01" - TEST_PACKAGES: "time python" + TIMING_PACKAGES: "time python" COQIDE_PACKAGES: "libgtk2.0-dev libgtksourceview2.0-dev" #COQIDE_PACKAGES_32BIT: "libgtk2.0-dev:i386 libgtksourceview2.0-dev:i386" @@ -58,14 +58,14 @@ before_script: artifacts: name: "$CI_JOB_NAME" paths: - - install + - _install_ci - config/Makefile expire_in: 1 week script: - set -e - echo 'start:coq.config' - - ./configure -prefix "$(pwd)/install" ${EXTRA_CONF} + - ./configure -prefix "$(pwd)/_install_ci" ${EXTRA_CONF} - echo 'end:coq.config' - echo 'start:coq.build' @@ -74,7 +74,7 @@ before_script: - echo 'start:coq.install' - make install - - cp bin/fake_ide install/bin/ + - cp bin/fake_ide _install_ci/bin/ - echo 'end:coq.install' - set +e @@ -110,7 +110,9 @@ before_script: - cd test-suite - make clean # careful with the ending / - - make -j ${NJOBS} BIN=$(readlink -f ../install/bin)/ LIB=$(readlink -f ../install/lib/coq)/ all + - BIN=$(readlink -f ../_install_ci/bin)/ + - LIB=$(readlink -f ../_install_ci/lib/coq)/ + - make -j ${NJOBS} BIN="$BIN" LIB="$LIB" all artifacts: name: "$CI_JOB_NAME.logs" when: on_failure @@ -120,7 +122,7 @@ before_script: .validate-template: &validate-template stage: test script: - - cd install + - cd _install_ci - find lib/coq/ -name '*.vo' -print0 > vofiles - for regexp in 's/.vo//' 's:lib/coq/plugins:Coq:' 's:lib/coq/theories:Coq:' 's:/:.:g'; do sed -z -i "$regexp" vofiles; done - xargs -0 --arg-file=vofiles bin/coqchk -boot -silent -o -m -coqlib lib/coq/ @@ -128,10 +130,10 @@ before_script: .documentation-template: &documentation-template stage: test script: - - ./configure -prefix "$(pwd)/install" ${EXTRA_CONF} - - cp install/lib/coq/tools/coqdoc/coqdoc.sty . + - INSTALLDIR=$(readlink -f _install_ci) + - ./configure -prefix "$INSTALLDIR" ${EXTRA_CONF} + - cp "$INSTALLDIR/lib/coq/tools/coqdoc/coqdoc.sty" . - - INSTALLDIR=$(readlink -f install) - LIB="$INSTALLDIR/lib/coq" # WTF using a newline makes make sigsev # see https://gitlab.com/SkySkimmer/coq/builds/17313312 @@ -145,7 +147,7 @@ before_script: artifacts: name: "$CI_JOB_NAME" paths: - - install/share/doc + - _install_ci/share/doc expire_in: 1 week .ci-template: &ci-template @@ -160,6 +162,7 @@ before_script: - build variables: &ci-template-vars TEST_TARGET: "$CI_JOB_NAME" + EXTRA_PACKAGES: "$TIMING_PACKAGES" build: <<: *build-template @@ -201,7 +204,7 @@ test-suite: dependencies: - build variables: - EXTRA_PACKAGES: "$TEST_PACKAGES" + EXTRA_PACKAGES: "$TIMING_PACKAGES" test-suite:32bit: <<: *test-suite-template @@ -209,7 +212,7 @@ test-suite:32bit: - build:32bit variables: COMPILER: "$COMPILER_32BIT" - EXTRA_PACKAGES: "gcc-multilib $TEST_PACKAGES" + EXTRA_PACKAGES: "gcc-multilib $TIMING_PACKAGES" test-suite:bleeding-edge: <<: *test-suite-template @@ -218,7 +221,7 @@ test-suite:bleeding-edge: variables: COMPILER: "$COMPILER_BLEEDING_EDGE" CAMLP5_VER: "$CAMLP5_VER_BLEEDING_EDGE" - EXTRA_PACKAGES: "$TEST_PACKAGES" + EXTRA_PACKAGES: "$TIMING_PACKAGES" documentation: <<: *documentation-template @@ -258,7 +261,7 @@ ci-color: <<: *ci-template variables: <<: *ci-template-vars - EXTRA_PACKAGES: "subversion" + EXTRA_PACKAGES: "$TIMING_PACKAGES subversion" ci-compcert: <<: *ci-template @@ -268,13 +271,13 @@ ci-coq-dpdgraph: variables: <<: *ci-template-vars EXTRA_OPAM: "ocamlgraph" - EXTRA_PACKAGES: "autoconf" + EXTRA_PACKAGES: "$TIMING_PACKAGES autoconf" ci-coquelicot: <<: *ci-template variables: <<: *ci-template-vars - EXTRA_PACKAGES: "autoconf" + EXTRA_PACKAGES: "$TIMING_PACKAGES autoconf" ci-geocoq: <<: *ci-template @@ -289,13 +292,13 @@ ci-fiat-parsers: <<: *ci-template variables: <<: *ci-template-vars - EXTRA_PACKAGES: "python" + EXTRA_PACKAGES: "$TIMING_PACKAGES" ci-flocq: <<: *ci-template variables: <<: *ci-template-vars - EXTRA_PACKAGES: "autoconf" + EXTRA_PACKAGES: "$TIMING_PACKAGES autoconf" ci-formal-topology: <<: *ci-template @@ -304,7 +307,7 @@ ci-hott: <<: *ci-template variables: <<: *ci-template-vars - EXTRA_PACKAGES: "autoconf" + EXTRA_PACKAGES: "$TIMING_PACKAGES autoconf" ci-iris-coq: <<: *ci-template @@ -319,7 +322,7 @@ ci-sf: <<: *ci-template variables: <<: *ci-template-vars - EXTRA_PACKAGES: "wget" + EXTRA_PACKAGES: "$TIMING_PACKAGES wget" ci-unimath: <<: *ci-template diff --git a/.travis.yml b/.travis.yml index 2d6d9a2a68..b9ea455da6 100644 --- a/.travis.yml +++ b/.travis.yml @@ -136,6 +136,7 @@ matrix: packages: *coqide-packages - os: osx + osx_image: xcode8.3 env: - TEST_TARGET="test-suite" - COMPILER="4.02.3" @@ -143,10 +144,11 @@ matrix: - NATIVE_COMP="no" - COQ_DEST="-local" before_install: - - brew update + - brew update --debug --verbose - brew install opam gnu-time - os: osx + osx_image: xcode8.3 env: - TEST_TARGET="" - COMPILER="4.02.3" @@ -156,7 +158,7 @@ matrix: - EXTRA_CONF="-coqide opt -warn-error" - EXTRA_OPAM="lablgtk-extras" before_install: - - brew update + - brew update --debug --verbose - brew install opam gnu-time gtk+ expat gtksourceview libxml2 gdk-pixbuf python3 - pip3 install macpack before_deploy: diff --git a/API/API.ml b/API/API.ml index c4bcef6f6c..46ad36d36d 100644 --- a/API/API.ml +++ b/API/API.ml @@ -10,9 +10,9 @@ To see such order issue the comand: -``` -bash -c 'for i in kernel intf library engine pretyping interp proofs parsing printing tactics vernac stm toplevel; do echo -e "\n## $i files" && cat ${i}/${i}.mllib; done && echo -e "\n## highparsing files" && cat parsing/highparsing.mllib' > API/link -``` + ``` + bash -c 'for i in kernel intf library engine pretyping interp proofs parsing printing tactics vernac stm toplevel; do echo -e "\n## $i files" && cat ${i}/${i}.mllib; done > API/link + ``` *) (******************************************************************************) @@ -162,6 +162,7 @@ module Indrec = Indrec (* module Cases *) module Pretyping = Pretyping module Unification = Unification +module Univdecls = Univdecls (******************************************************************************) (* interp *) (******************************************************************************) @@ -223,6 +224,9 @@ module Pcoq = Pcoq module Egramml = Egramml (* Egramcoq *) +module G_vernac = G_vernac +module G_proofs = G_proofs + (******************************************************************************) (* Tactics *) (******************************************************************************) @@ -276,9 +280,3 @@ module Vernacentries = Vernacentries (******************************************************************************) module Vernac_classifier = Vernac_classifier module Stm = Stm - -(******************************************************************************) -(* Highparsing *) -(******************************************************************************) -module G_vernac = G_vernac -module G_proofs = G_proofs diff --git a/API/API.mli b/API/API.mli index 8b0bef48c9..ea4a1ceb26 100644 --- a/API/API.mli +++ b/API/API.mli @@ -10,7 +10,7 @@ in Coq. To see such order issue the comand: ``` - bash -c 'for i in kernel intf library engine pretyping interp proofs parsing printing tactics vernac stm toplevel; do echo -e "\n## $i files" && cat ${i}/${i}.mllib; done && echo -e "\n## highparsing files" && cat parsing/highparsing.mllib' > API/link + bash -c 'for i in kernel intf library engine pretyping interp proofs parsing printing tactics vernac stm toplevel; do echo -e "\n## $i files" && cat ${i}/${i}.mllib; done > API/link ``` Note however that files in intf/ are located manually now as their @@ -1648,6 +1648,14 @@ sig type sort_info = Names.Name.t Loc.located list type glob_sort = sort_info glob_sort_gen + type ('a, 'b) gen_universe_decl = { + univdecl_instance : 'a; (* Declared universes *) + univdecl_extensible_instance : bool; (* Can new universes be added *) + univdecl_constraints : 'b; (* Declared constraints *) + univdecl_extensible_constraints : bool (* Can new constraints be added *) } + + type glob_constraint = glob_level * Univ.constraint_type * glob_level + type case_style = Term.case_style = | LetStyle | IfStyle @@ -2300,7 +2308,7 @@ sig val universe_context_set : evar_map -> Univ.ContextSet.t val evar_ident : evar -> evar_map -> Names.Id.t option val extract_all_conv_pbs : evar_map -> evar_map * evar_constraint list - val universe_context : ?names:(Names.Id.t Loc.located) list -> evar_map -> + val universe_context : names:(Names.Id.t Loc.located) list -> extensible:bool -> evar_map -> (Names.Id.t * Univ.Level.t) list * Univ.UContext.t val nf_constraints : evar_map -> evar_map val from_ctx : UState.t -> evar_map @@ -2461,7 +2469,6 @@ sig constr_expr list list * local_binder_expr list list - type typeclass_constraint = (Names.Name.t Loc.located * Names.Id.t Loc.located list option) * Decl_kinds.binding_kind * constr_expr type constr_pattern_expr = constr_expr end @@ -2763,6 +2770,7 @@ sig val pr_evar_info : Evd.evar_info -> Pp.t val print_constr : EConstr.constr -> Pp.t + val pr_sort_family : Sorts.family -> Pp.t (** [dependent m t] tests whether [m] is a subterm of [t] *) val dependent : Evd.evar_map -> EConstr.constr -> EConstr.constr -> bool @@ -2810,6 +2818,8 @@ sig val print_constr_env : Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t val clear_named_body : Names.Id.t -> Environ.env -> Environ.env val is_Prop : Evd.evar_map -> EConstr.constr -> bool + val is_Set : Evd.evar_map -> EConstr.constr -> bool + val is_Type : Evd.evar_map -> EConstr.constr -> bool val is_global : Evd.evar_map -> Globnames.global_reference -> EConstr.constr -> bool val eq_constr : Evd.evar_map -> EConstr.constr -> EConstr.constr -> bool @@ -3660,7 +3670,7 @@ sig type lname = Names.Name.t Loc.located type lident = Names.Id.t Loc.located type opacity_flag = - | Opaque of lident list option + | Opaque | Transparent type locality_flag = bool type inductive_kind = @@ -3673,7 +3683,7 @@ sig | VtProofStep of proof_step | VtProofMode of string | VtQuery of vernac_part_of_script * Feedback.route_id - | VtStm of vernac_control * vernac_part_of_script + | VtBack of vernac_part_of_script * Stateid.t | VtUnknown and vernac_qed_type = | VtKeep @@ -3682,10 +3692,6 @@ sig and vernac_start = string * opacity_guarantee * Names.Id.t list and vernac_sideff_type = Names.Id.t list and vernac_part_of_script = bool - and vernac_control = - | VtWait - | VtJoinDocument - | VtBack of Stateid.t and opacity_guarantee = | GuaranteesOpacity | Doesn'tGuaranteeOpacity @@ -3705,6 +3711,10 @@ sig type obsolete_locality = bool + type universe_decl_expr = (lident list, Misctypes.glob_constraint list) gen_universe_decl + + type ident_decl = lident * universe_decl_expr option + type lstring type 'a with_coercion = coercion_flag * 'a type scope_name = string @@ -3722,9 +3732,7 @@ sig | Constructors of constructor_expr list | RecordDecl of lident option * local_decl_expr with_instance with_priority with_notation list - type plident = lident * lident list option - - type inductive_expr = plident with_coercion * Constrexpr.local_binder_expr list * Constrexpr.constr_expr option * inductive_kind * constructor_list_or_record_decl_expr + type inductive_expr = ident_decl with_coercion * Constrexpr.local_binder_expr list * Constrexpr.constr_expr option * inductive_kind * constructor_list_or_record_decl_expr type syntax_modifier = | SetItemLevel of string list * Extend.production_level @@ -3738,18 +3746,20 @@ sig type class_rawexpr = FunClass | SortClass | RefClass of reference or_by_notation + type typeclass_constraint = (Names.Name.t Loc.located * universe_decl_expr option) * Decl_kinds.binding_kind * constr_expr + type definition_expr = | ProveBody of local_binder_expr list * constr_expr | DefineBody of local_binder_expr list * Genredexpr.raw_red_expr option * constr_expr * constr_expr option type proof_expr = - plident option * (local_binder_expr list * constr_expr) + ident_decl option * (local_binder_expr list * constr_expr) type proof_end = | Admitted | Proved of opacity_flag * lident option - type fixpoint_expr = plident * (Names.Id.t Loc.located option * Constrexpr.recursion_order_expr) * Constrexpr.local_binder_expr list * Constrexpr.constr_expr * Constrexpr.constr_expr option + type fixpoint_expr = ident_decl * (Names.Id.t Loc.located option * Constrexpr.recursion_order_expr) * Constrexpr.local_binder_expr list * Constrexpr.constr_expr * Constrexpr.constr_expr option type cofixpoint_expr @@ -3767,7 +3777,6 @@ sig type option_value type showable type bullet - type stm_vernac type comment type register_kind type locatable @@ -3817,7 +3826,7 @@ sig | VernacTimeout of int * vernac_expr | VernacFail of vernac_expr | VernacSyntaxExtension of - obsolete_locality * (lstring * syntax_modifier list) + bool * obsolete_locality * (lstring * syntax_modifier list) | VernacOpenCloseScope of obsolete_locality * (bool * scope_name) | VernacDelimiters of scope_name * string option | VernacBindScope of scope_name * class_rawexpr list @@ -3828,12 +3837,12 @@ sig scope_name option | VernacNotationAddFormat of string * string * string | VernacDefinition of - (Decl_kinds.locality option * Decl_kinds.definition_object_kind) * plident * definition_expr + (Decl_kinds.locality option * Decl_kinds.definition_object_kind) * ident_decl * definition_expr | VernacStartTheoremProof of Decl_kinds.theorem_kind * proof_expr list | VernacEndProof of proof_end | VernacExactProof of Constrexpr.constr_expr | VernacAssumption of (Decl_kinds.locality option * Decl_kinds.assumption_object_kind) * - inline * (plident list * Constrexpr.constr_expr) with_coercion list + inline * (ident_decl list * Constrexpr.constr_expr) with_coercion list | VernacInductive of cumulative_inductive_parsing_flag * Decl_kinds.private_flag * inductive_flag * (inductive_expr * decl_notation list) list | VernacFixpoint of Decl_kinds.locality option * (fixpoint_expr * decl_notation list) list @@ -3857,7 +3866,7 @@ sig | VernacInstance of bool * Constrexpr.local_binder_expr list * - Constrexpr.typeclass_constraint * + typeclass_constraint * (bool * Constrexpr.constr_expr) option * hint_info_expr | VernacContext of Constrexpr.local_binder_expr list @@ -3919,7 +3928,6 @@ sig | VernacLocate of locatable | VernacRegister of lident * register_kind | VernacComments of comment list - | VernacStm of stm_vernac | VernacGoal of Constrexpr.constr_expr | VernacAbort of lident option | VernacAbortAll @@ -3949,7 +3957,7 @@ sig | SelectAll and vernac_classification = vernac_type * vernac_when and one_inductive_expr = - plident * Constrexpr.local_binder_expr list * Constrexpr.constr_expr option * constructor_expr list + ident_decl * Constrexpr.local_binder_expr list * Constrexpr.constr_expr option * constructor_expr list end (* XXX: end manual intf move *) @@ -4046,7 +4054,6 @@ sig val understand : ?flags:inference_flags -> ?expected_type:typing_constraint -> Environ.env -> Evd.evar_map -> Glob_term.glob_constr -> Constr.t Evd.in_evar_universe_context val check_evars : Environ.env -> Evd.evar_map -> Evd.evar_map -> EConstr.constr -> unit - val interp_elimination_sort : Misctypes.glob_sort -> Sorts.family val register_constr_interp0 : ('r, 'g, 't) Genarg.genarg_type -> (Glob_term.unbound_ltac_var_map -> Environ.env -> Evd.evar_map -> EConstr.types -> 'g -> EConstr.constr * Evd.evar_map) -> unit @@ -4087,6 +4094,18 @@ sig Environ.env -> Evd.evar_map -> ?flags:unify_flags -> EConstr.constr * EConstr.constr -> Evd.evar_map * EConstr.constr end +module Univdecls : +sig + type universe_decl = + (Names.Id.t Loc.located list, Univ.Constraint.t) Misctypes.gen_universe_decl + + val interp_univ_decl : Environ.env -> Vernacexpr.universe_decl_expr -> + Evd.evar_map * universe_decl + val interp_univ_decl_opt : Environ.env -> Vernacexpr.universe_decl_expr option -> + Evd.evar_map * universe_decl + val default_univ_decl : universe_decl +end + (************************************************************************) (* End of modules from pretyping/ *) (************************************************************************) @@ -4142,6 +4161,7 @@ sig val wit_global : (Libnames.reference, Globnames.global_reference Loc.located Misctypes.or_var, Globnames.global_reference) Genarg.genarg_type val wit_ident : Names.Id.t Genarg.uniform_genarg_type val wit_integer : int Genarg.uniform_genarg_type + val wit_sort_family : (Sorts.family, unit, unit) Genarg.genarg_type val wit_constr : (Constrexpr.constr_expr, Tactypes.glob_constr_and_expr, EConstr.constr) Genarg.genarg_type val wit_open_constr : (Constrexpr.constr_expr, Tactypes.glob_constr_and_expr, EConstr.constr) Genarg.genarg_type val wit_intro_pattern : (Constrexpr.constr_expr Misctypes.intro_pattern_expr Loc.located, Tactypes.glob_constr_and_expr Misctypes.intro_pattern_expr Loc.located, Tactypes.intro_pattern) Genarg.genarg_type @@ -4484,12 +4504,11 @@ sig type proof_terminator type lemma_possible_guards - type universe_binders type closed_proof = proof_object * proof_terminator val make_terminator : (proof_ending -> unit) -> proof_terminator val start_dependent_proof : - Names.Id.t -> ?pl:universe_binders -> Decl_kinds.goal_kind -> + Names.Id.t -> ?pl:Univdecls.universe_decl -> Decl_kinds.goal_kind -> Proofview.telescope -> proof_terminator -> unit val with_current_proof : (unit Proofview.tactic -> Proof.proof -> Proof.proof * 'a) -> 'a @@ -4703,7 +4722,7 @@ sig type coq_parsable - val parsable : ?file:string -> char Stream.t -> coq_parsable + val parsable : ?file:Loc.source -> char Stream.t -> coq_parsable val action : 'a -> action val entry_create : string -> 'a entry val entry_parse : 'a entry -> coq_parsable -> 'a @@ -4773,6 +4792,7 @@ sig val global : reference Gram.entry val universe_level : glob_level Gram.entry val sort : glob_sort Gram.entry + val sort_family : Sorts.family Gram.entry val pattern : cases_pattern_expr Gram.entry val constr_pattern : constr_expr Gram.entry val lconstr_pattern : constr_expr Gram.entry @@ -4849,6 +4869,23 @@ sig end +module G_vernac : +sig + + val def_body : Vernacexpr.definition_expr Pcoq.Gram.entry + val section_subset_expr : Vernacexpr.section_subset_expr Pcoq.Gram.entry + val query_command : (Vernacexpr.goal_selector option -> Vernacexpr.vernac_expr) Pcoq.Gram.entry + +end + +module G_proofs : +sig + + val hint : Vernacexpr.hints_expr Pcoq.Gram.entry + val hint_proof_using : 'a Pcoq.Gram.entry -> 'a option -> 'a option + +end + (************************************************************************) (* End of modules from parsing/ *) (************************************************************************) @@ -5333,7 +5370,7 @@ sig val lemInv_clause : Misctypes.quantified_hypothesis -> EConstr.constr -> Names.Id.t list -> unit Proofview.tactic val add_inversion_lemma_exn : - Names.Id.t -> Constrexpr.constr_expr -> Misctypes.glob_sort -> bool -> (Names.Id.t -> unit Proofview.tactic) -> + Names.Id.t -> Constrexpr.constr_expr -> Sorts.family -> bool -> (Names.Id.t -> unit Proofview.tactic) -> unit end @@ -5525,7 +5562,7 @@ sig val mk_hook : (Decl_kinds.locality -> Globnames.global_reference -> 'a) -> 'a declaration_hook - val start_proof : Names.Id.t -> ?pl:Proof_global.universe_binders -> Decl_kinds.goal_kind -> Evd.evar_map -> + val start_proof : Names.Id.t -> ?pl:Univdecls.universe_decl -> Decl_kinds.goal_kind -> Evd.evar_map -> ?terminator:(Proof_global.lemma_possible_guards -> unit declaration_hook -> Proof_global.proof_terminator) -> ?sign:Environ.named_context_val -> EConstr.types -> ?init_tac:unit Proofview.tactic -> ?compute_guard:Proof_global.lemma_possible_guards -> @@ -5601,7 +5638,7 @@ sig type structured_fixpoint_expr = { fix_name : Id.t; - fix_univs : lident list option; + fix_univs : universe_decl_expr option; fix_annot : Id.t Loc.located option; fix_binders : local_binder_expr list; fix_body : constr_expr option; @@ -5610,7 +5647,7 @@ sig type structured_one_inductive_expr = { ind_name : Id.t; - ind_univs : lident list option; + ind_univs : universe_decl_expr option; ind_arity : constr_expr; ind_lc : (Id.t * constr_expr) list } @@ -5626,7 +5663,7 @@ sig (Vernacexpr.one_inductive_expr * Vernacexpr.decl_notation list) list -> Decl_kinds.cumulative_inductive_flag -> Decl_kinds.polymorphic -> Decl_kinds.private_flag -> Decl_kinds.recursivity_kind -> unit - val do_definition : Names.Id.t -> Decl_kinds.definition_kind -> Vernacexpr.lident list option -> + 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 @@ -5639,7 +5676,7 @@ sig val interp_fixpoint : structured_fixpoint_expr list -> Vernacexpr.decl_notation list -> - recursive_preentry * Vernacexpr.lident list option * UState.t * + recursive_preentry * Univdecls.universe_decl * UState.t * (EConstr.rel_context * Impargs.manual_implicits * int option) list val extract_mutual_inductive_declaration_components : @@ -5667,7 +5704,7 @@ sig ?refine:bool -> Decl_kinds.polymorphic -> Constrexpr.local_binder_expr list -> - Constrexpr.typeclass_constraint -> + Vernacexpr.typeclass_constraint -> (bool * Constrexpr.constr_expr) option -> ?generalize:bool -> ?tac:unit Proofview.tactic -> @@ -5738,28 +5775,3 @@ end (************************************************************************) (* End of modules from stm/ *) (************************************************************************) - -(************************************************************************) -(* Modules from highparsing/ *) -(************************************************************************) - -module G_vernac : -sig - - val def_body : Vernacexpr.definition_expr Pcoq.Gram.entry - val section_subset_expr : Vernacexpr.section_subset_expr Pcoq.Gram.entry - val query_command : (Vernacexpr.goal_selector option -> Vernacexpr.vernac_expr) Pcoq.Gram.entry - -end - -module G_proofs : -sig - - val hint : Vernacexpr.hints_expr Pcoq.Gram.entry - val hint_proof_using : 'a Pcoq.Gram.entry -> 'a option -> 'a option - -end - -(************************************************************************) -(* End of modules from highparsing/ *) -(************************************************************************) @@ -13,8 +13,16 @@ Tactics profiling, and "Set NativeCompute Profile Filename" customizes the profile filename. -Changes from 8.6.1 to 8.7+beta -============================== +Changes from 8.7+beta1 to 8.7.0 +=============================== + +Tools + +- In CoqIDE, the "Compile Buffer" command takes account of flags in + _CoqProject or other project file. + +Changes from 8.6.1 to 8.7+beta1 +=============================== Tactics diff --git a/COMPATIBILITY b/COMPATIBILITY index 78dfabaa3e..b5fed7f018 100644 --- a/COMPATIBILITY +++ b/COMPATIBILITY @@ -5,6 +5,10 @@ Potential sources of incompatibilities between Coq V8.6 and V8.7 error rather than a warning when the superfluous name is already in use. The easy fix is to remove the superfluous name. +- Proofs ending in "Qed exporting ident, .., ident" are not supported + anymore. Constants generated during `abstract` are kept private to the + local environment. + Potential sources of incompatibilities between Coq V8.5 and V8.6 ---------------------------------------------------------------- diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 05f21895eb..c935b6b140 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -26,7 +26,7 @@ Documentation for getting started with the Coq sources is located in various fil Please make pull requests against the `master` branch. -It's helpful to run the Coq test suite with `make test-suite` before submitting your change. Travis CI runs this test suite and a much larger one including external Coq developments on every pull request, but these results take significantly longer to come back (on the order of a few hours). Running the test suite locally will take somewhere around 10-15 minutes. +It's helpful to run the Coq test suite with `make test-suite` before submitting your change. Travis CI runs this test suite and a much larger one including external Coq developments on every pull request, but these results take significantly longer to come back (on the order of a few hours). Running the test suite locally will take somewhere around 10-15 minutes. Refer to [`dev/ci/README.md`](/dev/ci/README.md#information-for-developers) for more information on Travis CI tests. Don't be alarmed if the pull request process takes some time. It can take a few days to get feedback, approval on the final changes, and then a merge. Coq doesn't release new versions very frequently so it can take a few months for your change to land in a released version. That said, you can start using the latest Coq `master` branch to take advantage of all the new features, improvements, and fixes. @@ -50,6 +50,8 @@ There are many useful ways to contribute to the Coq ecosystem that don't involve Tutorials to teach Coq, and especially to teach particular advanced features, would be much appreciated. Some tutorials are listed on the [Coq website](https://coq.inria.fr/documentation). If you would like to add a link to this list, please make a pull request against the Coq website repository at https://github.com/coq/www. +External plugins / libraries contribute to create a successful ecosystem around Coq. If your external development is mature enough, you may consider submitting it for addition to our CI tests. Refer to [`dev/ci/README.md`](/dev/ci/README.md) for more information. + Ask and answer questions on [Stack Exchange](https://stackexchange.com/filters/299857/questions-tagged-coq-on-stackexchange-sites) which has a helpful community of Coq users. Hang out on the Coq IRC channel, `irc://irc.freenode.net/#coq`, and help answer questions. @@ -7,7 +7,10 @@ The "Coq proof assistant" was jointly developed by associated to CNRS and university Paris Sud (since Sep. 1997), - Laboratoire d'Informatique de l'Ecole Polytechnique (LIX) associated to CNRS and Ecole Polytechnique (since Jan. 2003). -- Laboratoire PPS associated to CNRS and university Paris 7 (since Jan. 2009). +- Laboratoire PPS associated to CNRS and University Paris Diderot + (Jan. 2009 - Dec. 2015). +- Institut de Recherche en Informatique Fondamentale (IRIF), + associated to CNRS and University Paris Diderot (since Jan. 2016). All files of the "Coq proof assistant" in directories or sub-directories of @@ -15,8 +18,8 @@ All files of the "Coq proof assistant" in directories or sub-directories of scripts states tactics test-suite theories tools toplevel are distributed under the terms of the GNU Lesser General Public License -Version 2.1 (see file LICENSE). These files are COPYRIGHT 1999-2010, -The Coq development team, CNRS, INRIA and Université Paris Sud. +Version 2.1 (see file LICENSE). These files are COPYRIGHT 1999-2017, +The Coq development team, INRIA, CNRS, LIX, LRI, PPS. Files from the directory doc are distributed as indicated in file doc/LICENCE. @@ -37,8 +40,8 @@ plugins/firstorder plugins/fourier developed by Loïc Pottier (INRIA-Lemme, 2001) plugins/funind - developed by Pierre Courtieu (INRIA-Lemme, 2003-2004, CNAM, 2004-2008), - Julien Forest (INRIA-Everest, 2006, CNAM, 2007-2008) + developed by Pierre Courtieu (INRIA-Lemme, 2003-2004, CNAM, 2006-now), + Julien Forest (INRIA-Everest, 2006, CNAM, 2007-2008, ENSIIE, 2008-now) and Yves Bertot (INRIA-Marelle, 2005-2006) plugins/omega developed by Pierre Crégut (France Telecom R&D, 1996) @@ -60,7 +63,7 @@ plugins/ssrmatching plugins/subtac developed by Matthieu Sozeau (LRI, 2005-2008) plugins/micromega - developed by Frédéric Besson (IRISA/INRIA, 2006-2008), with some + developed by Frédéric Besson (IRISA/INRIA, 2006-now), with some extensions by Evgeny Makarov (INRIA, 2007); sum-of-squares solver and interface to the csdp solver uses code from John Harrison (University of Cambridge, 1998) @@ -94,32 +97,41 @@ of the Coq Proof assistant during the indicated time: Bruno Barras (INRIA, 1995-now) Yves Bertot (INRIA, 2000-now) - Pierre Boutillier (INRIA-PPS, 2010-now) + Pierre Boutillier (INRIA-PPS, 2010-2015) Xavier Clerc (INRIA, 2012-2014) + Tej Chajed (MIT, 2016-now) Jacek Chrzaszcz (LRI, 1998-2003) Thierry Coquand (INRIA, 1985-1989) Pierre Corbineau (LRI, 2003-2005, Nijmegen, 2005-2008, Grenoble 1, 2008-2011) Cristina Cornes (INRIA, 1993-1996) Yann Coscoy (INRIA Sophia-Antipolis, 1995-1996) + Pierre Courtieu (CNAM, 2006-now) David Delahaye (INRIA, 1997-2002) Maxime Dénès (INRIA, 2013-now) - Daniel de Rauglaudre (INRIA, 1996-1998) + Daniel de Rauglaudre (INRIA, 1996-1998, 2012, 2016) Olivier Desmettre (INRIA, 2001-2003) Gilles Dowek (INRIA, 1991-1994) Amy Felty (INRIA, 1993) Jean-Christophe Filliâtre (ENS Lyon, 1994-1997, LRI, 1997-2008) + Emilio Jesús Gallego Arias (MINES ParisTech 2015-now) + Gaetan Gilbert (INRIA-CoqHoTT 2016-now) Eduardo Giménez (ENS Lyon, 1993-1996, INRIA, 1997-1998) Stéphane Glondu (INRIA-PPS, 2007-2013) Benjamin Grégoire (INRIA, 2003-2011) + Jason Gross (MIT 2013-now) Hugo Herbelin (INRIA, 1996-now) Sébastien Hinderer (INRIA, 2014) Gérard Huet (INRIA, 1985-1997) + Matej Košík (INRIA, 2015-2017) Pierre Letouzey (LRI, 2000-2004, PPS, 2005-2008, INRIA-PPS, 2009-now) Patrick Loiseleur (Paris Sud, 1997-1999) Evgeny Makarov (INRIA, 2007) + Gregory Malecha (Harvard University 2013-2015, + University of California, San Diego 2016) + Cyprien Mangin (INRIA-IRIF, 2015-now) Pascal Manoury (INRIA, 1993) - Micaela Mayero (INRIA, 1997-2002) Claude Marché (INRIA, 2003-2004 & LRI, 2004) + Micaela Mayero (INRIA, 1997-2002) Guillaume Melquiond (INRIA, 2009-now) Benjamin Monate (LRI, 2003) César Muñoz (INRIA, 1994-1995) @@ -129,7 +141,8 @@ of the Coq Proof assistant during the indicated time: Catherine Parent-Vigouroux (ENS Lyon, 1992-1995) Christine Paulin-Mohring (INRIA, 1985-1989, ENS Lyon, 1989-1997, LRI, 1997-2006) - Pierre-Marie Pédrot (INRIA-PPS, 2011-now) + Pierre-Marie Pédrot (INRIA-PPS, 2011-2015, INRIA-CoqHoTT 2015-2016, + University of Ljubljana 2016-2017) Matthias Puech (INRIA-Bologna, 2008-2011) Yann Régis-Gianas (INRIA-PPS, 2009-now) Clément Renard (INRIA, 2001-2004) @@ -138,9 +151,15 @@ of the Coq Proof assistant during the indicated time: Vincent Siles (INRIA, 2007) Élie Soubiran (INRIA, 2007-2010) Matthieu Sozeau (INRIA, 2005-now) - Arnaud Spiwack (INRIA, 2006-now) + Arnaud Spiwack (INRIA-LIX-Chalmers University, 2006-2010, + INRIA, 2011-2014, MINES ParisTech 2014-2015, + Tweag/IO 2015-now) + Paul Steckler (MIT 2016-now) Enrico Tassi (INRIA, 2011-now) + Amin Timany (Katholieke Universiteit Leuven, 2017) Benjamin Werner (INRIA, 1989-1994) + Nickolai Zeldovich (MIT 2014-2016) + Théo Zimmermann (INRIA-IRIF, 2015-now) *************************************************************************** INRIA refers to: @@ -228,6 +228,32 @@ package "stm" ( ) +package "API" ( + + description = "Coq API" + version = "8.7" + + requires = "coq.stm" + directory = "API" + + archive(byte) = "API.cma" + archive(native) = "API.cmxa" + +) + +package "ltac" ( + + description = "Coq LTAC Plugin" + version = "8.7" + + requires = "coq.API" + directory = "plugins/ltac" + + archive(byte) = "ltac_plugin.cmo" + archive(native) = "ltac_plugin.cmx" + +) + package "toplevel" ( description = "Coq Toplevel" @@ -254,6 +280,7 @@ package "idetop" ( ) +# XXX Depends on way less than toplevel package "ide" ( description = "Coq IDE Libraries" @@ -267,44 +294,3 @@ package "ide" ( archive(native) = "ide.cmxa" ) - -# XXX: Remove the dependency on toplevel (due to Coqinit use for compat flags) -package "highparsing" ( - - description = "Coq Extra Parsing" - version = "8.7" - - requires = "coq.toplevel" - directory = "parsing" - - archive(byte) = "highparsing.cma" - archive(native) = "highparsing.cmxa" - -) - -# XXX: API should depend only on stm. -package "API" ( - - description = "Coq API" - version = "8.7" - - requires = "coq.highparsing" - directory = "API" - - archive(byte) = "API.cma" - archive(native) = "API.cmxa" - -) - -package "ltac" ( - - description = "Coq LTAC Plugin" - version = "8.7" - - requires = "coq.API" - directory = "plugins/ltac" - - archive(byte) = "ltac_plugin.cmo" - archive(native) = "ltac_plugin.cmx" - -) @@ -54,6 +54,7 @@ FIND_SKIP_DIRS:='(' \ -name "$${GIT_DIR}" -o \ -name '_build' -o \ -name '_build_ci' -o \ + -name '_install_ci' -o \ -name 'user-contrib' -o \ -name 'coq-makefile' -o \ -name '.opamcache' -o \ diff --git a/Makefile.common b/Makefile.common index ccbe9261ef..4d63b08e2b 100644 --- a/Makefile.common +++ b/Makefile.common @@ -105,7 +105,7 @@ BYTERUN:=$(addprefix kernel/byterun/, \ CORECMA:=lib/clib.cma lib/lib.cma kernel/kernel.cma intf/intf.cma library/library.cma \ engine/engine.cma pretyping/pretyping.cma interp/interp.cma proofs/proofs.cma \ parsing/parsing.cma printing/printing.cma tactics/tactics.cma vernac/vernac.cma \ - parsing/highparsing.cma stm/stm.cma toplevel/toplevel.cma API/API.cma + stm/stm.cma toplevel/toplevel.cma API/API.cma TOPLOOPCMA:=stm/proofworkertop.cma stm/tacworkertop.cma stm/queryworkertop.cma diff --git a/Makefile.dev b/Makefile.dev index b0299bd160..dc4ded3977 100644 --- a/Makefile.dev +++ b/Makefile.dev @@ -116,12 +116,11 @@ tactics: tactics/tactics.cma interp: interp/interp.cma parsing: parsing/parsing.cma pretyping: pretyping/pretyping.cma -highparsing: parsing/highparsing.cma stm: stm/stm.cma toplevel: toplevel/toplevel.cma .PHONY: lib kernel byterun library proofs tactics interp parsing pretyping API -.PHONY: engine highparsing stm toplevel +.PHONY: engine stm toplevel ###################### ### 3) theories files diff --git a/Makefile.doc b/Makefile.doc index dd7717359e..0c3b701497 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -218,13 +218,9 @@ doc/refman/html/index.html: doc/refman/Reference-Manual.html $(REFMANPNGFILES) \ @touch $(INDEXES) (cd doc/common/styles/html/$(HTMLSTYLE);\ for f in `find . -name \*.css`; do \ - install -m 644 -D $$f ../../../../refman/html/$$f;\ + $(MKDIR) $$(dirname ../../../../refman/html/$$f);\ + $(INSTALLLIB) $$f ../../../../refman/html/$$f;\ done) - (cd doc/common/styles/html/$(HTMLSTYLE);\ - for f in `find . -name coqdoc.css -o -name style.css`; do \ - install -m 644 -D $$f ../../../../refman/html/;\ - done) - install -m 644 doc/common/styles/html/$(HTMLSTYLE)/*.css doc/refman/html refman-quick: (cd doc/refman;\ @@ -391,8 +387,11 @@ install-doc-meta: install-doc-html: $(MKDIR) $(addprefix $(FULLDOCDIR)/html/, refman stdlib faq) - $(INSTALLLIB) doc/refman/html/* $(FULLDOCDIR)/html/refman - $(INSTALLLIB) doc/stdlib/html/* $(FULLDOCDIR)/html/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 @@ -470,7 +469,7 @@ OCAMLDOC_MLLIBD = $(OCAMLFIND) ocamldoc -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) - ml-doc: $(OCAMLFIND) ocamldoc -charset utf-8 -html -rectypes -I +threads $(MLINCLUDES) $(COQIDEFLAGS) -d $(OCAMLDOCDIR) $(MLSTATICFILES) -parsing/parsing.dot : | parsing/parsing.mllib.d parsing/highparsing.mllib.d +parsing/parsing.dot : | parsing/parsing.mllib.d $(OCAMLDOC_MLLIBD) grammar/grammar.dot : | grammar/grammar.mllib.d diff --git a/Makefile.install b/Makefile.install index 85ffc93d51..4800f8f3fa 100644 --- a/Makefile.install +++ b/Makefile.install @@ -87,7 +87,6 @@ install-tools: $(MKDIR) $(FULLBINDIR) # recopie des fichiers de style pour coqide $(MKDIR) $(FULLCOQLIB)/tools/coqdoc - touch $(FULLCOQLIB)/tools/coqdoc/coqdoc.sty $(FULLCOQLIB)/tools/coqdoc/coqdoc.css # to have the mode according to umask (bug #1715) $(INSTALLLIB) tools/coqdoc/coqdoc.css tools/coqdoc/coqdoc.sty $(FULLCOQLIB)/tools/coqdoc $(INSTALLBIN) $(TOOLS) $(FULLBINDIR) diff --git a/README.ci.md b/README.ci.md deleted file mode 100644 index cf9da50941..0000000000 --- a/README.ci.md +++ /dev/null @@ -1,116 +0,0 @@ -**WARNING:** This document is a work in progress and intended as a RFC. -If you are not a Coq Developer, don't follow these instructions yet. - -Introduction -============ - -As of 2017, Coq's Git repository includes a `.travis.yml` file, a -`.gitlab-ci.yml` file, and supporting scripts, that enable lightweight -Continuous Integration (CI) tests to be run on clones of that repository stored -at Github or on a GitLab instance, respectively. This affords two benefits. - -First, it allows developers working on Coq itself to perform CI on their own -Git remotes, thereby enabling them to catch and fix problems with their -proposed changes before submitting pull requests to Coq itself. This in turn -reduces the risk of a faulty PR being opened against the official Coq -repository. - -Secondly, it allows developers working on a library dependent on Coq to have -that library included in the Travis CI tests invoked by the official Coq -repository on GitHub. - -(More comprehensive testing than is provided by the Travis CI and GitLab CI -integration is the responsibility of Coq's [Jenkins CI -server](https://ci.inria.fr/coq/) see, [XXX: add document] for instructions on -how to add your development to Jenkins.) - -How to submit your library for inclusion in Coq's Travis CI builds -================================================================== - -CI provides a convenient way to perform testing of Coq changes -versus a set of curated libraries. - -Are you an author of a Coq library who would be interested in having -the latest Coq changes validated against it? - -If so, all you need to do is: - -1. Put your library in a public repository tracking the `master` - branch of Coq's Git repository. -2. Make sure that your development builds in less than 35 minutes. -3. Submit a PR adding your development. -4. ? -5. Profit! Your library is now part of Coq's continous integration! - -Note that by partipating in this program, you assume a reasonable -compromise to discuss and eventually integrate compatibility changes -upstream. - -Get in touch with us to discuss any special need your development may -have. - -Maintaining your contribution manually [current method] -====================================== - -To add your contribution to the Coq CI set, add a script for building -your library to `dev/ci/`, update `.travis.yml`, `.gitlab-ci.yml` and -`Makefile.ci`. Then, submit a PR. - -Maintaining your contribution as an OPAM package [work in progress] [to be implemented] -================================================ - -You can also provide an opam package for your contribution XXX at -https://github.com/coq/opam-coq-archive - -Then, add a `ci-opam-XXX` target to the `.travis.yml` file, the -package XXX.dev will be tested against each Coq commit and pull -request. - -- TODO: The main question here is what to do with `.opam` caching. We - could disable it altogether, however this will have an impact. We - could install a dummy Coq package, but `coq-*` dependencies will be - botched too. Need to think more. - -PR Overlays [work in progress] [to be implemented] -=========== - -It is common for PR to break some of the external tests. To this -purpose, we provide a method for particular PR to overlay the -repositories of some of the tests so they can provide fixed -developments. - -The general idea is that the PR author will drop a file -`dev/ci/overlays/$branch.overlay` where branch name is taken from -`${TRAVIS_PULL_REQUEST_BRANCH:-$TRAVIS_BRANCH}` -that is to say, the name of the original branch for the PR. - -The `.overlay` file will contain a set of variables that will be used -to do the corresponding `opam pin` or to overload the corresponding -git repositories, etc... - -Since pull requests only happen on GitHub there is no need to test the -corresponding GitLab CI variables. - -Travis specific information -=========================== - -Travis rebuilds all of Coq's executables and stdlib for each job. Coq -is built with `./configure -local`, then used for the job's test. - -GitLab specific information -=========================== - -GitLab is set up to use the "build artifact" feature to avoid -rebuilding Coq. In one job, Coq is built with `./configure -prefix -install` and `make install` is run, then the `install` directory -persists to and is used by the next jobs. - -Artifacts can also be downloaded from the GitLab repository. -Currently, available artifacts are: -- the Coq executables and stdlib, in three copies varying in - architecture and Ocaml version used to build Coq. -- the Coq documentation, in two different copies varying in the OCaml - version used to build Coq - -As an exception to the above, jobs testing that compilation triggers -no Ocaml warnings build Coq in parallel with other tests. diff --git a/checker/checker.ml b/checker/checker.ml index 7a69700d28..247a98e63e 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -10,7 +10,6 @@ open Pp open CErrors open Util open System -open Flags open Names open Check @@ -74,7 +73,7 @@ let add_path ~unix_path:dir ~coq_root:coq_dirpath = let convert_string d = try Id.of_string d with CErrors.UserError _ -> - if_verbose Feedback.msg_warning + Flags.if_verbose Feedback.msg_warning (str "Directory " ++ str d ++ str " cannot be used as a Coq identifier (skipped)"); raise Exit @@ -342,7 +341,7 @@ let parse_args argv = | ("-?"|"-h"|"-H"|"-help"|"--help") :: _ -> usage () | ("-v"|"--version") :: _ -> version () - | "-boot" :: rem -> boot := true; parse rem + | "-boot" :: rem -> Flags.boot := true; parse rem | ("-m" | "--memory") :: rem -> Check_stat.memory_stat := true; parse rem | ("-o" | "--output-context") :: rem -> Check_stat.output_context := true; parse rem @@ -366,15 +365,53 @@ let parse_args argv = (* To prevent from doing the initialization twice *) let initialized = ref false +(* XXX: At some point we need to either port the checker to use the + feedback system or to remove its use completely. *) +let init_feedback_listener () = + let open Format in + let pp_lvl fmt lvl = let open Feedback in match lvl with + | Error -> fprintf fmt "Error: " + | Info -> fprintf fmt "Info: " + | Debug -> fprintf fmt "Debug: " + | Warning -> fprintf fmt "Warning: " + | Notice -> fprintf fmt "" + in + let pp_loc fmt loc = let open Loc in match loc with + | None -> fprintf fmt "" + | Some loc -> + let where = + match loc.fname with InFile f -> f | ToplevelInput -> "Toplevel input" in + fprintf fmt "\"%s\", line %d, characters %d-%d:@\n" + where loc.line_nb (loc.bp-loc.bol_pos) (loc.ep-loc.bol_pos) in + let checker_feed (fb : Feedback.feedback) = let open Feedback in + match fb.contents with + | Processed -> () + | Incomplete -> () + | Complete -> () + | ProcessingIn _ -> () + | InProgress _ -> () + | WorkerStatus (_,_) -> () + | AddedAxiom -> () + | GlobRef (_,_,_,_,_) -> () + | GlobDef (_,_,_,_) -> () + | FileDependency (_,_) -> () + | FileLoaded (_,_) -> () + | Custom (_,_,_) -> () + (* Re-enable when we switch back to feedback-based error printing *) + | Message (lvl,loc,msg) -> + Format.eprintf "@[%a@]%a@[%a@]\n%!" pp_loc loc pp_lvl lvl Pp.pp_with msg + in ignore(Feedback.add_feeder checker_feed) + let init_with_argv argv = if not !initialized then begin initialized := true; Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *) + init_feedback_listener (); try parse_args argv; if !Flags.debug then Printexc.record_backtrace true; Envars.set_coqlib ~fail:(fun x -> CErrors.user_err Pp.(str x)); - if_verbose print_header (); + Flags.if_verbose print_header (); init_load_path (); engage (); with e -> diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index 3c9e1cac54..63e28448f9 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -25,7 +25,7 @@ let refresh_arity ar = | _ -> ar, Univ.ContextSet.empty let check_constant_declaration env kn cb = - Feedback.msg_notice (str " checking cst:" ++ prcon kn); + Flags.if_verbose Feedback.msg_notice (str " checking cst:" ++ prcon kn); (** [env'] contains De Bruijn universe variables *) let env' = match cb.const_universes with diff --git a/checker/univ.ml b/checker/univ.ml index 558315c2c1..4f31318132 100644 --- a/checker/univ.ml +++ b/checker/univ.ml @@ -29,107 +29,6 @@ open Util union-find algorithm. The assertions $<$ and $\le$ are represented by adjacency lists *) -module type Hashconsed = -sig - type t - val hash : t -> int - val eq : t -> t -> bool - val hcons : t -> t -end - -module HashedList (M : Hashconsed) : -sig - type t = private Nil | Cons of M.t * int * t - val nil : t - val cons : M.t -> t -> t -end = -struct - type t = Nil | Cons of M.t * int * t - module Self = - struct - type _t = t - type t = _t - type u = (M.t -> M.t) - let hash = function Nil -> 0 | Cons (_, h, _) -> h - let eq l1 l2 = match l1, l2 with - | Nil, Nil -> true - | Cons (x1, _, l1), Cons (x2, _, l2) -> x1 == x2 && l1 == l2 - | _ -> false - let hashcons hc = function - | Nil -> Nil - | Cons (x, h, l) -> Cons (hc x, h, l) - end - module Hcons = Hashcons.Make(Self) - let hcons = Hashcons.simple_hcons Hcons.generate Hcons.hcons M.hcons - (** No recursive call: the interface guarantees that all HLists from this - program are already hashconsed. If we get some external HList, we can - still reconstruct it by traversing it entirely. *) - let nil = Nil - let cons x l = - let h = M.hash x in - let hl = match l with Nil -> 0 | Cons (_, h, _) -> h in - let h = Hashset.Combine.combine h hl in - hcons (Cons (x, h, l)) -end - -module HList = struct - - module type S = sig - type elt - type t = private Nil | Cons of elt * int * t - val hash : t -> int - val nil : t - val cons : elt -> t -> t - val tip : elt -> t - val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a - val map : (elt -> elt) -> t -> t - val smartmap : (elt -> elt) -> t -> t - val exists : (elt -> bool) -> t -> bool - val for_all : (elt -> bool) -> t -> bool - val for_all2 : (elt -> elt -> bool) -> t -> t -> bool - val to_list : t -> elt list - end - - module Make (H : Hashconsed) : S with type elt = H.t = - struct - type elt = H.t - include HashedList(H) - - let hash = function Nil -> 0 | Cons (_, h, _) -> h - - let tip e = cons e nil - - let rec fold f l accu = match l with - | Nil -> accu - | Cons (x, _, l) -> fold f l (f x accu) - - let rec map f = function - | Nil -> nil - | Cons (x, _, l) -> cons (f x) (map f l) - - let smartmap = map - (** Apriori hashconsing ensures that the map is equal to its argument *) - - let rec exists f = function - | Nil -> false - | Cons (x, _, l) -> f x || exists f l - - let rec for_all f = function - | Nil -> true - | Cons (x, _, l) -> f x && for_all f l - - let rec for_all2 f l1 l2 = match l1, l2 with - | Nil, Nil -> true - | Cons (x1, _, l1), Cons (x2, _, l2) -> f x1 x2 && for_all2 f l1 l2 - | _ -> false - - let rec to_list = function - | Nil -> [] - | Cons (x, _, l) -> x :: to_list l - - end -end - module RawLevel = struct open Names @@ -167,24 +66,6 @@ struct | _, Level _ -> 1 | Var n, Var m -> Int.compare n m - let hequal x y = - x == y || - match x, y with - | Prop, Prop -> true - | Set, Set -> true - | Level (n,d), Level (n',d') -> - n == n' && d == d' - | Var n, Var n' -> n == n' - | _ -> false - - let hcons = function - | Prop as x -> x - | Set as x -> x - | Level (n,d) as x -> - let d' = Names.DirPath.hcons d in - if d' == d then x else Level (n,d') - | Var n as x -> x - open Hashset.Combine let hash = function @@ -216,24 +97,7 @@ module Level = struct let data x = x.data - (** Hashcons on levels + their hash *) - - module Self = struct - type _t = t - type t = _t - type u = unit - let eq x y = x.hash == y.hash && RawLevel.hequal x.data y.data - let hash x = x.hash - let hashcons () x = - let data' = RawLevel.hcons x.data in - if x.data == data' then x else { x with data = data' } - end - - let hcons = - let module H = Hashcons.Make(Self) in - Hashcons.simple_hcons H.generate H.hcons () - - let make l = hcons { hash = RawLevel.hash l; data = l } + let make l = { hash = RawLevel.hash l; data = l } let set = make Set let prop = make Prop @@ -270,7 +134,7 @@ module Level = struct let pr u = str (to_string u) - let make m n = make (Level (n, Names.DirPath.hcons m)) + let make m n = make (Level (n, m)) end @@ -303,48 +167,12 @@ struct module Expr = struct type t = Level.t * int - type _t = t - (* Hashing of expressions *) - module ExprHash = - struct - type t = _t - type u = Level.t -> Level.t - let hashcons hdir (b,n as x) = - let b' = hdir b in - if b' == b then x else (b',n) - let eq l1 l2 = - l1 == l2 || - match l1,l2 with - | (b,n), (b',n') -> b == b' && n == n' - - let hash (x, n) = n + Level.hash x - - end - - module HExpr = - struct - - module H = Hashcons.Make(ExprHash) - - type t = ExprHash.t - - let hcons = - Hashcons.simple_hcons H.generate H.hcons Level.hcons - let hash = ExprHash.hash - let eq x y = x == y || - (let (u,n) = x and (v,n') = y in - Int.equal n n' && Level.equal u v) - - end - - let hcons = HExpr.hcons - - let make l = hcons (l, 0) + let make l = (l, 0) - let prop = make Level.prop - let set = make Level.set - let type1 = hcons (Level.set, 1) + let prop = (Level.prop, 0) + let set = (Level.set, 0) + let type1 = (Level.set, 1) let is_prop = function | (l,0) -> Level.is_prop l @@ -363,13 +191,13 @@ struct let successor (u,n) = if Level.is_prop u then type1 - else hcons (u, n + 1) + else (u, n + 1) let addn k (u,n as x) = if k = 0 then x else if Level.is_prop u then - hcons (Level.set,n+k) - else hcons (u,n+k) + (Level.set,n+k) + else (u,n+k) let super (u,n as x) (v,n' as y) = let cmp = Level.compare u v in @@ -394,31 +222,29 @@ struct let v' = f v in if v' == v then x else if Level.is_prop v' && n != 0 then - hcons (Level.set, n) - else hcons (v', n) + (Level.set, n) + else (v', n) end - - module Huniv = HList.Make(Expr.HExpr) - type t = Huniv.t - open Huniv - - let equal x y = x == y || - (Huniv.hash x == Huniv.hash y && - Huniv.for_all2 Expr.equal x y) - let make l = Huniv.tip (Expr.make l) - let tip x = Huniv.tip x - + type t = Expr.t list + + let tip u = [u] + let cons u v = u :: v + + let equal x y = x == y || List.equal Expr.equal x y + + let make l = tip (Expr.make l) + let pr l = match l with - | Cons (u, _, Nil) -> Expr.pr u + | [u] -> Expr.pr u | _ -> str "max(" ++ hov 0 - (prlist_with_sep pr_comma Expr.pr (to_list l)) ++ + (prlist_with_sep pr_comma Expr.pr l) ++ str ")" let level l = match l with - | Cons (l, _, Nil) -> Expr.level l + | [l] -> Expr.level l | _ -> None (* The lower predicative level of the hierarchy that contains (impredicative) @@ -438,16 +264,16 @@ struct (* Returns the formal universe that lies juste above the universe variable u. Used to type the sort u. *) let super l = - Huniv.map (fun x -> Expr.successor x) l + List.map (fun x -> Expr.successor x) l let addn n l = - Huniv.map (fun x -> Expr.addn n x) l + List.map (fun x -> Expr.addn n x) l let rec merge_univs l1 l2 = match l1, l2 with - | Nil, _ -> l2 - | _, Nil -> l1 - | Cons (h1, _, t1), Cons (h2, _, t2) -> + | [], _ -> l2 + | _, [] -> l1 + | h1 :: t1, h2 :: t2 -> (match Expr.super h1 h2 with | Inl true (* h1 < h2 *) -> merge_univs t1 l2 | Inl false -> merge_univs l1 t2 @@ -459,28 +285,28 @@ struct let sort u = let rec aux a l = match l with - | Cons (b, _, l') -> + | b :: l' -> (match Expr.super a b with | Inl false -> aux a l' | Inl true -> l | Inr c -> if c <= 0 then cons a l else cons b (aux a l')) - | Nil -> cons a l + | [] -> cons a l in - fold (fun a acc -> aux a acc) u nil + List.fold_right (fun a acc -> aux a acc) u [] (* Returns the formal universe that is greater than the universes u and v. Used to type the products. *) let sup x y = merge_univs x y - let empty = nil + let empty = [] - let exists = Huniv.exists + let exists = List.exists - let for_all = Huniv.for_all + let for_all = List.for_all - let smartmap = Huniv.smartmap + let smartmap = List.smartmap end @@ -768,9 +594,9 @@ let check_equal_expr g x y = let check_eq_univs g l1 l2 = let f x1 x2 = check_equal_expr g x1 x2 in - let exists x1 l = Huniv.exists (fun x2 -> f x1 x2) l in - Huniv.for_all (fun x1 -> exists x1 l2) l1 - && Huniv.for_all (fun x2 -> exists x2 l1) l2 + let exists x1 l = List.exists (fun x2 -> f x1 x2) l in + List.for_all (fun x1 -> exists x1 l2) l1 + && List.for_all (fun x2 -> exists x2 l1) l2 let check_eq g u v = Universe.equal u v || check_eq_univs g u v @@ -784,11 +610,11 @@ let check_smaller_expr g (u,n) (v,m) = | _ -> false let exists_bigger g ul l = - Huniv.exists (fun ul' -> + Universe.exists (fun ul' -> check_smaller_expr g ul ul') l let real_check_leq g u v = - Huniv.for_all (fun ul -> exists_bigger g ul v) u + Universe.for_all (fun ul -> exists_bigger g ul v) u let check_leq g u v = Universe.equal u v || @@ -1026,8 +852,8 @@ let check_univ_leq u v = let enforce_leq u v c = match v with - | Universe.Huniv.Cons (v, _, Universe.Huniv.Nil) -> - Universe.Huniv.fold (fun u -> constraint_add_leq u v) u c + | [v] -> + List.fold_right (fun u -> constraint_add_leq u v) u c | _ -> anomaly (Pp.str"A universe bound can only be a variable.") let enforce_leq u v c = @@ -1080,63 +906,18 @@ end = struct type t = Level.t array - let empty : t = [||] - - module HInstancestruct = - struct - type _t = t - type t = _t - type u = Level.t -> Level.t - - let hashcons huniv a = - let len = Array.length a in - if Int.equal len 0 then empty - else begin - for i = 0 to len - 1 do - let x = Array.unsafe_get a i in - let x' = huniv x in - if x == x' then () - else Array.unsafe_set a i x' - done; - a - end - - let eq t1 t2 = - t1 == t2 || - (Int.equal (Array.length t1) (Array.length t2) && - let rec aux i = - (Int.equal i (Array.length t1)) || (t1.(i) == t2.(i) && aux (i + 1)) - in aux 0) - - let hash a = - let accu = ref 0 in - for i = 0 to Array.length a - 1 do - let l = Array.unsafe_get a i in - let h = Level.hash l in - accu := Hashset.Combine.combine !accu h; - done; - (* [h] must be positive. *) - let h = !accu land 0x3FFFFFFF in - h - - end - - module HInstance = Hashcons.Make(HInstancestruct) - - let hcons = Hashcons.simple_hcons HInstance.generate HInstance.hcons Level.hcons - - let empty = hcons [||] + let empty = [||] let is_empty x = Int.equal (Array.length x) 0 let subst_fn fn t = let t' = CArray.smartmap fn t in - if t' == t then t else hcons t' + if t' == t then t else t' let subst s t = let t' = CArray.smartmap (fun x -> try LMap.find x s with Not_found -> x) t - in if t' == t then t else hcons t' + in if t' == t then t else t' let pr = prvect_with_sep spc Level.pr @@ -1296,7 +1077,7 @@ let subst_univs_expr_opt fn (l,n) = let subst_univs_universe fn ul = let subst, nosubst = - Universe.Huniv.fold (fun u (subst,nosubst) -> + List.fold_right (fun u (subst,nosubst) -> try let a' = subst_univs_expr_opt fn u in (a' :: subst, nosubst) with Not_found -> (subst, u :: nosubst)) @@ -1307,7 +1088,7 @@ let subst_univs_universe fn ul = let substs = List.fold_left Universe.merge_univs Universe.empty subst in - List.fold_left (fun acc u -> Universe.merge_univs acc (Universe.Huniv.tip u)) + List.fold_left (fun acc u -> Universe.merge_univs acc (Universe.tip u)) substs nosubst let merge_context strict ctx g = diff --git a/checker/univ.mli b/checker/univ.mli index 0a21019b1b..0eadc6801f 100644 --- a/checker/univ.mli +++ b/checker/univ.mli @@ -164,7 +164,6 @@ sig val is_empty : t -> bool val equal : t -> t -> bool - (** Equality (note: instances are hash-consed, this is O(1)) *) val subst_fn : universe_level_subst_fn -> t -> t (** Substitution by a level-to-level function. *) diff --git a/checker/values.ml b/checker/values.ml index afde84854c..86634fbd80 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -99,7 +99,7 @@ let v_raw_level = v_sum "raw_level" 2 (* Prop, Set *) [|(*Level*)[|Int;v_dp|]; (*Var*)[|Int|]|] let v_level = v_tuple "level" [|Int;v_raw_level|] let v_expr = v_tuple "levelexpr" [|v_level;Int|] -let rec v_univ = Sum ("universe", 1, [| [|v_expr; Int; v_univ|] |]) +let v_univ = List v_expr let v_cstrs = Annot diff --git a/dev/build/osx/make-macos-dmg.sh b/dev/build/osx/make-macos-dmg.sh index cbe2a5186f..cfcc09b327 100755 --- a/dev/build/osx/make-macos-dmg.sh +++ b/dev/build/osx/make-macos-dmg.sh @@ -9,15 +9,12 @@ DMGDIR=$PWD/_dmg VERSION=$(sed -n -e '/^let coq_version/ s/^[^"]*"\([^"]*\)"$/\1/p' configure.ml) APP=bin/CoqIDE_${VERSION}.app -# Create a .app file with CoqIDE -make -j $NJOBS -l2 $APP +# Create a .app file with CoqIDE, without signing it +make PRIVATEBINARIES=$APP -j $NJOBS -l2 $APP # Add Coq to the .app file make OLDROOT=$OUTDIR COQINSTALLPREFIX=$APP/Contents/Resources/ install-coq install-ide-toploop -# Sign the .app file -codesign -f -s - $APP - # Create the dmg bundle mkdir -p $DMGDIR ln -sf /Applications $DMGDIR/Applications diff --git a/dev/build/windows/MakeCoq_MinGW.bat b/dev/build/windows/MakeCoq_MinGW.bat index a420b5d8bb..f91b301b8c 100644 --- a/dev/build/windows/MakeCoq_MinGW.bat +++ b/dev/build/windows/MakeCoq_MinGW.bat @@ -328,12 +328,6 @@ ECHO ========== INSTALL CYGWIN ========== REM Cygwin setup sets proper ACLs (permissions) for folders it CREATES. REM Otherwise chmod won't work and e.g. the ocaml build will fail. REM Cygwin setup does not touch the ACLs of existing folders. -REM => Create the setup log in a temporary location and move it later. - -REM Get Unique temporary file name -:logfileloop -SET LOGFILE=%TEMP%\CygwinSetUp%RANDOM%-%RANDOM%-%RANDOM%-%RANDOM%.log -if exist "%LOGFILE%" GOTO logfileloop REM Run Cygwin Setup @@ -348,6 +342,12 @@ IF "%COQREGTESTING%" == "Y" ( SET RUNSETUP=Y ) +SET "EXTRAPACKAGES= " + +IF NOT "%APPVEYOR%" == "True" ( + SET EXTRAPACKAGES="-P wget,curl,git,gcc-core,gcc-g++,automake1.5" +) + IF "%RUNSETUP%"=="Y" ( %SETUP% ^ --proxy "%PROXY%" ^ @@ -356,10 +356,9 @@ IF "%RUNSETUP%"=="Y" ( --local-package-dir "%CYGWIN_LOCAL_CACHE_WFMT%" ^ --no-shortcuts ^ %CYGWIN_OPT% ^ - -P wget,curl,git,make,unzip ^ - -P gcc-core,gcc-g++ ^ + -P make,unzip ^ -P gdb,liblzma5 ^ - -P patch,automake1.14,automake1.15 ^ + -P patch,automake1.14 ^ -P mingw64-%ARCH%-binutils,mingw64-%ARCH%-gcc-core,mingw64-%ARCH%-gcc-g++,mingw64-%ARCH%-pkg-config,mingw64-%ARCH%-windows_default_manifest ^ -P mingw64-%ARCH%-headers,mingw64-%ARCH%-runtime,mingw64-%ARCH%-pthreads,mingw64-%ARCH%-zlib ^ -P libiconv-devel,libunistring-devel,libncurses-devel ^ @@ -369,12 +368,11 @@ IF "%RUNSETUP%"=="Y" ( -P gtk-update-icon-cache ^ -P libtool,automake ^ -P intltool ^ - > "%LOGFILE%" ^ + %EXTRAPACKAGES% ^ || GOTO ErrorExit MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build" MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build\buildlogs" - MOVE "%LOGFILE%" "%CYGWIN_INSTALLDIR_WFMT%\build\buildlogs\cygwinsetup.log" || GOTO ErrorExit ) diff --git a/dev/ci/README.md b/dev/ci/README.md new file mode 100644 index 0000000000..f4423558cc --- /dev/null +++ b/dev/ci/README.md @@ -0,0 +1,130 @@ +Continuous Integration for the Coq Proof Assistant +================================================== + +Changes to Coq are systematically tested for regression and compatibility +breakage on our Continuous Integration (CI) platforms *before* integration, +so as to ensure better robustness and catch problems as early as possible. +These tests include the compilation of several external libraries / plugins. + +This document contains information for both external library / plugin authors, +who might be interested in having their development tested, and for Coq +developers / contributors, who must ensure that they don't break these +external developments accidentally. + +*Remark:* the CI policy outlined in this document is susceptible to evolve and +specific accommodations are of course possible. + +Information for external library / plugin authors +------------------------------------------------- + +You are encouraged to consider submitting your development for addition to +our CI. This means that: + +- Any time that a proposed change is breaking your development, Coq developers + will send you patches to adapt it or, at the very least, will work with you + to see how to adapt it. + +On the condition that: + +- At the time of the submission, your development works with Coq master branch. + +- Your development is publicly available in a git repository and we can easily + send patches to you (e.g. through pull / merge requests). + +- You react in a timely manner to discuss / integrate those patches. + +- You do not push, to the branches that we test, commits that haven't been + first tested to compile with the corresponding branch(es) of Coq. + +- Your development compiles in less than 35 minutes with just two threads. + If this is not the case, consider adding a "lite" target that compiles just + part of it. + +In case you forget to comply with these last three conditions, we would reach +out to you and give you a 30-day grace period during which your development +would be moved into our "allow failure" category. At the end of the grace +period, in the absence of progress, the development would be removed from our +CI. + +### Add your development by submitting a pull request + +Add a new `ci-mydev.sh` script to [`dev/ci`](/dev/ci) (have a look at +[`ci-coq-dpdgraph.sh`](/dev/ci/ci-coq-dpdgraph.sh) or +[`ci-fiat-parsers.sh`](/dev/ci/ci-fiat-parsers.sh) for simple examples); +set the corresponding variables in +[`ci-basic-overlay.sh`](/dev/ci/ci-basic-overlay.sh); add the corresponding +target to [`Makefile.ci`](/Makefile.ci); add new jobs to +[`.travis.yml`](/.travis.yml) and [`.gitlab-ci.yml`](/.gitlab-ci.yml) so that +this new target is run. **Do not hesitate to submit an incomplete pull request +if you need help to finish it.** + +You may also be interested in having your development tested in our +performance benchmark. Currently this is done by providing an OPAM package +in https://github.com/coq/opam-coq-archive and opening an issue at +https://github.com/coq/coq-bench/issues. + + +Information for developers +-------------------------- + +When you submit a pull request (PR) on Coq GitHub repository, this will +automatically launch a battery of CI tests. The PR will not be integrated +unless these tests pass. + +Currently, we have two CI platforms: + +- Travis is the main CI platform. It tests the compilation of Coq, of the + documentation, and of CoqIDE on Linux with several versions of OCaml / + camlp5, and with warnings as errors; it runs the test-suite and tests the + compilation of several external developments. It also tests the compilation + of Coq on OS X. + +- AppVeyor is used to test the compilation of Coq and run the test-suite on + Windows. + +You can anticipate the results of these tests prior to submitting your PR +by having them run of your fork of Coq, on GitHub or GitLab. This can be +especially helpful given that our Travis platform is often overloaded and +therefore there can be a significant delay before these tests are actually +run on your PR. To take advantage of this, simply create a Travis account +and link it to your GitHub account, or activate the pipelines on your GitLab +fork. + +You can also run one CI target locally (using `make ci-somedev`). + +Whenever your PR breaks tested developments, you should either adapt it +so that it doesn't, or provide a branch fixing these developments (or at +least work with the author of the development / other Coq developers to +prepare these fixes). Then, add an overlay in +[`dev/ci/user-overlays`](/dev/ci/user-overlays) (see the README there) +in a separate commit in your PR. + +The process to merge your PR is then to submit PRs to the external +development repositories, merge the latter first (if the fixes are +backward-compatible), drop the overlay commit and merge the PR on Coq then. + + +Travis specific information +--------------------------- + +Travis rebuilds all of Coq's executables and stdlib for each job. Coq +is built with `./configure -local`, then used for the job's test. + + +GitLab specific information +--------------------------- + +GitLab is set up to use the "build artifact" feature to avoid +rebuilding Coq. In one job, Coq is built with `./configure -prefix +install` and `make install` is run, then the `install` directory +persists to and is used by the next jobs. + +Artifacts can also be downloaded from the GitLab repository. +Currently, available artifacts are: +- the Coq executables and stdlib, in three copies varying in + architecture and Ocaml version used to build Coq. +- the Coq documentation, in two different copies varying in the OCaml + version used to build Coq + +As an exception to the above, jobs testing that compilation triggers +no Ocaml warnings build Coq in parallel with other tests. diff --git a/dev/ci/ci-common.sh b/dev/ci/ci-common.sh index 238960948d..1bfdf7dfbe 100644 --- a/dev/ci/ci-common.sh +++ b/dev/ci/ci-common.sh @@ -4,7 +4,8 @@ set -xe if [ -n "${GITLAB_CI}" ]; then - export COQBIN=`pwd`/install/bin + export COQBIN=`pwd`/_install_ci/bin + export TRAVIS_BRANCH="$CI_COMMIT_REF_NAME" else export COQBIN=`pwd`/bin fi diff --git a/dev/core.dbg b/dev/core.dbg index 71d06cdb0a..18e82c352c 100644 --- a/dev/core.dbg +++ b/dev/core.dbg @@ -16,7 +16,6 @@ load_printer tactics.cma load_printer vernac.cma load_printer stm.cma load_printer toplevel.cma -load_printer highparsing.cma load_printer intf.cma load_printer API.cma load_printer ltac_plugin.cmo diff --git a/dev/doc/changes.txt b/dev/doc/changes.md index 0f1a28028c..5ed74917aa 100644 --- a/dev/doc/changes.txt +++ b/dev/doc/changes.md @@ -1,141 +1,146 @@ -========================================= -= CHANGES BETWEEN COQ V8.7 AND COQ V8.8 = -========================================= +## Changes between Coq 8.7 and Coq 8.8 -* ML API * +### Plugin API + +Coq 8.8 offers a new module overlay containing a proposed plugin API +in `API/API.ml`; this overlay is enabled by adding the `-open API` +flag to the OCaml compiler; this happens automatically for +developments in the `plugin` folder and `coq_makefile`. + +However, `coq_makefile` can be instructed not to enable this flag by +passing `-bypass-API`. + +### ML API We removed the following functions: -- Universes.unsafe_constr_of_global: use Global.constr_of_global_in_context +- `Universes.unsafe_constr_of_global`: use `Global.constr_of_global_in_context` instead. The returned term contains De Bruijn universe variables. If you don't depend on universes being instantiated, simply drop the context. -- Universes.unsafe_type_of_global: same as above with - Global.type_of_global_in_context + +- `Universes.unsafe_type_of_global`: same as above with + `Global.type_of_global_in_context` We changed the type of the following functions: -- Global.body_of_constant_body: now also returns the abstract universe context. +- `Global.body_of_constant_body`: now also returns the abstract universe context. The returned term contains De Bruijn universe variables. -- Global.body_of_constant: same as above. + +- `Global.body_of_constant`: same as above. We renamed the following datatypes: - Pp.std_ppcmds -> Pp.t +- `Pp.std_ppcmds` -> `Pp.t` -========================================= -= CHANGES BETWEEN COQ V8.6 AND COQ V8.7 = -========================================= +## Changes between Coq 8.6 and Coq 8.7 -* Ocaml * +### Ocaml -Coq is compiled with -safe-string enabled and requires plugins to do +Coq is compiled with `-safe-string` enabled and requires plugins to do the same. This means that code using `String` in an imperative way will fail to compile now. They should switch to `Bytes.t` -* Plugin API * +### ML API -Coq 8.7 offers a new module overlay containing a proposed plugin API -in `API/API.ml`; this overlay is enabled by adding the `-open API` -flag to the OCaml compiler; this happens automatically for -developments in the `plugin` folder and `coq_makefile`. - -However, `coq_makefile` can be instructed not to enable this flag by -passing `-bypass-API`. - -* ML API * - -Added two functions for declaring hooks to be executed in reduction +- Added two functions for declaring hooks to be executed in reduction functions when some given constants are traversed: - declare_reduction_effect: to declare a hook to be applied when some + * `declare_reduction_effect`: to declare a hook to be applied when some constant are visited during the execution of some reduction functions (primarily cbv). - set_reduction_effect: to declare a constant on which a given effect + * `set_reduction_effect`: to declare a constant on which a given effect hook should be called. -We renamed the following functions: +- We renamed the following functions: + ``` Context.Rel.Declaration.fold -> Context.Rel.Declaration.fold_constr Context.Named.Declaration.fold -> Context.Named.Declaration.fold_constr Printer.pr_var_list_decl -> Printer.pr_compacted_decl Printer.pr_var_decl -> Printer.pr_named_decl Nameops.lift_subscript -> Nameops.increment_subscript + ``` -We removed the following functions: +- We removed the following functions: - Termops.compact_named_context_reverse ... practical substitute is Termops.compact_named_context - Namegen.to_avoid ... equivalent substitute is Names.Id.List.mem + * `Termops.compact_named_context_reverse`: practical substitute is `Termops.compact_named_context`. + * `Namegen.to_avoid`: equivalent substitute is `Names.Id.List.mem`. -We renamed the following modules: +- We renamed the following modules: - Context.ListNamed -> Context.Compacted + * `Context.ListNamed` -> `Context.Compacted` -The following type aliases where removed +- The following type aliases where removed - Context.section_context ... it was just an alias for "Context.Named.t" which is still available + * `Context.section_context`: it was just an alias for `Context.Named.t` which is still available. -The module Constrarg was merged into Stdarg. +- The module `Constrarg` was merged into `Stdarg`. -The following types have been moved and modified: +- The following types have been moved and modified: - local_binder -> local_binder_expr - glob_binder merged with glob_decl + * `local_binder` -> `local_binder_expr` + * `glob_binder` merged with `glob_decl` -The following constructors have been renamed: +- The following constructors have been renamed: + ``` LocalRawDef -> CLocalDef LocalRawAssum -> CLocalAssum LocalPattern -> CLocalPattern + ``` -In Constrexpr_ops: +- In `Constrexpr_ops`: - Deprecating abstract_constr_expr in favor of mkCLambdaN, and - prod_constr_expr in favor of mkCProdN. Note: the first ones were - interpreting "(x y z:_)" as "(x:_) (y:_) (z:_)" while the second + Deprecating `abstract_constr_expr` in favor of `mkCLambdaN`, and + `prod_constr_expr` in favor of `mkCProdN`. Note: the first ones were + interpreting `(x y z:_)` as `(x:_) (y:_) (z:_)` while the second ones were preserving the original sharing of the type. -In Nameops: +- In `Nameops`: The API has been made more uniform. New combinators added in the - "Name" space name. Function "out_name" now fails with IsAnonymous - rather than with Failure "Nameops.out_name". + `Name` space name. Function `out_name` now fails with `IsAnonymous` + rather than with `Failure "Nameops.out_name"`. -Location handling and AST attributes: +- Location handling and AST attributes: - Location handling has been reworked. First, Loc.ghost has been + Location handling has been reworked. First, `Loc.ghost` has been removed in favor of an option type, all objects carrying an optional source code location have been switched to use `Loc.t option`. Storage of location information has been also refactored. The main - datatypes representing Coq AST (constrexpr, glob_expr) have been + datatypes representing Coq AST (`constrexpr`, `glob_expr`) have been switched to a generic "node with attributes" representation `'a CAst.ast`, which is a record of the form: -```ocaml -type 'a ast = private { - v : 'a; - loc : Loc.t option; - ... -} -``` + ```ocaml + type 'a ast = private { + v : 'a; + loc : Loc.t option; + ... + } + ``` consumers of AST nodes are recommended to use accessor-based pattern matching `{ v; loc }` to destruct `ast` object. Creation is done with `CAst.make ?loc obj`, where the attributes are optional. Some convenient combinators are provided in the module. A typical match: -``` -| CCase(loc, a1) -> CCase(loc, f a1) -``` + + ```ocaml + | CCase(loc, a1) -> CCase(loc, f a1) + ``` + is now done as: -``` -| { v = CCase(a1); loc } -> CAst.make ?loc @@ CCase(f a1) -``` + ```ocaml + | { v = CCase(a1); loc } -> CAst.make ?loc @@ CCase(f a1) + + ``` or even better, if plan to preserve the attributes you can wrap your top-level function in `CAst.map` to have: -``` -| CCase(a1) -> CCase(f a1) -``` + ```ocaml + | CCase(a1) -> CCase(f a1) + ``` This scheme based on records enables easy extensibility of the AST node type without breaking compatibility. @@ -151,14 +156,14 @@ type 'a ast = private { implemented in the whole code base. Matching a located object hasn't changed, however, `Loc.tag ?loc obj` must be used to build one. -In GOption: +- In `GOption`: Support for non-synchronous options has been removed. Now all options are handled as a piece of normal document state, and thus passed to workers, etc... As a consequence, the field `Goptions.optsync` has been removed. -In Coqlib / reference location: +- In `Coqlib` / reference location: We have removed from Coqlib functions returning `constr` from names. Now it is only possible to obtain references, that must be @@ -175,65 +180,67 @@ In Coqlib / reference location: `pf_constr_of_global` in tactics and `Evarutil.new_global` variants when constructing terms in ML (see univpoly.txt for more information). -** Tactic API ** +### Tactic API -- pf_constr_of_global now returns a tactic instead of taking a continuation. +- `pf_constr_of_global` now returns a tactic instead of taking a continuation. Thus it only generates one instance of the global reference, and it is the caller's responsibility to perform a focus on the goal. -- pf_global, construct_reference, global_reference, - global_reference_in_absolute_module now return a global_reference - instead of a constr. +- `pf_global`, `construct_reference`, `global_reference`, + `global_reference_in_absolute_module` now return a `global_reference` + instead of a `constr`. -- The tclWEAK_PROGRESS and tclNOTSAMEGOAL tacticals were removed. Their usecase - was very specific. Use tclPROGRESS instead. +- The `tclWEAK_PROGRESS` and `tclNOTSAMEGOAL` tacticals were removed. Their usecase + was very specific. Use `tclPROGRESS` instead. - New (internal) tactical `tclINDEPENDENTL` that combined with enter_one allows to iterate a non-unit tactic on all goals and access their returned values. -- The unsafe flag of the Refine.refine function and its variants has been +- The unsafe flag of the `Refine.refine` function and its variants has been renamed and dualized into typecheck and has been made mandatory. -** Ltac API ** +### Ltac API Many Ltac specific API has been moved in its own ltac/ folder. Amongst other important things: -- Pcoq.Tactic -> Pltac -- Constrarg.wit_tactic -> Tacarg.wit_tactic -- Constrarg.wit_ltac -> Tacarg.wit_ltac -- API below ltac/ that accepted a *_tactic_expr now accept a *_generic_argument +- `Pcoq.Tactic` -> `Pltac` +- `Constrarg.wit_tactic` -> `Tacarg.wit_tactic` +- `Constrarg.wit_ltac` -> `Tacarg.wit_ltac` +- API below `ltac/` that accepted a *`_tactic_expr` now accept a *`_generic_argument` instead -- Some printing functions were moved from Pptactic to Pputils -- A part of Tacexpr has been moved to Tactypes -- The TacFun tactic expression constructor now takes a `Name.t list` for the +- Some printing functions were moved from `Pptactic` to `Pputils` +- A part of `Tacexpr` has been moved to `Tactypes` +- The `TacFun` tactic expression constructor now takes a `Name.t list` for the variable list rather than an `Id.t option list`. The folder itself has been turned into a plugin. This does not change much, but because it is a packed plugin, it may wreak havoc for third-party plugins -depending on any module defined in the ltac/ directory. Namely, even if +depending on any module defined in the `ltac/` directory. Namely, even if everything looks OK at compile time, a plugin can fail to load at link time -because it mistakenly looks for a module Foo instead of Ltac_plugin.Foo, with +because it mistakenly looks for a module `Foo` instead of `Ltac_plugin.Foo`, with an error of the form: +``` Error: while loading myplugin.cmxs, no implementation available for Foo. +``` -In particular, most EXTEND macros will trigger this problem even if they +In particular, most `EXTEND` macros will trigger this problem even if they seemingly do not use any Ltac module, as their expansion do. -The solution is simple, and consists in adding a statement "open Ltac_plugin" +The solution is simple, and consists in adding a statement `open Ltac_plugin` in each file using a Ltac module, before such a module is actually called. An alternative solution would be to fully qualify Ltac modules, e.g. turning any -call to Tacinterp into Ltac_plugin.Tacinterp. Note that this solution does not -work for EXTEND macros though. +call to Tacinterp into `Ltac_plugin.Tacinterp`. Note that this solution does not +work for `EXTEND` macros though. -** Additional changes in tactic extensions ** +### Additional changes in tactic extensions -Entry "constr_with_bindings" has been renamed into -"open_constr_with_bindings". New entry "constr_with_bindings" now +Entry `constr_with_bindings` has been renamed into +`open_constr_with_bindings`. New entry `constr_with_bindings` now uses type classes and rejects terms with unresolved holes. -** Error handling ** +### Error handling - All error functions now take an optional parameter `?loc:Loc.t`. For functions that used to carry a suffix `_loc`, such suffix has been @@ -243,14 +250,14 @@ uses type classes and rejects terms with unresolved holes. - The header parameter to `user_err` has been made optional. -** Pretty printing ** +### Pretty printing Some functions have been removed, see pretty printing below for more details. -* Pretty Printing and XML protocol * +#### Pretty Printing and XML protocol -The type std_cmdpps has been reworked and made the canonical "Coq rich +The type `std_cmdpps` has been reworked and made the canonical "Coq rich document type". This allows for a more uniform handling of printing (specially in IDEs). The main consequences are: @@ -267,12 +274,13 @@ document type". This allows for a more uniform handling of printing - `Pp_control` has removed. The new module `Topfmt` implements console control for the toplevel. - - The impure tag system in Pp has been removed. This also does away + - The impure tag system in `Pp` has been removed. This also does away with the printer signatures and functors. Now printers tag unconditionally. - The following functions have been removed from `Pp`: + ```ocaml val stras : int * string -> std_ppcmds val tbrk : int * int -> std_ppcmds val tab : unit -> std_ppcmds @@ -294,8 +302,9 @@ document type". This allows for a more uniform handling of printing val msg_with : ... module Tag + ``` -** Stm API ** +### Stm API - We have streamlined the `Stm` API, now `add` and `query` take a `coq_parsable` instead a `string` so clients can have more control @@ -312,7 +321,7 @@ document type". This allows for a more uniform handling of printing - A few unused hooks were removed due to cleanups, no clients known. -** Toplevel and Vernacular API ** +### Toplevel and Vernacular API - The components related to vernacular interpretation have been moved to their own folder `vernac/` whereas toplevel now contains the @@ -321,39 +330,41 @@ document type". This allows for a more uniform handling of printing - Coq's toplevel has been ported to directly use the common `Stm` API. The signature of a few functions has changed as a result. -** XML Protocol ** +### XML Protocol - The legacy `Interp` call has been turned into a noop. - The `query` call has been modified, now it carries a mandatory - "route_id" integer parameter, that associated the result of such + `route_id` integer parameter, that associated the result of such query with its generated feedback. -========================================= -= CHANGES BETWEEN COQ V8.5 AND COQ V8.6 = -========================================= +## Changes between Coq 8.5 and Coq 8.6 -** Parsing ** +### Parsing -Pcoq.parsable now takes an extra optional filename argument so as to +`Pcoq.parsable` now takes an extra optional filename argument so as to bind locations to a file name when relevant. -** Files ** +### Files To avoid clashes with OCaml's compiler libs, the following files were renamed: + +``` kernel/closure.ml{,i} -> kernel/cClosure.ml{,i} lib/errors.ml{,i} -> lib/cErrors.ml{,i} toplevel/cerror.ml{,i} -> toplevel/explainErr.mli{,i} +``` -All IDE-specific files, including the XML protocol have been moved to ide/ +All IDE-specific files, including the XML protocol have been moved to `ide/` -** Reduction functions ** +### Reduction functions -In closure.ml, we introduced the more precise reduction flags fMATCH, fFIX, -fCOFIX. +In `closure.ml`, we introduced the more precise reduction flags `fMATCH`, `fFIX`, +`fCOFIX`. We renamed the following functions: +``` Closure.betadeltaiota -> Closure.all Closure.betadeltaiotanolet -> Closure.allnolet Reductionops.beta -> Closure.beta @@ -380,9 +391,11 @@ Reductionops.whd_betadeltaiota_nolet_state -> Reductionops.whd_allnolet_state Reductionops.whd_eta -> Reductionops.shrink_eta Tacmach.pf_whd_betadeltaiota -> Tacmach.pf_whd_all Tacmach.New.pf_whd_betadeltaiota -> Tacmach.New.pf_whd_all +``` And removed the following ones: +``` Reductionops.whd_betaetalet Reductionops.whd_betaetalet_stack Reductionops.whd_betaetalet_state @@ -392,15 +405,16 @@ Reductionops.whd_betadeltaeta Reductionops.whd_betadeltaiotaeta_stack Reductionops.whd_betadeltaiotaeta_state Reductionops.whd_betadeltaiotaeta +``` -In intf/genredexpr.mli, fIota was replaced by FMatch, FFix and -FCofix. Similarly, rIota was replaced by rMatch, rFix and rCofix. +In `intf/genredexpr.mli`, `fIota` was replaced by `FMatch`, `FFix` and +`FCofix`. Similarly, `rIota` was replaced by `rMatch`, `rFix` and `rCofix`. -** Notation_ops ** +### Notation_ops -Use Glob_ops.glob_constr_eq instead of Notation_ops.eq_glob_constr. +Use `Glob_ops.glob_constr_eq` instead of `Notation_ops.eq_glob_constr`. -** Logging and Pretty Printing: ** +### Logging and Pretty Printing * Printing functions have been removed from `Pp.mli`, which is now a purely pretty-printing interface. Functions affected are: @@ -429,7 +443,7 @@ val message : string -> unit * Feedback related functions and definitions have been moved to the `Feedback` module. `message_level` has been renamed to - level. Functions moved from Pp to Feedback are: + level. Functions moved from `Pp` to `Feedback` are: ```` ocaml val set_logger : logger -> unit @@ -474,12 +488,13 @@ val set_id_for_feedback : ?route:route_id -> edit_or_state_id -> unit val get_id_for_feedback : unit -> edit_or_state_id * route_id ```` -** Kernel API changes ** +### Kernel API changes -- The interface of the Context module was changed. +- The interface of the `Context` module was changed. Related types and functions were put in separate submodules. The mapping from old identifiers to new identifiers is the following: + ``` Context.named_declaration ---> Context.Named.Declaration.t Context.named_list_declaration ---> Context.NamedList.Declaration.t Context.rel_declaration ---> Context.Rel.Declaration.t @@ -521,123 +536,142 @@ val get_id_for_feedback : unit -> edit_or_state_id * route_id Context.rel_context_length ---> Context.Rel.length Context.rel_context_nhyps ---> Context.Rel.nhyps Context.rel_context_tags ---> Context.Rel.to_tags + ``` - Originally, rel-context was represented as: - Context.rel_context = Names.Name.t * Constr.t option * Constr.t + ```ocaml + type Context.rel_context = Names.Name.t * Constr.t option * Constr.t + ``` Now it is represented as: - Context.Rel.Declaration.t = LocalAssum of Names.Name.t * Constr.t - | LocalDef of Names.Name.t * Constr.t * Constr.t - + ```ocaml + type Context.Rel.Declaration.t = LocalAssum of Names.Name.t * Constr.t + | LocalDef of Names.Name.t * Constr.t * Constr.t + ``` + - Originally, named-context was represented as: - Context.named_context = Names.Id.t * Constr.t option * Constr.t + ```ocaml + type Context.named_context = Names.Id.t * Constr.t option * Constr.t + ``` Now it is represented as: - Context.Named.Declaration.t = LocalAssum of Names.Id.t * Constr.t - | LocalDef of Names.Id.t * Constr.t * Constr.t + ```ocaml + type Context.Named.Declaration.t = LocalAssum of Names.Id.t * Constr.t + | LocalDef of Names.Id.t * Constr.t * Constr.t + ``` -- The various EXTEND macros do not handle specially the Coq-defined entries +- The various `EXTEND` macros do not handle specially the Coq-defined entries anymore. Instead, they just output a name that have to exist in the scope - of the ML code. The parsing rules (VERNAC) ARGUMENT EXTEND will look for - variables "$name" of type Gram.entry, while the parsing rules of - (VERNAC COMMAND | TACTIC) EXTEND, as well as the various TYPED AS clauses will - look for variables "wit_$name" of type Genarg.genarg_type. The small DSL + of the ML code. The parsing rules (`VERNAC`) `ARGUMENT EXTEND` will look for + variables `$name` of type `Gram.entry`, while the parsing rules of + (`VERNAC COMMAND` | `TACTIC`) `EXTEND`, as well as the various `TYPED AS` clauses will + look for variables `wit_$name` of type `Genarg.genarg_type`. The small DSL for constructing compound entries still works over this scheme. Note that in - the case of (VERNAC) ARGUMENT EXTEND, the name of the argument entry is bound + the case of (`VERNAC`) `ARGUMENT EXTEND`, the name of the argument entry is bound in the parsing rules, so beware of recursive calls. - For example, to get "wit_constr" you must "open Constrarg" at the top of the file. + For example, to get `wit_constr` you must `open Constrarg` at the top of the file. -- Evarutil was split in two parts. The new Evardefine file exposes functions -define_evar_* mostly used internally in the unification engine. +- `Evarutil` was split in two parts. The new `Evardefine` file exposes functions + `define_evar_`* mostly used internally in the unification engine. -- The Refine module was move out of Proofview. +- The `Refine` module was moved out of `Proofview`. + ``` Proofview.Refine.* ---> Refine.* + ``` -- A statically monotonous evarmap type was introduced in Sigma. Not all the API +- A statically monotonic evarmap type was introduced in `Sigma`. Not all the API has been converted, so that the user may want to use compatibility functions - Sigma.to_evar_map and Sigma.Unsafe.of_evar_map or Sigma.Unsafe.of_pair when + `Sigma.to_evar_map` and `Sigma.Unsafe.of_evar_map` or `Sigma.Unsafe.of_pair` when needed. Code can be straightforwardly adapted in the following way: + ```ocaml let (sigma, x1) = ... in ... let (sigma, xn) = ... in (sigma, ans) + ``` should be turned into: + ```ocaml open Sigma.Notations let Sigma (x1, sigma, p1) = ... in ... let Sigma (xn, sigma, pn) = ... in Sigma (ans, sigma, p1 +> ... +> pn) + ``` Examples of `Sigma.Unsafe.of_evar_map` include: + ``` Evarutil.new_evar env (Tacmach.project goal) ty ----> Evarutil.new_evar env (Sigma.Unsafe.of_evar_map (Tacmach.project goal)) ty + ``` -- The Proofview.Goal.*enter family of functions now takes a polymorphic +- The `Proofview.Goal.`*`enter` family of functions now takes a polymorphic continuation given as a record as an argument. + ```ocaml Proofview.Goal.enter begin fun gl -> ... end + ``` should be turned into + ```ocaml open Proofview.Notations Proofview.Goal.enter { enter = begin fun gl -> ... end } + ``` - `Tacexpr.TacDynamic(Loc.dummy_loc, Pretyping.constr_in c)` ---> `Tacinterp.Value.of_constr c` - `Vernacexpr.HintsResolveEntry(priority, poly, hnf, path, atom)` ---> `Vernacexpr.HintsResolveEntry(Vernacexpr.({hint_priority = priority; hint_pattern = None}), poly, hnf, path, atom)` - `Pretyping.Termops.mem_named_context` ---> `Engine.Termops.mem_named_context_val` - (`Global.named_context` ---> `Global.named_context_val`) - (`Context.Named.lookup` ---> `Environ.lookup_named_val`) +- `Global.named_context` ---> `Global.named_context_val` +- `Context.Named.lookup` ---> `Environ.lookup_named_val` -** Search API ** +### Search API The main search functions now take a function iterating over the results. This allows for clients to use streaming or more economic printing. -========================================= -= CHANGES BETWEEN COQ V8.4 AND COQ V8.5 = -========================================= +## Changes between Coq 8.4 and Coq 8.5 -** Refactoring : more mli interfaces and simpler grammar.cma ** +### Refactoring : more mli interfaces and simpler grammar.cma - A new directory intf/ now contains mli-only interfaces : - Constrexpr : definition of constr_expr, was in Topconstr - Decl_kinds : now contains binding_kind = Explicit | Implicit - Evar_kinds : type Evar_kinds.t was previously Evd.hole_kind - Extend : was parsing/extend.mli - Genredexpr : regroup Glob_term.red_expr_gen and Tacexpr.glob_red_flag - Glob_term : definition of glob_constr - Locus : definition of occurrences and stuff about clauses - Misctypes : intro_pattern_expr, glob_sort, cast_type, or_var, ... - Notation_term : contains notation_constr, was Topconstr.aconstr - Pattern : contains constr_pattern - Tacexpr : was tactics/tacexpr.ml - Vernacexpr : was toplevel/vernacexpr.ml + * `Constrexpr` : definition of `constr_expr`, was in `Topconstr` + * `Decl_kinds` : now contains `binding_kind = Explicit | Implicit` + * `Evar_kinds` : type `Evar_kinds.t` was previously `Evd.hole_kind` + * `Extend` : was `parsing/extend.mli` + * `Genredexpr` : regroup `Glob_term.red_expr_gen` and `Tacexpr.glob_red_flag` + * `Glob_term` : definition of `glob_constr` + * `Locus` : definition of occurrences and stuff about clauses + * `Misctypes` : `intro_pattern_expr`, `glob_sort`, `cast_type`, `or_var`, ... + * `Notation_term` : contains `notation_constr`, was `Topconstr.aconstr` + * `Pattern` : contains `constr_pattern` + * `Tacexpr` : was `tactics/tacexpr.ml` + * `Vernacexpr` : was `toplevel/vernacexpr.ml` - Many files have been divided : - vernacexpr: vernacexpr.mli + Locality - decl_kinds: decl_kinds.mli + Kindops - evd: evar_kinds.mli + evd - tacexpr: tacexpr.mli + tacops - glob_term: glob_term.mli + glob_ops + genredexpr.mli + redops - topconstr: constrexpr.mli + constrexpr_ops - + notation_expr.mli + notation_ops + topconstr - pattern: pattern.mli + patternops - libnames: libnames (qualid, reference) + globnames (global_reference) - egrammar: egramml + egramcoq + * vernacexpr: vernacexpr.mli + Locality + * decl_kinds: decl_kinds.mli + Kindops + * evd: evar_kinds.mli + evd + * tacexpr: tacexpr.mli + tacops + * glob_term: glob_term.mli + glob_ops + genredexpr.mli + redops + * topconstr: constrexpr.mli + constrexpr_ops + + notation_expr.mli + notation_ops + topconstr + * pattern: pattern.mli + patternops + * libnames: libnames (qualid, reference) + globnames (global_reference) + * egrammar: egramml + egramcoq - New utility files : miscops (cf. misctypes.mli) and redops (cf genredexpr.mli). @@ -686,11 +720,11 @@ printing. letin_pat_tac do not accept a type anymore - New file find_subterm.ml for gathering former functions - subst_closed_term_occ_modulo, subst_closed_term_occ_decl (which now - take and outputs also an evar_map), and - subst_closed_term_occ_modulo, subst_closed_term_occ_decl_modulo (now - renamed into replace_term_occ_modulo and - replace_term_occ_decl_modulo). + `subst_closed_term_occ_modulo`, `subst_closed_term_occ_decl` (which now + take and outputs also an `evar_map`), and + `subst_closed_term_occ_modulo`, `subst_closed_term_occ_decl_modulo` (now + renamed into `replace_term_occ_modulo` and + `replace_term_occ_decl_modulo`). - API of Inductiveops made more uniform (see commit log or file itself). @@ -704,36 +738,34 @@ printing. - All functions taking an env and a sigma (or an evdref) now takes the env first. -========================================= -= CHANGES BETWEEN COQ V8.3 AND COQ V8.4 = -========================================= +## Changes between Coq 8.3 and Coq 8.4 -** Functions in unification.ml have now the evar_map coming just after the env +- Functions in unification.ml have now the evar_map coming just after the env -** Removal of Tacinterp.constr_of_id ** +- Removal of Tacinterp.constr_of_id Use instead either global_reference or construct_reference in constrintern.ml. -** Optimizing calls to Evd functions ** +- Optimizing calls to Evd functions Evars are split into defined evars and undefined evars; for efficiency, when an evar is known to be undefined, it is preferable to use specific functions about undefined evars since these ones are generally fewer than the defined ones. -** Type changes in TACTIC EXTEND rules ** +- Type changes in TACTIC EXTEND rules Arguments bound with tactic(_) in TACTIC EXTEND rules are now of type glob_tactic_expr, instead of glob_tactic_expr * tactic. Only the first component is kept, the second one can be obtained via Tacinterp.eval_tactic. -** ARGUMENT EXTEND ** +- ARGUMENT EXTEND It is now forbidden to use TYPED simultaneously with {RAW,GLOB}_TYPED in ARGUMENT EXTEND statements. -** Renaming of rawconstr to glob_constr ** +- Renaming of rawconstr to glob_constr The "rawconstr" type has been renamed to "glob_constr" for consistency. The "raw" in everything related to former rawconstr has @@ -743,62 +775,67 @@ scripts to migrate code using Coq's internals, see commits 13743, 2010) in Subversion repository. Contribs have been fixed too, and commit messages there might also be helpful for migrating. -========================================= -= CHANGES BETWEEN COQ V8.2 AND COQ V8.3 = -========================================= +## Changes between Coq 8.2 and Coq 8.3 -** Light cleaning in evarutil.ml ** +### Light cleaning in evaruil.ml whd_castappevar is now whd_head_evar obsolete whd_ise disappears -** Restructuration of the syntax of binders ** +### Restructuration of the syntax of binders +``` binders_let -> binders binders_let_fixannot -> binders_fixannot binder_let -> closed_binder (and now covers only bracketed binders) binder was already obsolete and has been removed +``` -** Semantical change of h_induction_destruct ** +### Semantical change of h_induction_destruct Warning, the order of the isrec and evar_flag was inconsistent and has been permuted. Tactic induction_destruct in tactics.ml is unchanged. -** Internal tactics renamed +### Internal tactics renamed There is no more difference between bindings and ebindings. The following tactics are therefore renamed +``` apply_with_ebindings_gen -> apply_with_bindings_gen left_with_ebindings -> left_with_bindings right_with_ebindings -> right_with_bindings split_with_ebindings -> split_with_bindings +``` and the following tactics are removed -apply_with_ebindings (use instead apply_with_bindings) -eapply_with_ebindings (use instead eapply_with_bindings) + - apply_with_ebindings (use instead apply_with_bindings) + - eapply_with_ebindings (use instead eapply_with_bindings) -** Obsolete functions in typing.ml +### Obsolete functions in typing.ml For mtype_of, msort_of, mcheck, now use type_of, sort_of, check -** Renaming functions renamed +### Renaming functions renamed +``` concrete_name -> compute_displayed_name_in concrete_let_name -> compute_displayed_let_name_in rename_rename_bound_var -> rename_bound_vars_as_displayed lookup_name_as_renamed -> lookup_name_as_displayed next_global_ident_away true -> next_ident_away_in_goal next_global_ident_away false -> next_global_ident_away +``` -** Cleaning in commmand.ml +### Cleaning in commmand.ml Functions about starting/ending a lemma are in lemmas.ml Functions about inductive schemes are in indschemes.ml Functions renamed: +``` declare_one_assumption -> declare_assumption declare_assumption -> declare_assumptions Command.syntax_definition -> Metasyntax.add_syntactic_definition @@ -815,15 +852,17 @@ instantiate_type_indrec_scheme -> weaken_sort_scheme instantiate_indrec_scheme -> modify_sort_scheme make_case_dep, make_case_nodep -> build_case_analysis_scheme make_case_gen -> build_case_analysis_scheme_default +``` Types: decl_notation -> decl_notation option -** Cleaning in libnames/nametab interfaces +### Cleaning in libnames/nametab interfaces Functions: +``` dirpath_prefix -> pop_dirpath extract_dirpath_prefix pop_dirpath_n extend_dirpath -> add_dirpath_suffix @@ -837,17 +876,19 @@ absolute_reference -> global_of_path locate_syntactic_definition -> locate_syndef path_of_syntactic_definition -> path_of_syndef push_syntactic_definition -> push_syndef +``` Types: section_path -> full_path -** Cleaning in parsing extensions (commit 12108) +### Cleaning in parsing extensions (commit 12108) Many moves and renamings, one new file (Extrawit, that contains wit_tactic). -** Cleaning in tactical.mli +### Cleaning in tactical.mli +``` tclLAST_HYP -> onLastHyp tclLAST_DECL -> onLastDecl tclLAST_NHYPS -> onNLastHypsId @@ -857,24 +898,21 @@ onLastHyp -> onLastHypId onNLastHyps -> onNLastDecls onClauses -> onClause allClauses -> allHypsAndConcl +``` -+ removal of various unused combinators on type "clause" - -========================================= -= CHANGES BETWEEN COQ V8.1 AND COQ V8.2 = -========================================= +and removal of various unused combinators on type "clause" -A few differences in Coq ML interfaces between Coq V8.1 and V8.2 -================================================================ +## Changes between Coq 8.1 and Coq 8.2 -** Datatypes +### Datatypes List of occurrences moved from "int list" to "Termops.occurrences" (an alias to "bool * int list") ETIdent renamed to ETName -** Functions +### Functions +``` Eauto: e_resolve_constr, vernac_e_resolve_constr -> simplest_eapply Tactics: apply_with_bindings -> apply_with_bindings_wo_evars Eauto.simplest_apply -> Hiddentac.h_simplest_apply @@ -884,98 +922,93 @@ Tactics.true_cut renamed into Tactics.assert_tac Constrintern.interp_constrpattern -> intern_constr_pattern Hipattern.match_with_conjunction is a bit more restrictive Hipattern.match_with_disjunction is a bit more restrictive +``` -** Universe names (univ.mli) +### Universe names (univ.mli) + ```ocaml base_univ -> type0_univ (* alias of Set is the Type hierarchy *) prop_univ -> type1_univ (* the type of Set in the Type hierarchy *) neutral_univ -> lower_univ (* semantic alias of Prop in the Type hierarchy *) is_base_univ -> is_type1_univ is_empty_univ -> is_lower_univ + ``` -** Sort names (term.mli) +### Sort names (term.mli) + ``` mk_Set -> set_sort mk_Prop -> prop_sort type_0 -> type1_sort - -========================================= -= CHANGES BETWEEN COQ V8.0 AND COQ V8.1 = -========================================= - -A few differences in Coq ML interfaces between Coq V8.0 and V8.1 -================================================================ - -** Functions - -Util: option_app -> option_map -Term: substl_decl -> subst_named_decl -Lib: library_part -> remove_section_part -Printer: prterm -> pr_lconstr -Printer: prterm_env -> pr_lconstr_env -Ppconstr: pr_sort -> pr_rawsort -Evd: in_dom, etc got standard ocaml names (i.e. mem, etc) -Pretyping: - - understand_gen_tcc and understand_gen_ltac merged into understand_ltac - - type_constraints can now say typed by a sort (use OfType to get the - previous behavior) -Library: import_library -> import_module - -** Constructors - -Declarations: mind_consnrealargs -> mind_consnrealdecls -NoRedun -> NoDup -Cast and RCast have an extra argument: you can recover the previous + ``` + +## Changes between Coq 8.0 and Coq 8.1 + +### Functions + +- Util: option_app -> option_map +- Term: substl_decl -> subst_named_decl +- Lib: library_part -> remove_section_part +- Printer: prterm -> pr_lconstr +- Printer: prterm_env -> pr_lconstr_env +- Ppconstr: pr_sort -> pr_rawsort +- Evd: in_dom, etc got standard ocaml names (i.e. mem, etc) +- Pretyping: + - understand_gen_tcc and understand_gen_ltac merged into understand_ltac + - type_constraints can now say typed by a sort (use OfType to get the + previous behavior) +- Library: import_library -> import_module + +### Constructors + + * Declarations: mind_consnrealargs -> mind_consnrealdecls + * NoRedun -> NoDup + * Cast and RCast have an extra argument: you can recover the previous behavior by setting the extra argument to "CastConv DEFAULTcast" and "DEFAULTcast" respectively -Names: "kernel_name" is now "constant" when argument of Term.Const -Tacexpr: TacTrueCut and TacForward(false,_,_) merged into new TacAssert -Tacexpr: TacForward(true,_,_) branched to TacLetTac + * Names: "kernel_name" is now "constant" when argument of Term.Const + * Tacexpr: TacTrueCut and TacForward(false,_,_) merged into new TacAssert + * Tacexpr: TacForward(true,_,_) branched to TacLetTac -** Modules +### Modules -module Decl_kinds: new interface -module Bigint: new interface -module Tacred spawned module Redexpr -module Symbols -> Notation -module Coqast, Ast, Esyntax, Termast, and all other modules related to old - syntax are removed -module Instantiate: integrated to Evd -module Pretyping now a functor: use Pretyping.Default instead + * module Decl_kinds: new interface + * module Bigint: new interface + * module Tacred spawned module Redexpr + * module Symbols -> Notation + * module Coqast, Ast, Esyntax, Termast, and all other modules related to old + syntax are removed + * module Instantiate: integrated to Evd + * module Pretyping now a functor: use Pretyping.Default instead -** Internal names +### Internal names OBJDEF and OBJDEF1 -> CANONICAL-STRUCTURE -** Tactic extensions +### Tactic extensions -- printers have an extra parameter which is a constr printer at high precedence -- the tactic printers have an extra arg which is the expected precedence -- level is now a precedence in declare_extra_tactic_pprule -- "interp" functions now of types the actual arg type, not its encapsulation - as a generic_argument + * printers have an extra parameter which is a constr printer at high precedence + * the tactic printers have an extra arg which is the expected precedence + * level is now a precedence in declare_extra_tactic_pprule + * "interp" functions now of types the actual arg type, not its encapsulation + as a generic_argument -========================================= -= CHANGES BETWEEN COQ V7.4 AND COQ V8.0 = -========================================= +## Changes between Coq 7.4 and Coq 8.0 See files in dev/syntax-v8 -============================================== -= MAIN CHANGES BETWEEN COQ V7.3 AND COQ V7.4 = -============================================== +## Main changes between Coq 7.4 and Coq 8.0 -CHANGES DUE TO INTRODUCTION OF MODULES -====================================== +### Changes due to introduction of modules -1.Kernel --------- +#### Kernel The module level has no effect on constr except for the structure of section_path. The type of unique names for constructions (what section_path served) is now called a kernel name and is defined by +```ocaml type uniq_ident = int * string * dir_path (* int may be enough *) type module_path = | MPfile of dir_path (* reference to physical module, e.g. file *) @@ -1002,7 +1035,8 @@ type kernel_name = module_path * dir_path * label Def u = ... end Def x := ... <M>.t ... <N>.O.u ... X.T.b ... L.A.a - +``` + <M> and <N> are self-references, X is a bound reference and L is a reference to a physical module. @@ -1019,14 +1053,13 @@ world. module_expr) and kernel/declarations.ml (type module_body and module_type_body). -2. Library ----------- +#### Library -i) tables +1. tables [Summaries] - the only change is the special treatment of the global environmet. -ii) objects +2. objects [Libobject] declares persistent objects, given with methods: * cache_function specifying how to add the object in the current @@ -1047,25 +1080,25 @@ Coq.Init.Datatypes.Fst) and kernel_name is its substitutive internal version such as (MPself<Datatypes#1>,[],"Fst") (see above) -What happens at the end of an interactive module ? -================================================== +#### What happens at the end of an interactive module ? + (or when a file is stored and reloaded from disk) All summaries (except Global environment) are reverted to the state from before the beginning of the module, and: -a) the objects (again, since last Declaremods.start_module or +1. the objects (again, since last Declaremods.start_module or Library.start_library) are classified using the classify_function. To simplify consider only those who returned Substitute _ or Keep _. -b) If the module is not a functor, the subst_function for each object of +2. If the module is not a functor, the subst_function for each object of the first group is called with the substitution [MPself "<Datatypes#1>" |-> MPfile "Coq.Init.Datatypes"]. Then the load_function is called for substituted objects and the "keep" object. (If the module is a library the substitution is done at reloading). -c) The objects which returned substitute are stored in the modtab +3. The objects which returned substitute are stored in the modtab together with the self ident of the module, and functor argument names if the module was a functor. @@ -1075,9 +1108,9 @@ c) The objects which returned substitute are stored in the modtab is evaluated -The difference between "substitute" and "keep" objects -======================================================== -i) The "keep" objects can _only_ reference other objects by section_paths +#### The difference between "substitute" and "keep" objects + +1. The "keep" objects can _only_ reference other objects by section_paths and qualids. They do not need the substitution function. They will work after end_module (or reloading a compiled library), @@ -1089,7 +1122,7 @@ These would typically be grammar rules, pretty printing rules etc. -ii) The "substitute" objects can _only_ reference objects by +2. The "substitute" objects can _only_ reference objects by kernel_names. They must have a valid subst_function. They will work after end_module _and_ after Module Z:=N or @@ -1098,17 +1131,18 @@ Module Z:=F(M). Other kinds of objects: -iii) "Dispose" - objects which do not survive end_module + +3. "Dispose" - objects which do not survive end_module As a consequence, objects which reference other objects sometimes by kernel_names and sometimes by section_path must be of this kind... -iv) "Anticipate" - objects which must be treated individually by +4. "Anticipate" - objects which must be treated individually by end_module (typically "REQUIRE" objects) -Writing subst_thing functions -============================= +#### Writing subst_thing functions + The subst_thing shoud not copy the thing if it hasn't actually changed. There are some cool emacs macros in dev/objects.el to help writing subst functions this way quickly and without errors. @@ -1123,15 +1157,13 @@ They are all (apart from constr, for now) written in the non-copying way. -Nametab -======= +#### Nametab Nametab has been made more uniform. For every kind of thing there is only one "push" function and one "locate" function. -Lib -=== +#### Lib library_segment is now a list of object_name * library_item, where object_name = section_path * kernel_name (see above) @@ -1139,20 +1171,19 @@ object_name = section_path * kernel_name (see above) New items have been added for open modules and module types -Declaremods -========== +#### Declaremods + Functions to declare interactive and noninteractive modules and module types. -Library -======= +#### Library + Uses Declaremods to actually communicate with Global and to register objects. -OTHER CHANGES -============= +### Other changes Internal representation of tactics bindings has changed (see type Rawterm.substitution). @@ -1169,258 +1200,48 @@ New parsing model for tactics and vernacular commands TACTIC EXTEND ... END to be used in ML files New organisation of THENS: -tclTHENS tac tacs : tacs is now an array -tclTHENSFIRSTn tac1 tacs tac2 : + +- tclTHENS tac tacs : tacs is now an array +- tclTHENSFIRSTn tac1 tacs tac2 : apply tac1 then, apply the array tacs on the first n subgoals and tac2 on the remaining subgoals (previously tclTHENST) -tclTHENSLASTn tac1 tac2 tacs : +- tclTHENSLASTn tac1 tac2 tacs : apply tac1 then, apply tac2 on the first subgoals and apply the array tacs on the last n subgoals -tclTHENFIRSTn tac1 tacs = tclTHENSFIRSTn tac1 tacs tclIDTAC (prev. tclTHENSI) -tclTHENLASTn tac1 tacs = tclTHENSLASTn tac1 tclIDTAC tacs -tclTHENFIRST tac1 tac2 = tclTHENFIRSTn tac1 [|tac2|] -tclTHENLAST tac1 tac2 = tclTHENLASTn tac1 [|tac2|] (previously tclTHENL) -tclTHENS tac1 tacs = tclTHENSFIRSTn tac1 tacs (fun _ -> error "wrong number") -tclTHENSV same as tclTHENS but with an array -tclTHENSi : no longer available +- tclTHENFIRSTn tac1 tacs = tclTHENSFIRSTn tac1 tacs tclIDTAC (prev. tclTHENSI) +- tclTHENLASTn tac1 tacs = tclTHENSLASTn tac1 tclIDTAC tacs +- tclTHENFIRST tac1 tac2 = tclTHENFIRSTn tac1 [|tac2|] +- tclTHENLAST tac1 tac2 = tclTHENLASTn tac1 [|tac2|] (previously tclTHENL) +- tclTHENS tac1 tacs = tclTHENSFIRSTn tac1 tacs (fun _ -> error "wrong number") +- tclTHENSV same as tclTHENS but with an array +- tclTHENSi : no longer available Proof_type: subproof field in type proof_tree glued with the ref field Tacmach: no more echo from functions of module Refiner Files plugins/*/g_*.ml4 take the place of files plugins/*/*.v. + Files parsing/{vernac,tac}extend.ml{4,i} implements TACTIC EXTEND andd VERNAC COMMAND EXTEND macros + File syntax/PPTactic.v moved to parsing/pptactic.ml + Tactics about False and not now in tactics/contradiction.ml + Tactics depending on Init now tactics/*.ml4 (no longer in tactics/*.v) + File tacinterp.ml moved from proofs to directory tactics -========================================== -= MAIN CHANGES FROM COQ V7.1 TO COQ V7.2 = -========================================== +## Changes between Coq 7.1 and Coq 7.2 The core of Coq (kernel) has meen minimized with the following effects: -kernel/term.ml split into kernel/term.ml, pretyping/termops.ml -kernel/reduction.ml split into kernel/reduction.ml, pretyping/reductionops.ml -kernel/names.ml split into kernel/names.ml, library/nameops.ml -kernel/inductive.ml split into kernel/inductive.ml, pretyping/inductiveops.ml +- kernel/term.ml split into kernel/term.ml, pretyping/termops.ml +- kernel/reduction.ml split into kernel/reduction.ml, pretyping/reductionops.ml +- kernel/names.ml split into kernel/names.ml, library/nameops.ml +- kernel/inductive.ml split into kernel/inductive.ml, pretyping/inductiveops.ml the prefixes "Is" ans "IsMut" have been dropped from kind_of_term constructors, e.g. IsRel is now Rel, IsMutCase is now Case, etc. - - -======================================================= -= PRINCIPAUX CHANGEMENTS ENTRE COQ V6.3.1 ET COQ V7.0 = -======================================================= - -Changements d'organisation / modules : --------------------------------------- - - Std, More_util -> lib/util.ml - - Names -> kernel/names.ml et kernel/sign.ml - (les parties noms et signatures ont été séparées) - - Avm,Mavm,Fmavm,Mhm -> utiliser plutôt Map (et freeze alors gratuit) - Mhb -> Bij - - Generic est intégré à Term (et un petit peu à Closure) - -Changements dans les types de données : ---------------------------------------- - dans Generic: free_rels : constr -> int Listset.t - devient : constr -> Intset.t - - type_judgement -> typed_type - environment -> context - context -> typed_type signature - - -ATTENTION: ----------- - - Il y a maintenant d'autres exceptions que UserError (TypeError, - RefinerError, etc.) - - Il ne faut donc plus se contenter (pour rattraper) de faire - - try . .. with UserError _ -> ... - - mais écrire à la place - - try ... with e when Logic.catchable_exception e -> ... - - -Changements dans les fonctions : --------------------------------- - - Vectops. - it_vect -> Array.fold_left - vect_it -> Array.fold_right - exists_vect -> Util.array_exists - for_all2eq_vect -> Util.array_for_all2 - tabulate_vect -> Array.init - hd_vect -> Util.array_hd - tl_vect -> Util.array_tl - last_vect -> Util.array_last - it_vect_from -> array_fold_left_from - vect_it_from -> array_fold_right_from - app_tl_vect -> array_app_tl - cons_vect -> array_cons - map_i_vect -> Array.mapi - map2_vect -> array_map2 - list_of_tl_vect -> array_list_of_tl - - Names - sign_it -> fold_var_context (se fait sur env maintenant) - it_sign -> fold_var_context_reverse (sur env maintenant) - - Generic - noccur_bet -> noccur_between - substn_many -> substnl - - Std - comp -> Util.compose - rev_append -> List.rev_append - - Termenv - mind_specif_of_mind -> Global.lookup_mind_specif - ou Environ.lookup_mind_specif si on a un env sous la main - mis_arity -> instantiate_arity - mis_lc -> instantiate_lc - - Ex-Environ - mind_of_path -> Global.lookup_mind - - Printer - gentermpr -> gen_pr_term - term0 -> prterm_env - pr_sign -> pr_var_context - pr_context_opt -> pr_context_of - pr_ne_env -> pr_ne_context_of - - Typing, Machops - type_of_type -> judge_of_type - fcn_proposition -> judge_of_prop_contents - safe_fmachine -> safe_infer - - Reduction, Clenv - whd_betadeltat -> whd_betaevar - whd_betadeltatiota -> whd_betaiotaevar - find_mrectype -> Inductive.find_mrectype - find_minductype -> Inductive.find_inductive - find_mcoinductype -> Inductive.find_coinductive - - Astterm - constr_of_com_casted -> interp_casted_constr - constr_of_com_sort -> interp_type - constr_of_com -> interp_constr - rawconstr_of_com -> interp_rawconstr - type_of_com -> type_judgement_of_rawconstr - judgement_of_com -> judgement_of_rawconstr - - Termast - bdize -> ast_of_constr - - Tacmach - pf_constr_of_com_sort -> pf_interp_type - pf_constr_of_com -> pf_interp_constr - pf_get_hyp -> pf_get_hyp_typ - pf_hyps, pf_untyped_hyps -> pf_env (tout se fait sur env maintenant) - - Pattern - raw_sopattern_of_compattern -> Astterm.interp_constrpattern - somatch -> is_matching - dest_somatch -> matches - - Tacticals - matches -> gl_is_matching - dest_match -> gl_matches - suff -> utiliser sort_of_goal - lookup_eliminator -> utiliser sort_of_goal pour le dernier arg - - Divers - initial_sign -> var_context - - Sign - ids_of_sign -> ids_of_var_context (or Environ.ids_of_context) - empty_sign -> empty_var_context - - Pfedit - list_proofs -> get_all_proof_names - get_proof -> get_current_proof_name - abort_goal -> abort_proof - abort_goals -> abort_all_proofs - abort_cur_goal -> abort_current_proof - get_evmap_sign -> get_goal_context/get_current_goal_context - unset_undo -> reset_undo - - Proof_trees - mkGOAL -> mk_goal - - Declare - machine_constant -> declare_constant (+ modifs) - - ex-Trad, maintenant Pretyping - inh_cast_rel -> Coercion.inh_conv_coerce_to - inh_conv_coerce_to -> Coercion.inh_conv_coerce_to_fail - ise_resolve1 -> understand, understand_type - ise_resolve -> understand_judgment, understand_type_judgment - - ex-Tradevar, maintenant Evarutil - mt_tycon -> empty_tycon - - Recordops - struc_info -> find_structure - -Changements dans les inductifs ------------------------------- -Nouveaux types "constructor" et "inductive" dans Term -La plupart des fonctions de typage des inductives prennent maintenant -un inductive au lieu d'un oonstr comme argument. Les seules fonctions -à traduire un constr en inductive sont les find_rectype and co. - -Changements dans les grammaires -------------------------------- - - . le lexer (parsing/lexer.mll) est maintenant un lexer ocamllex - - . attention : LIDENT -> IDENT (les identificateurs n'ont pas de - casse particulière dans Coq) - - . Le mot "command" est remplacé par "constr" dans les noms de - fichiers, noms de modules et non-terminaux relatifs au parsing des - termes; aussi les changements suivants "COMMAND"/"CONSTR" dans - g_vernac.ml4, VARG_COMMAND/VARG_CONSTR dans vernac*.ml* - - . Les constructeurs d'arguments de tactiques IDENTIFIER, CONSTR, ...n - passent en minuscule Identifier, Constr, ... - - . Plusieurs parsers ont changé de format (ex: sortarg) - -Changements dans le pretty-printing ------------------------------------ - - . Découplage de la traduction de constr -> rawconstr (dans detyping) - et de rawconstr -> ast (dans termast) - . Déplacement des options d'affichage de printer vers termast - . Déplacement des réaiguillage d'univers du pp de printer vers esyntax - - -Changements divers ------------------- - - . il n'y a plus de script coqtop => coqtop et coqtop.byte sont - directement le résultat du link du code - => debuggage et profiling directs - - . il n'y a plus d'installation locale dans bin/$ARCH - - . #use "include.ml" => #use "include" - go() => loop() - - . il y a "make depend" et "make dependcamlp4" car ce dernier prend beaucoup - de temps diff --git a/dev/doc/coq-src-description.txt b/dev/doc/coq-src-description.txt index 00e7f5c53c..2dbd132da7 100644 --- a/dev/doc/coq-src-description.txt +++ b/dev/doc/coq-src-description.txt @@ -14,11 +14,6 @@ parsing tactics toplevel -highparsing : - - Files in parsing/ that cannot be linked too early. - Contains the grammar rules g_*.ml4 - Special components ------------------ diff --git a/dev/doc/xml-protocol.md b/dev/doc/xml-protocol.md index 127b4a6d2d..cf7d205d8b 100644 --- a/dev/doc/xml-protocol.md +++ b/dev/doc/xml-protocol.md @@ -291,7 +291,10 @@ Pseudocode for listing all of the goals in order: `rev (flat_map fst background) ### <a name="command-status">**Status(force: bool)**</a> -CoqIDE typically sets `force` to `false`. +Returns information about the current proofs. CoqIDE typically sends this +message with `force = false` after each sentence, and with `force = true` if +the user wants to force the checking of all proofs (wheels button). In terms of +the STM API, `force` triggers a `Join`. ```html <call val="Status"><bool val="${force}"/></call> ``` diff --git a/doc/refman/AddRefMan-pre.tex b/doc/refman/AddRefMan-pre.tex index eee41a6798..856a823de0 100644 --- a/doc/refman/AddRefMan-pre.tex +++ b/doc/refman/AddRefMan-pre.tex @@ -4,6 +4,7 @@ \setheaders{Presentation of the Addendum} %END LATEX \chapter*{Presentation of the Addendum} +%HEVEA\cutname{addendum.html} Here you will find several pieces of additional documentation for the \Coq\ Reference Manual. Each of this chapters is concentrated on a diff --git a/doc/refman/AsyncProofs.tex b/doc/refman/AsyncProofs.tex index 1609e4a041..30039d4898 100644 --- a/doc/refman/AsyncProofs.tex +++ b/doc/refman/AsyncProofs.tex @@ -1,4 +1,5 @@ \achapter{Asynchronous and Parallel Proof Processing} +%HEVEA\cutname{async-proofs.html} \aauthor{Enrico Tassi} \label{pralitp} diff --git a/doc/refman/CanonicalStructures.tex b/doc/refman/CanonicalStructures.tex index 275e1c2d55..8961b00964 100644 --- a/doc/refman/CanonicalStructures.tex +++ b/doc/refman/CanonicalStructures.tex @@ -1,4 +1,5 @@ \achapter{Canonical Structures} +%HEVEA\cutname{canonical-structures.html} \aauthor{Assia Mahboubi and Enrico Tassi} \label{CS-full} diff --git a/doc/refman/Cases.tex b/doc/refman/Cases.tex index a95d8114ff..7ad895f9d8 100644 --- a/doc/refman/Cases.tex +++ b/doc/refman/Cases.tex @@ -1,4 +1,5 @@ \achapter{Extended pattern-matching} +%HEVEA\cutname{cases.html} %BEGIN LATEX \defaultheaders %END LATEX diff --git a/doc/refman/Classes.tex b/doc/refman/Classes.tex index 7e07868a38..22c75b4fc8 100644 --- a/doc/refman/Classes.tex +++ b/doc/refman/Classes.tex @@ -6,6 +6,7 @@ \newcommand\tele[1]{\overrightarrow{#1}} \achapter{\protect{Type Classes}} +%HEVEA\cutname{type-classes.html} \aauthor{Matthieu Sozeau} \label{typeclasses} diff --git a/doc/refman/Coercion.tex b/doc/refman/Coercion.tex index 16006a6adf..ec46e1eb58 100644 --- a/doc/refman/Coercion.tex +++ b/doc/refman/Coercion.tex @@ -1,4 +1,5 @@ \achapter{Implicit Coercions} +%HEVEA\cutname{coercions.html} \aauthor{Amokrane Saïbi} \label{Coercions-full} diff --git a/doc/refman/Extraction.tex b/doc/refman/Extraction.tex index 499239b6f3..83e866e9f3 100644 --- a/doc/refman/Extraction.tex +++ b/doc/refman/Extraction.tex @@ -1,4 +1,5 @@ \achapter{Extraction of programs in Objective Caml and Haskell} +%HEVEA\cutname{extraction.html} \label{Extraction} \aauthor{Jean-Christophe Filliâtre and Pierre Letouzey} \index{Extraction} diff --git a/doc/refman/Micromega.tex b/doc/refman/Micromega.tex index 4daf98f87a..2617142f5a 100644 --- a/doc/refman/Micromega.tex +++ b/doc/refman/Micromega.tex @@ -1,4 +1,5 @@ \achapter{Micromega: tactics for solving arithmetic goals over ordered rings} +%HEVEA\cutname{micromega.html} \aauthor{Frédéric Besson and Evgeny Makarov} \newtheorem{theorem}{Theorem} diff --git a/doc/refman/Misc.tex b/doc/refman/Misc.tex index e953d2f709..ab00fbfe37 100644 --- a/doc/refman/Misc.tex +++ b/doc/refman/Misc.tex @@ -1,4 +1,5 @@ \achapter{\protect{Miscellaneous extensions}} +%HEVEA\cutname{miscellaneous.html} \asection{Program derivation} diff --git a/doc/refman/Nsatz.tex b/doc/refman/Nsatz.tex index 70e36a5ee9..1401af10f6 100644 --- a/doc/refman/Nsatz.tex +++ b/doc/refman/Nsatz.tex @@ -1,4 +1,5 @@ \achapter{Nsatz: tactics for proving equalities in integral domains} +%HEVEA\cutname{nsatz.html} \aauthor{Loïc Pottier} The tactic \texttt{nsatz} proves goals of the form diff --git a/doc/refman/Omega.tex b/doc/refman/Omega.tex index 1610305e75..8025fbe29f 100644 --- a/doc/refman/Omega.tex +++ b/doc/refman/Omega.tex @@ -1,5 +1,6 @@ \achapter{Omega: a solver of quantifier-free problems in Presburger Arithmetic} +%HEVEA\cutname{omega.html} \aauthor{Pierre Crégut} \label{OmegaChapter} diff --git a/doc/refman/Polynom.tex b/doc/refman/Polynom.tex index 77d5928345..d9b8b8c522 100644 --- a/doc/refman/Polynom.tex +++ b/doc/refman/Polynom.tex @@ -1,4 +1,5 @@ \achapter{The \texttt{ring} and \texttt{field} tactic families} +%HEVEA\cutname{ring.html} \aauthor{Bruno Barras, Benjamin Gr\'egoire, Assia Mahboubi, Laurent Th\'ery\footnote{based on previous work from Patrick Loiseleur and Samuel Boutin}} diff --git a/doc/refman/Program.tex b/doc/refman/Program.tex index f60908da6c..1e204dc83d 100644 --- a/doc/refman/Program.tex +++ b/doc/refman/Program.tex @@ -1,4 +1,5 @@ \achapter{\Program{}} +%HEVEA\cutname{program.html} \label{Program} \aauthor{Matthieu Sozeau} \index{Program} diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index ad795d4064..0dbfe05d48 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -2,6 +2,7 @@ \label{Cic} \index{Cic@\textsc{CIC}} \index{Calculus of Inductive Constructions}} +%HEVEA\cutname{cic.html} The underlying formal language of {\Coq} is a {\em Calculus of Inductive Constructions} (\CIC) whose inference rules are presented in diff --git a/doc/refman/RefMan-com.tex b/doc/refman/RefMan-com.tex index 45230fb6e5..9790111f14 100644 --- a/doc/refman/RefMan-com.tex +++ b/doc/refman/RefMan-com.tex @@ -2,6 +2,7 @@ \ttindex{coqtop} \ttindex{coqc} \ttindex{coqchk}} +%HEVEA\cutname{commands.html} There are three \Coq~commands: \begin{itemize} diff --git a/doc/refman/RefMan-ext.tex b/doc/refman/RefMan-ext.tex index 713f344cbe..b27a4dc943 100644 --- a/doc/refman/RefMan-ext.tex +++ b/doc/refman/RefMan-ext.tex @@ -1,4 +1,5 @@ \chapter[Extensions of \Gallina{}]{Extensions of \Gallina{}\label{Gallina-extension}\index{Gallina}} +%HEVEA\cutname{gallina-ext.html} {\gallina} is the kernel language of {\Coq}. We describe here extensions of the Gallina's syntax. @@ -279,15 +280,78 @@ of the chapter devoted to coercions. \label{prim-proj} The option {\tt Set Primitive Projections} turns on the use of primitive -projections when defining subsequent records. Primitive projections +projections when defining subsequent records (even through the {\tt + Inductive} and {\tt CoInductive} commands). Primitive projections extended the Calculus of Inductive Constructions with a new binary term constructor {\tt r.(p)} representing a primitive projection p applied to a record object {\tt r} (i.e., primitive projections are always applied). Even if the record type has parameters, these do not appear at applications of the projection, considerably reducing the sizes of terms when manipulating parameterized records and typechecking time. On the -user level, primitive projections are a transparent replacement -for the usual defined ones. +user level, primitive projections can be used as a replacement for the +usual defined ones, although there are a few notable differences. + +The internally omitted parameters can be reconstructed at printing time +even though they are absent in the actual AST manipulated by the kernel. This +can be obtained by setting the {\tt Printing Primitive Projection Parameters} +flag. Another compatibility printing can be activated thanks to the +{\tt Printing Primitive Projection Compatibility} option which governs the +printing of pattern-matching over primitive records. + +\subsubsection{Primitive Record Types} +When the {\tt Set Primitive Projections} option is on, definitions of +record types change meaning. When a type is declared with primitive +projections, its {\tt match} construct is disabled (see +\ref{primproj:compat} though). To eliminate the (co-)inductive type, one +must use its defined primitive projections. + +There are currently two ways to introduce primitive records types: +\begin{itemize} +\item Through the {\tt Record} command, in which case the type has to be + non-recursive. The defined type enjoys eta-conversion definitionally, + that is the generalized form of surjective pairing for records: + {\tt $r$ = Build\_R ($r$.($p_1$) .. $r$.($p_n$))}. Eta-conversion allows to define + dependent elimination for these types as well. +\item Through the {\tt Inductive} and {\tt CoInductive} commands, when + the body of the definition is a record declaration of the form {\tt + Build\_R \{ $p_1$ : $t_1$; .. ; $p_n$ : $t_n$ \}}. In this case the types can be + recursive and eta-conversion is disallowed. These kind of record types + differ from their traditional versions in the sense that dependent + elimination is not available for them and only non-dependent case analysis + can be defined. +\end{itemize} + +\subsubsection{Reduction} + +The basic reduction rule of a primitive projection is {\tt $p_i$ + (Build\_R $t_1$ .. $t_n$) $\rightarrow_{\iota}$ $t_i$}. However, to take the $\delta$ flag into +account, projections can be in two states: folded or unfolded. An +unfolded primitive projection application obeys the rule above, while +the folded version delta-reduces to the unfolded version. This allows to +precisely mimic the usual unfolding rules of constants. Projections +obey the usual {\tt simpl} flags of the {\tt Arguments} command in particular. + +There is currently no way to input unfolded primitive projections at the +user-level, and one must use the {\tt Printing Primitive Projection + Compatibility} to display unfolded primitive projections as matches +and distinguish them from folded ones. + +\subsubsection{Compatibility Projections and {\tt match}} +\label{primproj:compat} +To ease compatibility with ordinary record types, each primitive +projection is also defined as a ordinary constant taking parameters and +an object of the record type as arguments, and whose body is an +application of the unfolded primitive projection of the same name. These +constants are used when elaborating partial applications of the +projection. One can distinguish them from applications of the primitive +projection if the {\tt Printing Primitive Projection Parameters} option +is off: for a primitive projection application, parameters are printed +as underscores while for the compatibility projections they are printed +as usual. + +Additionally, user-written {\tt match} constructs on primitive records +are desugared into substitution of the projections, they cannot be +printed back as {\tt match} constructs. % - r.(p) and (p r) elaborate to native projection application, and % the parameters cannot be mentioned. The following arguments are @@ -305,13 +369,6 @@ for the usual defined ones. % - [pattern x at n], [rewrite x at n] and in general abstraction and selection % of occurrences may fail due to the disappearance of parameters. -The internally omitted parameters can be reconstructed at printing time -even though they are absent in the actual AST manipulated by the kernel. This -can be obtained by setting the {\tt Printing Primitive Projection Parameters} -flag. Another compatibility printing can be activated thanks to the -{\tt Printing Primitive Projection Compatibility} option which governs the -printing of pattern-matching over primitive records. - \section{Variants and extensions of {\mbox{\tt match}} \label{Extensions-of-match} \index{match@{\tt match\ldots with\ldots end}}} @@ -1664,7 +1721,7 @@ to be given as if none arguments were implicit. By symmetry, this also affects printing. To restore parsing and normal printing of implicit arguments, use: \begin{quote} -{\tt Set Parsing Explicit.} +{\tt Unset Parsing Explicit.} \end{quote} \subsection{Canonical structures diff --git a/doc/refman/RefMan-gal.tex b/doc/refman/RefMan-gal.tex index ef12fe416a..df0cd2b825 100644 --- a/doc/refman/RefMan-gal.tex +++ b/doc/refman/RefMan-gal.tex @@ -1,5 +1,6 @@ \chapter{The \gallina{} specification language \label{Gallina}\index{Gallina}} +%HEVEA\cutname{gallina.html} \label{BNF-syntax} % Used referred to as a chapter label This chapter describes \gallina, the specification language of {\Coq}. diff --git a/doc/refman/RefMan-ide.tex b/doc/refman/RefMan-ide.tex index c6fbd1c538..75f3d18ded 100644 --- a/doc/refman/RefMan-ide.tex +++ b/doc/refman/RefMan-ide.tex @@ -1,5 +1,6 @@ \chapter[\Coq{} Integrated Development Environment]{\Coq{} Integrated Development Environment\label{Addoc-coqide} \ttindex{coqide}} +%HEVEA\cutname{coqide.html} The \Coq{} Integrated Development Environment is a graphical tool, to be used as a user-friendly replacement to \texttt{coqtop}. Its main diff --git a/doc/refman/RefMan-int.tex b/doc/refman/RefMan-int.tex index 2b9e4e6051..f802a35950 100644 --- a/doc/refman/RefMan-int.tex +++ b/doc/refman/RefMan-int.tex @@ -2,6 +2,7 @@ \setheaders{Introduction} %END LATEX \chapter*{Introduction} +%HEVEA\cutname{introduction.html} This document is the Reference Manual of version \coqversion{} of the \Coq\ proof assistant. A companion volume, the \Coq\ Tutorial, is provided diff --git a/doc/refman/RefMan-lib.tex b/doc/refman/RefMan-lib.tex index 4ebb484e7c..c8e8443026 100644 --- a/doc/refman/RefMan-lib.tex +++ b/doc/refman/RefMan-lib.tex @@ -1,4 +1,5 @@ \chapter[The {\Coq} library]{The {\Coq} library\index{Theories}\label{Theories}} +%HEVEA\cutname{stdlib.html} The \Coq\ library is structured into two parts: diff --git a/doc/refman/RefMan-ltac.tex b/doc/refman/RefMan-ltac.tex index 3ce1d4ecd8..574591185c 100644 --- a/doc/refman/RefMan-ltac.tex +++ b/doc/refman/RefMan-ltac.tex @@ -1,4 +1,5 @@ \chapter[The tactic language]{The tactic language\label{TacticLanguage}} +%HEVEA\cutname{ltac.html} %\geometry{a4paper,body={5in,8in}} @@ -1105,19 +1106,14 @@ Fail all:let n:= numgoals in guard n=2. Reset Initial. \end{coq_eval} -\subsubsection[Proving a subgoal as a separate lemma]{Proving a subgoal as a separate lemma\tacindex{abstract}\tacindex{transparent\_abstract}\comindex{Qed exporting} +\subsubsection[Proving a subgoal as a separate lemma]{Proving a subgoal as a separate lemma\tacindex{abstract}\tacindex{transparent\_abstract} \index{Tacticals!abstract@{\tt abstract}}\index{Tacticals!transparent\_abstract@{\tt transparent\_abstract}}} From the outside ``\texttt{abstract \tacexpr}'' is the same as {\tt solve \tacexpr}. Internally it saves an auxiliary lemma called {\ident}\texttt{\_subproof}\textit{n} where {\ident} is the name of the current goal and \textit{n} is chosen so that this is a fresh name. -Such auxiliary lemma is inlined in the final proof term -unless the proof is ended with ``\texttt{Qed exporting}''. In such -case the lemma is preserved. The syntax -``\texttt{Qed exporting }\ident$_1$\texttt{, ..., }\ident$_n$'' -is also supported. In such case the system checks that the names given by the -user actually exist when the proof is ended. +Such an auxiliary lemma is inlined in the final proof term. This tactical is useful with tactics such as \texttt{omega} or \texttt{discriminate} that generate huge proof terms. With that tool diff --git a/doc/refman/RefMan-modr.tex b/doc/refman/RefMan-modr.tex index 2019a529fe..7c672cf422 100644 --- a/doc/refman/RefMan-modr.tex +++ b/doc/refman/RefMan-modr.tex @@ -1,4 +1,5 @@ \chapter[The Module System]{The Module System\label{chapter:Modules}} +%HEVEA\cutname{modules.html} The module system extends the Calculus of Inductive Constructions providing a convenient way to structure large developments as well as diff --git a/doc/refman/RefMan-oth.tex b/doc/refman/RefMan-oth.tex index 8f43ebcfbc..60cd8b73a4 100644 --- a/doc/refman/RefMan-oth.tex +++ b/doc/refman/RefMan-oth.tex @@ -1,5 +1,6 @@ \chapter[Vernacular commands]{Vernacular commands\label{Vernacular-commands} \label{Other-commands}} +%HEVEA\cutname{vernacular.html} \section{Displaying} diff --git a/doc/refman/RefMan-pre.tex b/doc/refman/RefMan-pre.tex index 0c2a18eb2e..991c9745e9 100644 --- a/doc/refman/RefMan-pre.tex +++ b/doc/refman/RefMan-pre.tex @@ -2,6 +2,7 @@ \setheaders{Credits} %END LATEX \chapter*{Credits} +%HEVEA\cutname{credits.html} %\addcontentsline{toc}{section}{Credits} \Coq{}~ is a proof assistant for higher-order logic, allowing the diff --git a/doc/refman/RefMan-pro.tex b/doc/refman/RefMan-pro.tex index eb59ca584e..8f659ded35 100644 --- a/doc/refman/RefMan-pro.tex +++ b/doc/refman/RefMan-pro.tex @@ -1,5 +1,6 @@ \chapter[Proof handling]{Proof handling\index{Proof editing} \label{Proof-handling}} +%HEVEA\cutname{proof-handling.html} In \Coq's proof editing mode all top-level commands documented in Chapter~\ref{Vernacular-commands} remain available diff --git a/doc/refman/RefMan-sch.tex b/doc/refman/RefMan-sch.tex index 23a1c9b029..956f308512 100644 --- a/doc/refman/RefMan-sch.tex +++ b/doc/refman/RefMan-sch.tex @@ -1,4 +1,5 @@ \chapter{Proof schemes} +%HEVEA\cutname{schemes.html} \section{Generation of induction principles with {\tt Scheme}} \label{Scheme} diff --git a/doc/refman/RefMan-ssr.tex b/doc/refman/RefMan-ssr.tex index 61f7421c44..be199e0b24 100644 --- a/doc/refman/RefMan-ssr.tex +++ b/doc/refman/RefMan-ssr.tex @@ -1,4 +1,5 @@ \achapter{The SSReflect proof language} +%HEVEA\cutname{ssreflect.html} \aauthor{Georges Gonthier, Assia Mahboubi, Enrico Tassi} \newcommand{\ssr}{{\sc SSReflect}} @@ -42,7 +43,7 @@ Proofs written in \ssr{} typically look quite different from the ones written using only tactics as per Chapter~\ref{Tactics}. We try to summarise here the most ``visible'' ones in order to help the reader already accustomed to the tactics described in -Chapter~\ref{Tactics}to read this chapter. +Chapter~\ref{Tactics} to read this chapter. The first difference between the tactics described in this chapter and the tactics described in Chapter~\ref{Tactics} is the way @@ -79,19 +80,19 @@ expansion and partial evaluation participate all to a same concept of rewriting a goal in a larger sense. As such, all these functionalities are provided by the \ssrC{rewrite} tactic. -\ssrC{} includes a little language of patterns to select subterms in tactics +\ssr{} includes a little language of patterns to select subterms in tactics or tacticals where it matters. Its most notable application is in the \ssrC{rewrite} tactic, where patterns are used to specify where the rewriting step has to take place. -Finally, \ssr{} supports the so-called reflection steps, typically +Finally, \ssr{} supports so-called reflection steps, typically allowing to switch back and forth between the computational view and logical view of a concept. To conclude it is worth mentioning that \ssr{} tactics can be mixed with non \ssr{} tactics in the same proof, -or in the same LTac expression. The few exceptions -to this statement are described in section~\label{sec:compat}. +or in the same Ltac expression. The few exceptions +to this statement are described in section~\ref{sec:compat}. \iffalse %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -130,7 +131,7 @@ ProofGeneral provided in the distribution: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection*{Acknowledgments} -The authors would like to thank Fr\'ed\'eric Blanqui, Fran\,cois Pottier +The authors would like to thank Frédéric Blanqui, François Pottier and Laurence Rideau for their comments and suggestions. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% diff --git a/doc/refman/RefMan-syn.tex b/doc/refman/RefMan-syn.tex index d8a353300f..eecb5ac7c0 100644 --- a/doc/refman/RefMan-syn.tex +++ b/doc/refman/RefMan-syn.tex @@ -1,4 +1,5 @@ \chapter[Syntax extensions and interpretation scopes]{Syntax extensions and interpretation scopes\label{Addoc-syntax}} +%HEVEA\cutname{syntax-extensions.html} In this chapter, we introduce advanced commands to modify the way {\Coq} parses and prints objects, i.e. the translations between the diff --git a/doc/refman/RefMan-tac.tex b/doc/refman/RefMan-tac.tex index 6e27357008..a2d45046b0 100644 --- a/doc/refman/RefMan-tac.tex +++ b/doc/refman/RefMan-tac.tex @@ -3,6 +3,7 @@ \chapter{Tactics \index{Tactics} \label{Tactics}} +%HEVEA\cutname{tactics.html} A deduction rule is a link between some (unique) formula, that we call the {\em conclusion} and (several) formulas that we call the {\em @@ -3309,7 +3310,7 @@ evaluating purely computational expressions (i.e. with little dead code). fine-tuned. It is specially interesting for full evaluation of algebraic objects. This includes the case of reflection-based tactics. -\item {\tt native\_compute} \tacindex{native\_compute} +\item {\tt native\_compute} \tacindex{native\_compute} \optindex{NativeCompute Profiling} This tactic evaluates the goal by compilation to \ocaml{} as described in \cite{FullReduction}. If \Coq{} is running in native code, it can be typically diff --git a/doc/refman/RefMan-tacex.tex b/doc/refman/RefMan-tacex.tex index cb8f916f13..7cdb1a5274 100644 --- a/doc/refman/RefMan-tacex.tex +++ b/doc/refman/RefMan-tacex.tex @@ -1,4 +1,5 @@ \chapter[Detailed examples of tactics]{Detailed examples of tactics\label{Tactics-examples}} +%HEVEA\cutname{tactic-examples.html} This chapter presents detailed examples of certain tactics, to illustrate their behavior. diff --git a/doc/refman/RefMan-uti.tex b/doc/refman/RefMan-uti.tex index f6371f8e5c..ed41e32161 100644 --- a/doc/refman/RefMan-uti.tex +++ b/doc/refman/RefMan-uti.tex @@ -1,4 +1,5 @@ \chapter[Utilities]{Utilities\label{Utilities}} +%HEVEA\cutname{tools.html} The distribution provides utilities to simplify some tedious works beside proof development, tactics writing or documentation. diff --git a/doc/refman/Setoid.tex b/doc/refman/Setoid.tex index 0c8cd408f2..b7b343112f 100644 --- a/doc/refman/Setoid.tex +++ b/doc/refman/Setoid.tex @@ -1,6 +1,7 @@ \newtheorem{cscexample}{Example} \achapter{\protect{Generalized rewriting}} +%HEVEA\cutname{setoid.html} \aauthor{Matthieu Sozeau} \label{setoids} diff --git a/doc/refman/Universes.tex b/doc/refman/Universes.tex index 6ea2537399..75fac9454a 100644 --- a/doc/refman/Universes.tex +++ b/doc/refman/Universes.tex @@ -1,4 +1,5 @@ \achapter{Polymorphic Universes} +%HEVEA\cutname{universes.html} \aauthor{Matthieu Sozeau} \label{Universes-full} diff --git a/engine/eConstr.ml b/engine/eConstr.ml index 7b879a8031..a54c082979 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -566,7 +566,6 @@ let compare_constr sigma cmp c1 c2 = let cmp c1 c2 = cmp (of_constr c1) (of_constr c2) in compare_gen kind (fun _ -> Univ.Instance.equal) Sorts.equal cmp (unsafe_to_constr c1) (unsafe_to_constr c2) -(** TODO: factorize with universes.ml *) let test_constr_universes sigma leq m n = let open Universes in let kind c = kind_upto sigma c in @@ -574,14 +573,20 @@ let test_constr_universes sigma leq m n = else let cstrs = ref Constraints.empty in let eq_universes strict l l' = + let l = EInstance.kind sigma (EInstance.make l) in + let l' = EInstance.kind sigma (EInstance.make l') in cstrs := enforce_eq_instances_univs strict l l' !cstrs; true in let eq_sorts s1 s2 = + let s1 = ESorts.kind sigma (ESorts.make s1) in + let s2 = ESorts.kind sigma (ESorts.make s2) in if Sorts.equal s1 s2 then true else (cstrs := Constraints.add (Sorts.univ_of_sort s1,UEq,Sorts.univ_of_sort s2) !cstrs; true) in let leq_sorts s1 s2 = + let s1 = ESorts.kind sigma (ESorts.make s1) in + let s2 = ESorts.kind sigma (ESorts.make s2) in if Sorts.equal s1 s2 then true else (cstrs := Constraints.add diff --git a/engine/evd.ml b/engine/evd.ml index cfc9aa6351..f1b5419dec 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -748,7 +748,10 @@ let evar_universe_context d = d.universes let universe_context_set d = UState.context_set d.universes -let universe_context ?names evd = UState.universe_context ?names evd.universes +let universe_context ~names ~extensible evd = + UState.universe_context ~names ~extensible evd.universes + +let check_univ_decl evd decl = UState.check_univ_decl evd.universes decl let restrict_universe_context evd vars = { evd with universes = UState.restrict evd.universes vars } diff --git a/engine/evd.mli b/engine/evd.mli index 3f00a3b0b2..abcabe8157 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -493,7 +493,7 @@ val empty_evar_universe_context : evar_universe_context val union_evar_universe_context : evar_universe_context -> evar_universe_context -> evar_universe_context val evar_universe_context_subst : evar_universe_context -> Universes.universe_opt_subst -val constrain_variables : Univ.LSet.t -> evar_universe_context -> Univ.constraints +val constrain_variables : Univ.LSet.t -> evar_universe_context -> evar_universe_context val evar_universe_context_of_binders : @@ -547,11 +547,13 @@ val check_leq : evar_map -> Univ.universe -> Univ.universe -> bool val evar_universe_context : evar_map -> evar_universe_context val universe_context_set : evar_map -> Univ.universe_context_set -val universe_context : ?names:(Id.t located) list -> evar_map -> +val universe_context : names:(Id.t located) list -> extensible:bool -> evar_map -> (Id.t * Univ.Level.t) list * Univ.universe_context val universe_subst : evar_map -> Universes.universe_opt_subst val universes : evar_map -> UGraph.t +val check_univ_decl : evar_map -> UState.universe_decl -> + Universes.universe_binders * Univ.universe_context val merge_universe_context : evar_map -> evar_universe_context -> evar_map val set_universe_context : evar_map -> evar_universe_context -> evar_map diff --git a/engine/termops.ml b/engine/termops.ml index 2bd0c06d6d..e2bdf72387 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -1165,6 +1165,24 @@ let rec is_Prop sigma c = match EConstr.kind sigma c with | Cast (c,_,_) -> is_Prop sigma c | _ -> false +let rec is_Set sigma c = match EConstr.kind sigma c with + | Sort u -> + begin match EConstr.ESorts.kind sigma u with + | Prop Pos -> true + | _ -> false + end + | Cast (c,_,_) -> is_Set sigma c + | _ -> false + +let rec is_Type sigma c = match EConstr.kind sigma c with + | Sort u -> + begin match EConstr.ESorts.kind sigma u with + | Type _ -> true + | _ -> false + end + | Cast (c,_,_) -> is_Type sigma c + | _ -> false + (* eq_constr extended with universe erasure *) let compare_constr_univ sigma f cv_pb t1 t2 = let open EConstr in diff --git a/engine/termops.mli b/engine/termops.mli index 2624afd30d..ef2c52a455 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -267,6 +267,8 @@ val isGlobalRef : Evd.evar_map -> constr -> bool val is_template_polymorphic : env -> Evd.evar_map -> constr -> bool val is_Prop : Evd.evar_map -> constr -> bool +val is_Set : Evd.evar_map -> constr -> bool +val is_Type : Evd.evar_map -> constr -> bool (** Combinators on judgments *) diff --git a/engine/uState.ml b/engine/uState.ml index 63bd247d56..13a9bb3732 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -97,17 +97,9 @@ let subst ctx = ctx.uctx_univ_variables let ugraph ctx = ctx.uctx_universes -let algebraics ctx = ctx.uctx_univ_algebraic +let initial_graph ctx = ctx.uctx_initial_universes -let constrain_variables diff ctx = - Univ.LSet.fold - (fun l cstrs -> - try - match Univ.LMap.find l ctx.uctx_univ_variables with - | Some u -> Univ.Constraint.add (l, Univ.Eq, Option.get (Univ.Universe.level u)) cstrs - | None -> cstrs - with Not_found | Option.IsNone -> cstrs) - diff Univ.Constraint.empty +let algebraics ctx = ctx.uctx_univ_algebraic let add_uctx_names ?loc s l (names, names_rev) = (UNameMap.add s l names, Univ.LMap.add l { uname = Some s; uloc = loc } names_rev) @@ -240,6 +232,24 @@ let add_universe_constraints ctx cstrs = uctx_univ_variables = vars; uctx_universes = UGraph.merge_constraints local' ctx.uctx_universes } +let constrain_variables diff ctx = + let univs, local = ctx.uctx_local in + let univs, vars, local = + Univ.LSet.fold + (fun l (univs, vars, cstrs) -> + try + match Univ.LMap.find l vars with + | Some u -> + (Univ.LSet.add l univs, + Univ.LMap.remove l vars, + Univ.Constraint.add (l, Univ.Eq, Option.get (Univ.Universe.level u)) cstrs) + | None -> (univs, vars, cstrs) + with Not_found | Option.IsNone -> (univs, vars, cstrs)) + diff (univs, ctx.uctx_univ_variables, local) + in + { ctx with uctx_local = (univs, local); uctx_univ_variables = vars } + + let pr_uctx_level uctx = let map, map_rev = uctx.uctx_names in fun l -> @@ -247,41 +257,63 @@ let pr_uctx_level uctx = with Not_found | Option.IsNone -> Universes.pr_with_global_universes l -let universe_context ?names ctx = - match names with - | None -> [], Univ.ContextSet.to_context ctx.uctx_local - | Some pl -> - let levels = Univ.ContextSet.levels ctx.uctx_local in - let newinst, map, left = - List.fold_right - (fun (loc,id) (newinst, map, acc) -> - let l = - try UNameMap.find (Id.to_string id) (fst ctx.uctx_names) - with Not_found -> - user_err ?loc ~hdr:"universe_context" - (str"Universe " ++ Nameops.pr_id id ++ str" is not bound anymore.") - in (l :: newinst, (id, l) :: map, Univ.LSet.remove l acc)) - pl ([], [], levels) - in - if not (Univ.LSet.is_empty left) then - let n = Univ.LSet.cardinal left in - let loc = - try - let info = - Univ.LMap.find (Univ.LSet.choose left) (snd ctx.uctx_names) in - info.uloc - with Not_found -> None - in - user_err ?loc ~hdr:"universe_context" - ((str(CString.plural n "Universe") ++ spc () ++ - Univ.LSet.pr (pr_uctx_level ctx) left ++ - spc () ++ str (CString.conjugate_verb_to_be n) ++ - str" unbound.")) - else - let inst = Univ.Instance.of_array (Array.of_list newinst) in - let ctx = Univ.UContext.make (inst, - Univ.ContextSet.constraints ctx.uctx_local) - in map, ctx +type universe_decl = + (Names.Id.t Loc.located list, Univ.Constraint.t) Misctypes.gen_universe_decl + +let universe_context ~names ~extensible ctx = + let levels = Univ.ContextSet.levels ctx.uctx_local in + let newinst, left = + List.fold_right + (fun (loc,id) (newinst, acc) -> + let l = + try UNameMap.find (Id.to_string id) (fst ctx.uctx_names) + with Not_found -> + user_err ?loc ~hdr:"universe_context" + (str"Universe " ++ Nameops.pr_id id ++ str" is not bound anymore.") + in (l :: newinst, Univ.LSet.remove l acc)) + names ([], levels) + in + if not extensible && not (Univ.LSet.is_empty left) then + let n = Univ.LSet.cardinal left in + let loc = + try + let info = + Univ.LMap.find (Univ.LSet.choose left) (snd ctx.uctx_names) in + info.uloc + with Not_found -> None + in + user_err ?loc ~hdr:"universe_context" + ((str(CString.plural n "Universe") ++ spc () ++ + Univ.LSet.pr (pr_uctx_level ctx) left ++ + spc () ++ str (CString.conjugate_verb_to_be n) ++ + str" unbound.")) + else + let left = Univ.ContextSet.sort_levels (Array.of_list (Univ.LSet.elements left)) in + let inst = Array.append (Array.of_list newinst) left in + let inst = Univ.Instance.of_array inst in + let map = List.map (fun (s,l) -> Id.of_string s, l) (UNameMap.bindings (fst ctx.uctx_names)) in + let ctx = Univ.UContext.make (inst, + Univ.ContextSet.constraints ctx.uctx_local) in + map, ctx + +let check_implication uctx cstrs ctx = + let gr = initial_graph uctx in + let grext = UGraph.merge_constraints cstrs gr in + let cstrs' = Univ.UContext.constraints ctx in + if UGraph.check_constraints cstrs' grext then () + else CErrors.user_err ~hdr:"check_univ_decl" + (str "Universe constraints are not implied by the ones declared.") + +let check_univ_decl uctx decl = + let open Misctypes in + let pl, ctx = universe_context + ~names:decl.univdecl_instance + ~extensible:decl.univdecl_extensible_instance + uctx + in + if not decl.univdecl_extensible_constraints then + check_implication uctx decl.univdecl_constraints ctx; + pl, ctx let restrict ctx vars = let uctx' = Univops.restrict_universe_context ctx.uctx_local vars in diff --git a/engine/uState.mli b/engine/uState.mli index d198fbfbe9..c44f2c1d74 100644 --- a/engine/uState.mli +++ b/engine/uState.mli @@ -44,6 +44,9 @@ val subst : t -> Universes.universe_opt_subst val ugraph : t -> UGraph.t (** The current graph extended with the local constraints *) +val initial_graph : t -> UGraph.t +(** The initial graph with just the declarations of new universes. *) + val algebraics : t -> Univ.LSet.t (** The subset of unification variables that can be instantiated with algebraic universes as they appear in inferred types only. *) @@ -105,7 +108,7 @@ val is_sort_variable : t -> Sorts.t -> Univ.Level.t option val normalize_variables : t -> Univ.universe_subst * t -val constrain_variables : Univ.LSet.t -> t -> Univ.constraints +val constrain_variables : Univ.LSet.t -> t -> t val abstract_undefined_variables : t -> t @@ -115,9 +118,26 @@ val refresh_undefined_univ_variables : t -> t * Univ.universe_level_subst val normalize : t -> t -(** {5 TODO: Document me} *) +(** [universe_context names extensible ctx] + + Return a universe context containing the local universes of [ctx] + and their constraints. The universes corresponding to [names] come + first in the order defined by that list. + + If [extensible] is false, check that the universes of [names] are + the only local universes. -val universe_context : ?names:(Id.t Loc.located) list -> t -> (Id.t * Univ.Level.t) list * Univ.universe_context + Also return the association list of universe names and universes + (including those not in [names]). *) +val universe_context : names:(Id.t Loc.located) list -> extensible:bool -> t -> + (Id.t * Univ.Level.t) list * Univ.universe_context + +type universe_decl = + (Names.Id.t Loc.located list, Univ.Constraint.t) Misctypes.gen_universe_decl + +val check_univ_decl : t -> universe_decl -> Universes.universe_binders * Univ.universe_context + +(** {5 TODO: Document me} *) val update_sigma_env : t -> Environ.env -> t diff --git a/engine/universes.ml b/engine/universes.ml index 719af43edf..7f5bf24b74 100644 --- a/engine/universes.ml +++ b/engine/universes.ml @@ -14,7 +14,7 @@ open Environ open Univ open Globnames -let pr_with_global_universes l = +let pr_with_global_universes l = try Nameops.pr_id (LMap.find l (snd (Global.global_universe_names ()))) with Not_found -> Level.pr l @@ -31,7 +31,7 @@ let universe_binders_of_global ref = let register_universe_binders ref l = universe_binders_table := Refmap.add ref l !universe_binders_table - + (* To disallow minimization to Set *) let set_minimization = ref true @@ -131,47 +131,6 @@ let to_constraints g s = "to_constraints: non-trivial algebraic constraint between universes") in Constraints.fold tr s Constraint.empty -let test_constr_univs_infer leq univs fold m n accu = - if m == n then Some accu - else - let cstrs = ref accu in - let eq_universes strict l l' = UGraph.check_eq_instances univs l l' in - let eq_sorts s1 s2 = - if Sorts.equal s1 s2 then true - else - let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in - match fold (Constraints.singleton (u1, UEq, u2)) !cstrs with - | None -> false - | Some accu -> cstrs := accu; true - in - let leq_sorts s1 s2 = - if Sorts.equal s1 s2 then true - else - let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in - match fold (Constraints.singleton (u1, ULe, u2)) !cstrs with - | None -> false - | Some accu -> cstrs := accu; true - in - let rec eq_constr' m n = - m == n || Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n - in - let res = - if leq then - let rec compare_leq m n = - Constr.compare_head_gen_leq eq_universes leq_sorts - eq_constr' leq_constr' m n - and leq_constr' m n = m == n || compare_leq m n in - compare_leq m n - else Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n - in - if res then Some !cstrs else None - -let eq_constr_univs_infer univs fold m n accu = - test_constr_univs_infer false univs fold m n accu - -let leq_constr_univs_infer univs fold m n accu = - test_constr_univs_infer true univs fold m n accu - (** Variant of [eq_constr_univs_infer] taking kind-of-term functions, to expose subterms of [m] and [n], arguments. *) let eq_constr_univs_infer_with kind1 kind2 univs fold m n accu = @@ -197,42 +156,6 @@ let eq_constr_univs_infer_with kind1 kind2 univs fold m n accu = let res = Constr.compare_head_gen_with kind1 kind2 eq_universes eq_sorts eq_constr' m n in if res then Some !cstrs else None -let test_constr_universes leq m n = - if m == n then Some Constraints.empty - else - let cstrs = ref Constraints.empty in - let eq_universes strict l l' = - cstrs := enforce_eq_instances_univs strict l l' !cstrs; true in - let eq_sorts s1 s2 = - if Sorts.equal s1 s2 then true - else (cstrs := Constraints.add - (Sorts.univ_of_sort s1,UEq,Sorts.univ_of_sort s2) !cstrs; - true) - in - let leq_sorts s1 s2 = - if Sorts.equal s1 s2 then true - else - (cstrs := Constraints.add - (Sorts.univ_of_sort s1,ULe,Sorts.univ_of_sort s2) !cstrs; - true) - in - let rec eq_constr' m n = - m == n || Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n - in - let res = - if leq then - let rec compare_leq m n = - Constr.compare_head_gen_leq eq_universes leq_sorts eq_constr' leq_constr' m n - and leq_constr' m n = m == n || compare_leq m n in - compare_leq m n - else - Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n - in - if res then Some !cstrs else None - -let eq_constr_universes m n = test_constr_universes false m n -let leq_constr_universes m n = test_constr_universes true m n - let compare_head_gen_proj env equ eqs eqc' m n = match kind_of_term m, kind_of_term n with | Proj (p, c), App (f, args) diff --git a/engine/universes.mli b/engine/universes.mli index fe40f82385..8b2217d446 100644 --- a/engine/universes.mli +++ b/engine/universes.mli @@ -67,11 +67,6 @@ val enforce_eq_instances_univs : bool -> universe_instance universe_constraint_f val to_constraints : UGraph.t -> universe_constraints -> constraints -(** [eq_constr_univs_infer u a b] is [true, c] if [a] equals [b] modulo alpha, casts, - application grouping, the universe constraints in [u] and additional constraints [c]. *) -val eq_constr_univs_infer : UGraph.t -> 'a constraint_accumulator -> - constr -> constr -> 'a -> 'a option - (** [eq_constr_univs_infer_With kind1 kind2 univs m n] is a variant of {!eq_constr_univs_infer} taking kind-of-term functions, to expose subterms of [m] and [n], arguments. *) @@ -80,20 +75,6 @@ val eq_constr_univs_infer_with : (constr -> (constr, types, Sorts.t, Univ.Instance.t) kind_of_term) -> UGraph.t -> 'a constraint_accumulator -> constr -> constr -> 'a -> 'a option -(** [leq_constr_univs u a b] is [true, c] if [a] is convertible to [b] - modulo alpha, casts, application grouping, the universe constraints - in [u] and additional constraints [c]. *) -val leq_constr_univs_infer : UGraph.t -> 'a constraint_accumulator -> - constr -> constr -> 'a -> 'a option - -(** [eq_constr_universes a b] [true, c] if [a] equals [b] modulo alpha, casts, - application grouping and the universe constraints in [c]. *) -val eq_constr_universes : constr -> constr -> universe_constraints option - -(** [leq_constr_universes a b] [true, c] if [a] is convertible to [b] modulo - alpha, casts, application grouping and the universe constraints in [c]. *) -val leq_constr_universes : constr -> constr -> universe_constraints option - (** [eq_constr_universes a b] [true, c] if [a] equals [b] modulo alpha, casts, application grouping and the universe constraints in [c]. *) val eq_constr_universes_proj : env -> constr -> constr -> bool universe_constrained diff --git a/ide/coqOps.ml b/ide/coqOps.ml index 364fc883ba..9be70e6d38 100644 --- a/ide/coqOps.ml +++ b/ide/coqOps.ml @@ -463,7 +463,7 @@ object(self) self#attach_tooltip ~loc sentence (Printf.sprintf "%s %s %s" filepath ident ty) | Message(Error, loc, msg), Some (id,sentence) -> - log_pp ?id Pp.(str "ErrorMsg" ++ msg); + log_pp ?id Pp.(str "ErrorMsg " ++ msg); remove_flag sentence `PROCESSING; let rmsg = Pp.string_of_ppcmds msg in add_flag sentence (`ERROR (loc, rmsg)); @@ -471,17 +471,17 @@ object(self) self#attach_tooltip ?loc sentence rmsg; self#position_tag_at_sentence ?loc Tags.Script.error sentence | Message(Warning, loc, msg), Some (id,sentence) -> - log_pp ?id Pp.(str "WarningMsg" ++ msg); + log_pp ?id Pp.(str "WarningMsg " ++ msg); let rmsg = Pp.string_of_ppcmds msg in add_flag sentence (`WARNING (loc, rmsg)); self#attach_tooltip ?loc sentence rmsg; self#position_tag_at_sentence ?loc Tags.Script.warning sentence; messages#push Warning msg | Message(lvl, loc, msg), Some (id,sentence) -> - log_pp ?id Pp.(str "Msg" ++ msg); + log_pp ?id Pp.(str "Msg " ++ msg); messages#push lvl msg | Message(lvl, loc, msg), None -> - log_pp Pp.(str "Msg" ++ msg); + log_pp Pp.(str "Msg " ++ msg); messages#push lvl msg | InProgress n, _ -> if n < 0 then processed <- processed + abs n diff --git a/ide/coqide.ml b/ide/coqide.ml index 7b65c9fec9..2c8ce0049e 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -439,7 +439,9 @@ let compile sn = match sn.fileops#filename with |None -> flash_info "Active buffer has no name" |Some f -> - let cmd = cmd_coqc#get ^ " -I " ^ (Filename.quote (Filename.dirname f)) + let args = Coq.get_arguments sn.coqtop in + let cmd = cmd_coqc#get + ^ " " ^ String.concat " " args ^ " " ^ (Filename.quote f) ^ " 2>&1" in let buf = Buffer.create 1024 in diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index 67391f5567..f00b1e1421 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -1,5 +1,4 @@ (************************************************************************) - (* v * The Coq Proof Assistant / The Coq Development Team *) (* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) (* \VV/ **************************************************************) @@ -414,6 +413,7 @@ let eval_call c = Interface.quit = (fun () -> quit := true); Interface.init = interruptible init; Interface.about = interruptible about; + Interface.wait = interruptible Stm.wait; Interface.interp = interruptible interp; Interface.handle_exn = handle_exn; Interface.stop_worker = Stm.stop_worker; diff --git a/ide/interface.mli b/ide/interface.mli index 1939a8427c..a5d98946f3 100644 --- a/ide/interface.mli +++ b/ide/interface.mli @@ -229,6 +229,9 @@ type print_ast_rty = Xml_datatype.xml type annotate_sty = string type annotate_rty = Xml_datatype.xml +type wait_sty = unit +type wait_rty = unit + type handler = { add : add_sty -> add_rty; edit_at : edit_at_sty -> edit_at_rty; @@ -248,6 +251,8 @@ type handler = { handle_exn : handle_exn_sty -> handle_exn_rty; init : init_sty -> init_rty; quit : quit_sty -> quit_rty; + (* for internal use (fake_id) only, do not use *) + wait : wait_sty -> wait_rty; (* Retrocompatibility stuff *) interp : interp_sty -> interp_rty; } diff --git a/ide/xmlprotocol.ml b/ide/xmlprotocol.ml index 4b521a9682..b452b0a13f 100644 --- a/ide/xmlprotocol.ml +++ b/ide/xmlprotocol.ml @@ -531,6 +531,7 @@ let set_options_sty_t : set_options_sty val_t = list_t (pair_t (list_t string_t) option_value_t) let mkcases_sty_t : mkcases_sty val_t = string_t let quit_sty_t : quit_sty val_t = unit_t +let wait_sty_t : wait_sty val_t = unit_t let about_sty_t : about_sty val_t = unit_t let init_sty_t : init_sty val_t = option_t string_t let interp_sty_t : interp_sty val_t = pair_t (pair_t bool_t bool_t) string_t @@ -555,6 +556,7 @@ let get_options_rty_t : get_options_rty val_t = let set_options_rty_t : set_options_rty val_t = unit_t let mkcases_rty_t : mkcases_rty val_t = list_t (list_t string_t) let quit_rty_t : quit_rty val_t = unit_t +let wait_rty_t : wait_rty val_t = unit_t let about_rty_t : about_rty val_t = coq_info_t let init_rty_t : init_rty val_t = state_id_t let interp_rty_t : interp_rty val_t = pair_t state_id_t (union_t string_t string_t) @@ -576,6 +578,7 @@ let calls = [| "SetOptions", ($)set_options_sty_t, ($)set_options_rty_t; "MkCases", ($)mkcases_sty_t, ($)mkcases_rty_t; "Quit", ($)quit_sty_t, ($)quit_rty_t; + "Wait", ($)wait_sty_t, ($)wait_rty_t; "About", ($)about_sty_t, ($)about_rty_t; "Init", ($)init_sty_t, ($)init_rty_t; "Interp", ($)interp_sty_t, ($)interp_rty_t; @@ -600,6 +603,8 @@ type 'a call = | About : about_sty -> about_rty call | Init : init_sty -> init_rty call | StopWorker : stop_worker_sty -> stop_worker_rty call + (* internal use (fake_ide) only, do not use *) + | Wait : wait_sty -> wait_rty call (* retrocompatibility *) | Interp : interp_sty -> interp_rty call | PrintAst : print_ast_sty -> print_ast_rty call @@ -618,12 +623,13 @@ let id_of_call : type a. a call -> int = function | SetOptions _ -> 9 | MkCases _ -> 10 | Quit _ -> 11 - | About _ -> 12 - | Init _ -> 13 - | Interp _ -> 14 - | StopWorker _ -> 15 - | PrintAst _ -> 16 - | Annotate _ -> 17 + | Wait _ -> 12 + | About _ -> 13 + | Init _ -> 14 + | Interp _ -> 15 + | StopWorker _ -> 16 + | PrintAst _ -> 17 + | Annotate _ -> 18 let str_of_call c = pi1 calls.(id_of_call c) @@ -643,6 +649,7 @@ let mkcases x : mkcases_rty call = MkCases x let search x : search_rty call = Search x let quit x : quit_rty call = Quit x let init x : init_rty call = Init x +let wait x : wait_rty call = Wait x let interp x : interp_rty call = Interp x let stop_worker x : stop_worker_rty call = StopWorker x let print_ast x : print_ast_rty call = PrintAst x @@ -664,6 +671,7 @@ let abstract_eval_call : type a. _ -> a call -> a value = fun handler c -> | SetOptions x -> mkGood (handler.set_options x) | MkCases x -> mkGood (handler.mkcases x) | Quit x -> mkGood (handler.quit x) + | Wait x -> mkGood (handler.wait x) | About x -> mkGood (handler.about x) | Init x -> mkGood (handler.init x) | Interp x -> mkGood (handler.interp x) @@ -688,6 +696,7 @@ let of_answer : type a. a call -> a value -> xml = function | SetOptions _ -> of_value (of_value_type set_options_rty_t) | MkCases _ -> of_value (of_value_type mkcases_rty_t ) | Quit _ -> of_value (of_value_type quit_rty_t ) + | Wait _ -> of_value (of_value_type wait_rty_t ) | About _ -> of_value (of_value_type about_rty_t ) | Init _ -> of_value (of_value_type init_rty_t ) | Interp _ -> of_value (of_value_type interp_rty_t ) @@ -711,6 +720,7 @@ let to_answer : type a. a call -> xml -> a value = function | SetOptions _ -> to_value (to_value_type set_options_rty_t) | MkCases _ -> to_value (to_value_type mkcases_rty_t ) | Quit _ -> to_value (to_value_type quit_rty_t ) + | Wait _ -> to_value (to_value_type wait_rty_t ) | About _ -> to_value (to_value_type about_rty_t ) | Init _ -> to_value (to_value_type init_rty_t ) | Interp _ -> to_value (to_value_type interp_rty_t ) @@ -733,6 +743,7 @@ let of_call : type a. a call -> xml = fun q -> | SetOptions x -> mkCall (of_value_type set_options_sty_t x) | MkCases x -> mkCall (of_value_type mkcases_sty_t x) | Quit x -> mkCall (of_value_type quit_sty_t x) + | Wait x -> mkCall (of_value_type wait_sty_t x) | About x -> mkCall (of_value_type about_sty_t x) | Init x -> mkCall (of_value_type init_sty_t x) | Interp x -> mkCall (of_value_type interp_sty_t x) @@ -756,6 +767,7 @@ let to_call : xml -> unknown_call = | "SetOptions" -> Unknown (SetOptions (mkCallArg set_options_sty_t a)) | "MkCases" -> Unknown (MkCases (mkCallArg mkcases_sty_t a)) | "Quit" -> Unknown (Quit (mkCallArg quit_sty_t a)) + | "Wait" -> Unknown (Wait (mkCallArg wait_sty_t a)) | "About" -> Unknown (About (mkCallArg about_sty_t a)) | "Init" -> Unknown (Init (mkCallArg init_sty_t a)) | "Interp" -> Unknown (Interp (mkCallArg interp_sty_t a)) @@ -786,6 +798,7 @@ let pr_full_value : type a. a call -> a value -> string = fun call value -> matc | SetOptions _ -> pr_value_gen (print set_options_rty_t) value | MkCases _ -> pr_value_gen (print mkcases_rty_t ) value | Quit _ -> pr_value_gen (print quit_rty_t ) value + | Wait _ -> pr_value_gen (print wait_rty_t ) value | About _ -> pr_value_gen (print about_rty_t ) value | Init _ -> pr_value_gen (print init_rty_t ) value | Interp _ -> pr_value_gen (print interp_rty_t ) value @@ -807,6 +820,7 @@ let pr_call : type a. a call -> string = fun call -> | SetOptions x -> return set_options_sty_t x | MkCases x -> return mkcases_sty_t x | Quit x -> return quit_sty_t x + | Wait x -> return wait_sty_t x | About x -> return about_sty_t x | Init x -> return init_sty_t x | Interp x -> return interp_sty_t x diff --git a/ide/xmlprotocol.mli b/ide/xmlprotocol.mli index d1c678b90f..22117e35c0 100644 --- a/ide/xmlprotocol.mli +++ b/ide/xmlprotocol.mli @@ -29,6 +29,8 @@ val set_options : set_options_sty -> set_options_rty call val quit : quit_sty -> quit_rty call val init : init_sty -> init_rty call val stop_worker : stop_worker_sty -> stop_worker_rty call +(* internal use (fake_ide) only, do not use *) +val wait : wait_sty -> wait_rty call (* retrocompatibility *) val interp : interp_sty -> interp_rty call val print_ast : print_ast_sty -> print_ast_rty call diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index 2d0a19b9a6..771c137344 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -320,13 +320,13 @@ let coerce_reference_to_id = function (str "This expression should be a simple identifier.") let coerce_to_id = function - | { CAst.v = CRef (Ident (loc,id),_); _ } -> (loc,id) + | { CAst.v = CRef (Ident (loc,id),None) } -> (loc,id) | { CAst.loc; _ } -> CErrors.user_err ?loc ~hdr:"coerce_to_id" (str "This expression should be a simple identifier.") let coerce_to_name = function - | { CAst.v = CRef (Ident (loc,id),_) } -> (loc,Name id) - | { CAst.loc; CAst.v = CHole (_,_,_) } -> (loc,Anonymous) + | { CAst.v = CRef (Ident (loc,id),None) } -> (loc,Name id) + | { CAst.loc; CAst.v = CHole (None,Misctypes.IntroAnonymous,None) } -> (loc,Anonymous) | { CAst.loc; _ } -> CErrors.user_err ?loc ~hdr:"coerce_to_name" (str "This expression should be a name.") diff --git a/interp/dumpglob.mli b/interp/dumpglob.mli index 054e43e7c8..afcd7a2ed2 100644 --- a/interp/dumpglob.mli +++ b/interp/dumpglob.mli @@ -37,7 +37,7 @@ val dump_notation : (Constrexpr.notation * Notation.notation_location) Loc.located -> Notation_term.scope_name option -> bool -> unit val dump_constraint : - Constrexpr.typeclass_constraint -> bool -> string -> unit + Vernacexpr.typeclass_constraint -> bool -> string -> unit val dump_string : string -> unit diff --git a/interp/notation.ml b/interp/notation.ml index 176ac3bf68..d3cac1e3e9 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -425,7 +425,7 @@ let warn_notation_overridden = CWarnings.create ~name:"notation-overridden" ~category:"parsing" (fun (ntn,which_scope) -> str "Notation" ++ spc () ++ str ntn ++ spc () - ++ strbrk "was already used" ++ which_scope) + ++ strbrk "was already used" ++ which_scope ++ str ".") let declare_notation_interpretation ntn scopt pat df ~onlyprint = let scope = match scopt with Some s -> s | None -> default_scope in diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index 0341167318..3d48114ec6 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -297,28 +297,29 @@ let compare_recursive_parts found f f' (iterator,subc) = user_err ?loc:(subtract_loc loc1 loc2) (str "Both ends of the recursive pattern are the same.") | Some (x,y,RecursiveTerms lassoc) -> - let newfound,x,y,lassoc = + let toadd,x,y,lassoc = if List.mem_f (pair_equal Id.equal Id.equal) (x,y) (pi2 !found) || List.mem_f (pair_equal Id.equal Id.equal) (x,y) (pi3 !found) then - !found,x,y,lassoc + None,x,y,lassoc else if List.mem_f (pair_equal Id.equal Id.equal) (y,x) (pi2 !found) || List.mem_f (pair_equal Id.equal Id.equal) (y,x) (pi3 !found) then - !found,y,x,not lassoc + None,y,x,not lassoc else - (pi1 !found, (x,y) :: pi2 !found, pi3 !found),x,y,lassoc in + Some (x,y),x,y,lassoc in let iterator = f' (if lassoc then iterator else subst_glob_vars [x, DAst.make @@ GVar y] iterator) in - (* found have been collected by compare_constr *) - found := newfound; + (* found variables have been collected by compare_constr *) + found := (List.remove Id.equal y (pi1 !found), + Option.fold_right (fun a l -> a::l) toadd (pi2 !found), + pi3 !found); NList (x,y,iterator,f (Option.get !terminator),lassoc) | Some (x,y,RecursiveBinders (t_x,t_y)) -> - let newfound = (pi1 !found, pi2 !found, (x,y) :: pi3 !found) in let iterator = f' (subst_glob_vars [x, DAst.make @@ GVar y] iterator) in (* found have been collected by compare_constr *) - found := newfound; + found := (List.remove Id.equal y (pi1 !found), pi2 !found, (x,y) :: pi3 !found); check_is_hole x t_x; check_is_hole y t_y; NBinderList (x,y,iterator,f (Option.get !terminator)) @@ -348,7 +349,7 @@ let notation_constr_and_vars_of_glob_constr a = | _c -> aux' c and aux' x = DAst.with_val (function - | GVar id -> add_id found id; NVar id + | GVar id -> if not (Id.equal id ldots_var) then add_id found id; NVar id | GApp (g,args) -> NApp (aux g, List.map aux args) | GLambda (na,bk,ty,c) -> add_name found na; NLambda (na,aux ty,aux c) | GProd (na,bk,ty,c) -> add_name found na; NProd (na,aux ty,aux c) @@ -823,7 +824,7 @@ let bind_bindinglist_env alp (terms,onlybinders,termlists,binderlists as sigma) alp, b :: bl | _ -> raise No_match in let alp, bl = unify alp bl bl' in - let sigma = (terms,Id.List.remove_assoc var onlybinders,termlists,binderlists) in + let sigma = (terms,onlybinders,termlists,Id.List.remove_assoc var binderlists) in alp, add_bindinglist_env sigma var bl with Not_found -> alp, add_bindinglist_env sigma var bl @@ -909,7 +910,7 @@ let rec match_iterated_binders islambda decls bi = DAst.(with_loc_val (fun ?loc | GLambda (na,bk,t,b) as b0 -> begin match na, DAst.get b with | Name p, GCases (LetPatternStyle,None,[(e,_)],[(_,(ids,[cp],b))]) - when islambda && is_gvar p e -> + when islambda && is_gvar p e && not (occur_glob_constr p b) -> match_iterated_binders islambda ((DAst.make ?loc @@ GLocalPattern((cp,ids),p,bk,t))::decls) b | _, _ when islambda -> match_iterated_binders islambda ((DAst.make ?loc @@ GLocalAssum(na,bk,t))::decls) b @@ -918,7 +919,7 @@ let rec match_iterated_binders islambda decls bi = DAst.(with_loc_val (fun ?loc | GProd (na,bk,t,b) as b0 -> begin match na, DAst.get b with | Name p, GCases (LetPatternStyle,None,[(e,_)],[(_,(ids,[cp],b))]) - when not islambda && is_gvar p e -> + when not islambda && is_gvar p e && not (occur_glob_constr p b) -> match_iterated_binders islambda ((DAst.make ?loc @@ GLocalPattern((cp,ids),p,bk,t))::decls) b | Name _, _ when not islambda -> match_iterated_binders islambda ((DAst.make ?loc @@ GLocalAssum(na,bk,t))::decls) b @@ -991,8 +992,6 @@ let does_not_come_from_already_eta_expanded_var glob = (* checked). *) match DAst.get glob with GVar _ -> false | _ -> true -let is_var c = match DAst.get c with GVar _ -> true | _ -> false - let rec match_ inner u alp metas sigma a1 a2 = let open CAst in let loc = a1.loc in @@ -1009,7 +1008,8 @@ let rec match_ inner u alp metas sigma a1 a2 = | GLambda (na1, bk, t1, b1), NBinderList (x,y,iter,termin) -> begin match na1, DAst.get b1, iter with (* "λ p, let 'cp = p in t" -> "λ 'cp, t" *) - | Name p, GCases (LetPatternStyle,None,[(e,_)],[(_,(ids,[cp],b1))]), NLambda (Name _, _, _) when is_gvar p e -> + | Name p, GCases (LetPatternStyle,None,[(e,_)],[(_,(ids,[cp],b1))]), NLambda (Name _, _, _) + when is_gvar p e && not (occur_glob_constr p b1) -> let (decls,b) = match_iterated_binders true [DAst.make ?loc @@ GLocalPattern((cp,ids),p,bk,t1)] b1 in let alp,sigma = bind_bindinglist_env alp sigma x decls in match_in u alp metas sigma b termin @@ -1027,7 +1027,8 @@ let rec match_ inner u alp metas sigma a1 a2 = | GProd (na1, bk, t1, b1), NBinderList (x,y,iter,termin) -> (* "∀ p, let 'cp = p in t" -> "∀ 'cp, t" *) begin match na1, DAst.get b1, iter, termin with - | Name p, GCases (LetPatternStyle,None,[(e, _)],[(_,(ids,[cp],b1))]), NProd (Name _,_,_), NVar _ when is_gvar p e -> + | Name p, GCases (LetPatternStyle,None,[(e, _)],[(_,(ids,[cp],b1))]), NProd (Name _,_,_), NVar _ + when is_gvar p e && not (occur_glob_constr p b1) -> let (decls,b) = match_iterated_binders true [DAst.make ?loc @@ GLocalPattern ((cp,ids),p,bk,t1)] b1 in let alp,sigma = bind_bindinglist_env alp sigma x decls in match_in u alp metas sigma b termin @@ -1049,7 +1050,7 @@ let rec match_ inner u alp metas sigma a1 a2 = | GLambda (na1, bk, t1, b1), NLambda (na2, t2, b2) -> begin match na1, DAst.get b1, na2 with | Name p, GCases (LetPatternStyle,None,[(e,_)],[(_,(ids,[cp],b1))]), Name id - when is_var e && is_bindinglist_meta id metas -> + when is_gvar p e && is_bindinglist_meta id metas && not (occur_glob_constr p b1) -> let alp,sigma = bind_bindinglist_env alp sigma id [DAst.make ?loc @@ GLocalPattern ((cp,ids),p,bk,t1)] in match_in u alp metas sigma b1 b2 | _, _, Name id when is_bindinglist_meta id metas -> diff --git a/interp/ppextend.ml b/interp/ppextend.ml index 3ebc9b71d2..ce19dd8a92 100644 --- a/interp/ppextend.ml +++ b/interp/ppextend.ml @@ -36,5 +36,5 @@ type unparsing = | UnpListMetaVar of int * parenRelation * unparsing list | UnpBinderListMetaVar of int * bool * unparsing list | UnpTerminal of string - | UnpBox of ppbox * unparsing list + | UnpBox of ppbox * unparsing Loc.located list | UnpCut of ppcut diff --git a/interp/ppextend.mli b/interp/ppextend.mli index 6ff5a42728..7b62a2074b 100644 --- a/interp/ppextend.mli +++ b/interp/ppextend.mli @@ -29,5 +29,5 @@ type unparsing = | UnpListMetaVar of int * parenRelation * unparsing list | UnpBinderListMetaVar of int * bool * unparsing list | UnpTerminal of string - | UnpBox of ppbox * unparsing list + | UnpBox of ppbox * unparsing Loc.located list | UnpCut of ppcut diff --git a/interp/stdarg.ml b/interp/stdarg.ml index 274ea6213b..45dec5112b 100644 --- a/interp/stdarg.ml +++ b/interp/stdarg.ml @@ -50,6 +50,8 @@ let wit_ref = make0 "ref" let wit_quant_hyp = make0 "quant_hyp" +let wit_sort_family = make0 "sort_family" + let wit_constr = make0 "constr" diff --git a/interp/stdarg.mli b/interp/stdarg.mli index 1d4a29b9c2..dffbd6659f 100644 --- a/interp/stdarg.mli +++ b/interp/stdarg.mli @@ -47,6 +47,8 @@ val wit_ref : (reference, global_reference located or_var, global_reference) gen val wit_quant_hyp : quantified_hypothesis uniform_genarg_type +val wit_sort_family : (Sorts.family, unit, unit) genarg_type + val wit_constr : (constr_expr, glob_constr_and_expr, constr) genarg_type val wit_uconstr : (constr_expr , glob_constr_and_expr, Glob_term.closed_glob_constr) genarg_type diff --git a/intf/constrexpr.ml b/intf/constrexpr.ml index 413cd9704b..8eadafe667 100644 --- a/intf/constrexpr.ml +++ b/intf/constrexpr.ml @@ -132,10 +132,6 @@ and constr_notation_substitution = constr_expr list list * (** for recursive notations *) local_binder_expr list list (** for binders subexpressions *) -type typeclass_constraint = (Name.t Loc.located * Id.t Loc.located list option) * binding_kind * constr_expr - -and typeclass_context = typeclass_constraint list - type constr_pattern_expr = constr_expr (** Concrete syntax for modules and module types *) diff --git a/intf/misctypes.ml b/intf/misctypes.ml index 807882b42f..8b70731432 100644 --- a/intf/misctypes.ml +++ b/intf/misctypes.ml @@ -53,6 +53,7 @@ type level_info = Name.t Loc.located option type glob_sort = sort_info glob_sort_gen type glob_level = level_info glob_sort_gen +type glob_constraint = glob_level * Univ.constraint_type * glob_level (** A synonym of [Evar.t], also defined in Term *) @@ -136,3 +137,9 @@ type inversion_kind = | SimpleInversion | FullInversion | FullInversionClear + +type ('a, 'b) gen_universe_decl = { + univdecl_instance : 'a; (* Declared universes *) + univdecl_extensible_instance : bool; (* Can new universes be added *) + univdecl_constraints : 'b; (* Declared constraints *) + univdecl_extensible_constraints : bool (* Can new constraints be added *) } diff --git a/intf/vernacexpr.ml b/intf/vernacexpr.ml index 2adf522b74..03e8ea43d1 100644 --- a/intf/vernacexpr.ml +++ b/intf/vernacexpr.ml @@ -139,8 +139,7 @@ type search_restriction = type rec_flag = bool (* true = Rec; false = NoRec *) type verbose_flag = bool (* true = Verbose; false = Silent *) - (* list of idents for qed exporting *) -type opacity_flag = Opaque of lident list option | Transparent +type opacity_flag = Opaque | Transparent type coercion_flag = bool (* true = AddCoercion false = NoCoercion *) type instance_flag = bool option (* Some true = Backward instance; Some false = Forward instance, None = NoInstance *) @@ -166,10 +165,13 @@ type option_ref_value = | StringRefValue of string | QualidRefValue of reference -(** Identifier and optional list of bound universes. *) -type plident = lident * lident list option +(** Identifier and optional list of bound universes and constraints. *) -type sort_expr = glob_sort +type universe_decl_expr = (Id.t Loc.located list, glob_constraint list) gen_universe_decl + +type ident_decl = lident * universe_decl_expr option + +type sort_expr = Sorts.family type definition_expr = | ProveBody of local_binder_expr list * constr_expr @@ -177,10 +179,10 @@ type definition_expr = * constr_expr option type fixpoint_expr = - plident * (Id.t located option * recursion_order_expr) * local_binder_expr list * constr_expr * constr_expr option + ident_decl * (Id.t located option * recursion_order_expr) * local_binder_expr list * constr_expr * constr_expr option type cofixpoint_expr = - plident * local_binder_expr list * constr_expr * constr_expr option + ident_decl * local_binder_expr list * constr_expr * constr_expr option type local_decl_expr = | AssumExpr of lname * constr_expr @@ -199,14 +201,18 @@ type constructor_list_or_record_decl_expr = | Constructors of constructor_expr list | RecordDecl of lident option * local_decl_expr with_instance with_priority with_notation list type inductive_expr = - plident with_coercion * local_binder_expr list * constr_expr option * inductive_kind * + ident_decl with_coercion * local_binder_expr list * constr_expr option * inductive_kind * constructor_list_or_record_decl_expr type one_inductive_expr = - plident * local_binder_expr list * constr_expr option * constructor_expr list + ident_decl * local_binder_expr list * constr_expr option * constructor_expr list + +type typeclass_constraint = (Name.t Loc.located * universe_decl_expr option) * binding_kind * constr_expr + +and typeclass_context = typeclass_constraint list type proof_expr = - plident option * (local_binder_expr list * constr_expr) + ident_decl option * (local_binder_expr list * constr_expr) type syntax_modifier = | SetItemLevel of string list * Extend.production_level @@ -280,11 +286,6 @@ type bullet = | Star of int | Plus of int -(** {6 Types concerning Stm} *) -type stm_vernac = - | JoinDocument - | Wait - (** {6 Types concerning the module layer} *) (** Rigid / flexible module signature *) @@ -325,7 +326,7 @@ type vernac_expr = (* Syntax *) | VernacSyntaxExtension of - obsolete_locality * (lstring * syntax_modifier list) + bool * obsolete_locality * (lstring * syntax_modifier list) | VernacOpenCloseScope of obsolete_locality * (bool * scope_name) | VernacDelimiters of scope_name * string option | VernacBindScope of scope_name * class_rawexpr list @@ -338,12 +339,12 @@ type vernac_expr = (* Gallina *) | VernacDefinition of - (locality option * definition_object_kind) * plident * definition_expr + (locality option * definition_object_kind) * ident_decl * definition_expr | VernacStartTheoremProof of theorem_kind * proof_expr list | VernacEndProof of proof_end | VernacExactProof of constr_expr | VernacAssumption of (locality option * assumption_object_kind) * - inline * (plident list * constr_expr) with_coercion list + inline * (ident_decl list * constr_expr) with_coercion list | VernacInductive of cumulative_inductive_parsing_flag * private_flag * inductive_flag * (inductive_expr * decl_notation list) list | VernacFixpoint of locality option * (fixpoint_expr * decl_notation list) list @@ -352,7 +353,7 @@ type vernac_expr = | VernacScheme of (lident option * scheme) list | VernacCombinedScheme of lident * lident list | VernacUniverse of lident list - | VernacConstraint of (glob_level * Univ.constraint_type * glob_level) list + | VernacConstraint of glob_constraint list (* Gallina extensions *) | VernacBeginSection of lident @@ -450,10 +451,6 @@ type vernac_expr = | VernacRegister of lident * register_kind | VernacComments of comment list - (* Stm backdoor: used in fake_id, will be removed when fake_ide - becomes aware of feedback about completed jobs. *) - | VernacStm of stm_vernac - (* Proof management *) | VernacGoal of constr_expr | VernacAbort of lident option @@ -504,16 +501,12 @@ type vernac_type = | VtProofStep of proof_step | VtProofMode of string | VtQuery of vernac_part_of_script * Feedback.route_id - | VtStm of vernac_control * vernac_part_of_script + | VtBack of vernac_part_of_script * Stateid.t | VtUnknown and vernac_qed_type = VtKeep | VtKeepAsAxiom | VtDrop (* Qed/Admitted, Abort *) and vernac_start = string * opacity_guarantee * Id.t list and vernac_sideff_type = Id.t list and vernac_part_of_script = bool -and vernac_control = - | VtWait - | VtJoinDocument - | VtBack of Stateid.t and opacity_guarantee = | GuaranteesOpacity (** Only generates opaque terms at [Qed] *) | Doesn'tGuaranteeOpacity (** May generate transparent terms even with [Qed].*) diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 1eaba49aa9..a393073689 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -860,6 +860,8 @@ let filter_stack_domain env ci p stack = match stack, kind_of_term t with | elt :: stack', Prod (n,a,c0) -> let d = LocalAssum (n,a) in + let ctx, a = dest_prod_assum env a in + let env = push_rel_context ctx env in let ty, args = decompose_app (whd_all env a) in let elt = match kind_of_term ty with | Ind ind -> diff --git a/kernel/univ.ml b/kernel/univ.ml index d915fb8c98..bae782f5d4 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -31,133 +31,6 @@ open Util union-find algorithm. The assertions $<$ and $\le$ are represented by adjacency lists *) -module type Hashconsed = -sig - type t - val hash : t -> int - val eq : t -> t -> bool - val hcons : t -> t -end - -module HashedList (M : Hashconsed) : -sig - type t = private Nil | Cons of M.t * int * t - val nil : t - val cons : M.t -> t -> t -end = -struct - type t = Nil | Cons of M.t * int * t - module Self = - struct - type _t = t - type t = _t - type u = (M.t -> M.t) - let hash = function Nil -> 0 | Cons (_, h, _) -> h - let eq l1 l2 = match l1, l2 with - | Nil, Nil -> true - | Cons (x1, _, l1), Cons (x2, _, l2) -> x1 == x2 && l1 == l2 - | _ -> false - let hashcons hc = function - | Nil -> Nil - | Cons (x, h, l) -> Cons (hc x, h, l) - end - module Hcons = Hashcons.Make(Self) - let hcons = Hashcons.simple_hcons Hcons.generate Hcons.hcons M.hcons - (** No recursive call: the interface guarantees that all HLists from this - program are already hashconsed. If we get some external HList, we can - still reconstruct it by traversing it entirely. *) - let nil = Nil - let cons x l = - let h = M.hash x in - let hl = match l with Nil -> 0 | Cons (_, h, _) -> h in - let h = Hashset.Combine.combine h hl in - hcons (Cons (x, h, l)) -end - -module HList = struct - - module type S = sig - type elt - type t = private Nil | Cons of elt * int * t - val hash : t -> int - val nil : t - val cons : elt -> t -> t - val tip : elt -> t - val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a - val map : (elt -> elt) -> t -> t - val smartmap : (elt -> elt) -> t -> t - val exists : (elt -> bool) -> t -> bool - val for_all : (elt -> bool) -> t -> bool - val for_all2 : (elt -> elt -> bool) -> t -> t -> bool - val mem : elt -> t -> bool - val remove : elt -> t -> t - val to_list : t -> elt list - val compare : (elt -> elt -> int) -> t -> t -> int - end - - module Make (H : Hashconsed) : S with type elt = H.t = - struct - type elt = H.t - include HashedList(H) - - let hash = function Nil -> 0 | Cons (_, h, _) -> h - - let tip e = cons e nil - - let rec fold f l accu = match l with - | Nil -> accu - | Cons (x, _, l) -> fold f l (f x accu) - - let rec map f = function - | Nil -> nil - | Cons (x, _, l) -> cons (f x) (map f l) - - let smartmap = map - (** Apriori hashconsing ensures that the map is equal to its argument *) - - let rec exists f = function - | Nil -> false - | Cons (x, _, l) -> f x || exists f l - - let rec for_all f = function - | Nil -> true - | Cons (x, _, l) -> f x && for_all f l - - let rec for_all2 f l1 l2 = match l1, l2 with - | Nil, Nil -> true - | Cons (x1, _, l1), Cons (x2, _, l2) -> f x1 x2 && for_all2 f l1 l2 - | _ -> false - - let rec to_list = function - | Nil -> [] - | Cons (x, _, l) -> x :: to_list l - - let rec remove x = function - | Nil -> nil - | Cons (y, _, l) -> - if H.eq x y then l - else cons y (remove x l) - - let rec mem x = function - | Nil -> false - | Cons (y, _, l) -> H.eq x y || mem x l - - let rec compare cmp l1 l2 = match l1, l2 with - | Nil, Nil -> 0 - | Cons (x1, h1, l1), Cons (x2, h2, l2) -> - let c = Int.compare h1 h2 in - if c == 0 then - let c = cmp x1 x2 in - if c == 0 then - compare cmp l1 l2 - else c - else c - | Cons _, Nil -> 1 - | Nil, Cons _ -> -1 - - end -end - module RawLevel = struct open Names @@ -390,12 +263,11 @@ struct module Expr = struct type t = Level.t * int - type _t = t (* Hashing of expressions *) module ExprHash = struct - type t = _t + type t = Level.t * int type u = Level.t -> Level.t let hashcons hdir (b,n as x) = let b' = hdir b in @@ -409,25 +281,12 @@ struct end - module HExpr = - struct - - module H = Hashcons.Make(ExprHash) - - type t = ExprHash.t - - let hcons = - Hashcons.simple_hcons H.generate H.hcons Level.hcons - let hash = ExprHash.hash - let eq x y = x == y || - (let (u,n) = x and (v,n') = y in - Int.equal n n' && Level.equal u v) - - end + module H = Hashcons.Make(ExprHash) - let hcons = HExpr.hcons + let hcons = + Hashcons.simple_hcons H.generate H.hcons Level.hcons - let make l = hcons (l, 0) + let make l = (l, 0) let compare u v = if u == v then 0 @@ -436,8 +295,8 @@ struct if Int.equal n n' then Level.compare x x' else n - n' - let prop = make Level.prop - let set = make Level.set + let prop = hcons (Level.prop, 0) + let set = hcons (Level.set, 0) let type1 = hcons (Level.set, 1) let is_small = function @@ -448,6 +307,8 @@ struct (let (u,n) = x and (v,n') = y in Int.equal n n' && Level.equal u v) + let hash = ExprHash.hash + let leq (u,n) (v,n') = let cmp = Level.compare u v in if Int.equal cmp 0 then n <= n' @@ -457,13 +318,13 @@ struct let successor (u,n) = if Level.is_prop u then type1 - else hcons (u, n + 1) + else (u, n + 1) let addn k (u,n as x) = if k = 0 then x else if Level.is_prop u then - hcons (Level.set,n+k) - else hcons (u,n+k) + (Level.set,n+k) + else (u,n+k) type super_result = SuperSame of bool @@ -515,71 +376,63 @@ struct let v' = f v in if v' == v then x else if Level.is_prop v' && n != 0 then - hcons (Level.set, n) - else hcons (v', n) + (Level.set, n) + else (v', n) end - - let compare_expr = Expr.compare - module Huniv = HList.Make(Expr.HExpr) - type t = Huniv.t - open Huniv - - let equal x y = x == y || - (Huniv.hash x == Huniv.hash y && - Huniv.for_all2 Expr.equal x y) + type t = Expr.t list - let hash = Huniv.hash + let tip l = [l] + let cons x l = x :: l - let compare x y = - if x == y then 0 - else - let hx = Huniv.hash x and hy = Huniv.hash y in - let c = Int.compare hx hy in - if c == 0 then - Huniv.compare (fun e1 e2 -> compare_expr e1 e2) x y - else c + let rec hash = function + | [] -> 0 + | e :: l -> Hashset.Combine.combinesmall (Expr.ExprHash.hash e) (hash l) + + let equal x y = x == y || List.equal Expr.equal x y + + let compare x y = if x == y then 0 else List.compare Expr.compare x y + + module Huniv = Hashcons.Hlist(Expr) - let rec hcons = function - | Nil -> Huniv.nil - | Cons (x, _, l) -> Huniv.cons x (hcons l) + let hcons = Hashcons.recursive_hcons Huniv.generate Huniv.hcons Expr.hcons - let make l = Huniv.tip (Expr.make l) - let tip x = Huniv.tip x + let make l = tip (Expr.make l) + let tip x = tip x let pr l = match l with - | Cons (u, _, Nil) -> Expr.pr u + | [u] -> Expr.pr u | _ -> str "max(" ++ hov 0 - (prlist_with_sep pr_comma Expr.pr (to_list l)) ++ + (prlist_with_sep pr_comma Expr.pr l) ++ str ")" let pr_with f l = match l with - | Cons (u, _, Nil) -> Expr.pr_with f u + | [u] -> Expr.pr_with f u | _ -> str "max(" ++ hov 0 - (prlist_with_sep pr_comma (Expr.pr_with f) (to_list l)) ++ + (prlist_with_sep pr_comma (Expr.pr_with f) l) ++ str ")" let is_level l = match l with - | Cons (l, _, Nil) -> Expr.is_level l + | [l] -> Expr.is_level l | _ -> false let rec is_levels l = match l with - | Cons (l, _, r) -> Expr.is_level l && is_levels r - | Nil -> true + | l :: r -> Expr.is_level l && is_levels r + | [] -> true let level l = match l with - | Cons (l, _, Nil) -> Expr.level l + | [l] -> Expr.level l | _ -> None let levels l = - fold (fun x acc -> LSet.add (Expr.get_level x) acc) l LSet.empty + List.fold_left (fun acc x -> LSet.add (Expr.get_level x) acc) LSet.empty l let is_small u = match u with - | Cons (l, _, Nil) -> Expr.is_small l + | [l] -> Expr.is_small l | _ -> false (* The lower predicative level of the hierarchy that contains (impredicative) @@ -601,16 +454,16 @@ struct let super l = if is_small l then type1 else - Huniv.map (fun x -> Expr.successor x) l + List.smartmap (fun x -> Expr.successor x) l let addn n l = - Huniv.map (fun x -> Expr.addn n x) l + List.smartmap (fun x -> Expr.addn n x) l let rec merge_univs l1 l2 = match l1, l2 with - | Nil, _ -> l2 - | _, Nil -> l1 - | Cons (h1, _, t1), Cons (h2, _, t2) -> + | [], _ -> l2 + | _, [] -> l1 + | h1 :: t1, h2 :: t2 -> let open Expr in (match super h1 h2 with | SuperSame true (* h1 < h2 *) -> merge_univs t1 l2 @@ -623,7 +476,7 @@ struct let sort u = let rec aux a l = match l with - | Cons (b, _, l') -> + | b :: l' -> let open Expr in (match super a b with | SuperSame false -> aux a l' @@ -631,21 +484,21 @@ struct | SuperDiff c -> if c <= 0 then cons a l else cons b (aux a l')) - | Nil -> cons a l + | [] -> cons a l in - fold (fun a acc -> aux a acc) u nil + List.fold_right (fun a acc -> aux a acc) u [] (* Returns the formal universe that is greater than the universes u and v. Used to type the products. *) let sup x y = merge_univs x y - let empty = nil + let empty = [] - let exists = Huniv.exists + let exists = List.exists - let for_all = Huniv.for_all + let for_all = List.for_all - let smartmap = Huniv.smartmap + let smartmap = List.smartmap end @@ -818,12 +671,11 @@ let check_univ_leq u v = Universe.for_all (fun u -> check_univ_leq_one u v) u let enforce_leq u v c = - let open Universe.Huniv in let rec aux acc v = match v with - | Cons (v, _, l) -> - aux (fold (fun u -> constraint_add_leq u v) u c) l - | Nil -> acc + | v :: l -> + aux (List.fold_right (fun u -> constraint_add_leq u v) u c) l + | [] -> acc in aux c v let enforce_leq u v c = @@ -842,12 +694,13 @@ let enforce_univ_constraint (u,d,v) = (* Miscellaneous functions to remove or test local univ assumed to occur in a universe *) -let univ_level_mem u v = Huniv.mem (Expr.make u) v +let univ_level_mem u v = + List.exists (fun (l, n) -> Int.equal n 0 && Level.equal u l) v let univ_level_rem u v min = match Universe.level v with | Some u' -> if Level.equal u u' then min else v - | None -> Huniv.remove (Universe.Expr.make u) v + | None -> List.filter (fun (l, n) -> not (Int.equal n 0 && Level.equal u l)) v (* Is u mentionned in v (or equals to v) ? *) @@ -1260,7 +1113,7 @@ let subst_univs_expr_opt fn (l,n) = let subst_univs_universe fn ul = let subst, nosubst = - Universe.Huniv.fold (fun u (subst,nosubst) -> + List.fold_right (fun u (subst,nosubst) -> try let a' = subst_univs_expr_opt fn u in (a' :: subst, nosubst) with Not_found -> (subst, u :: nosubst)) @@ -1271,7 +1124,7 @@ let subst_univs_universe fn ul = let substs = List.fold_left Universe.merge_univs Universe.empty subst in - List.fold_left (fun acc u -> Universe.merge_univs acc (Universe.Huniv.tip u)) + List.fold_left (fun acc u -> Universe.merge_univs acc (Universe.tip u)) substs nosubst let subst_univs_level fn l = diff --git a/kernel/univ.mli b/kernel/univ.mli index a4f2e26b63..94116e4737 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -411,6 +411,7 @@ sig val add_instance : Instance.t -> t -> t (** Arbitrary choice of linear order of the variables *) + val sort_levels : Level.t array -> Level.t array val to_context : t -> universe_context val of_context : universe_context -> t diff --git a/lib/cArray.ml b/lib/cArray.ml index d08f24d490..013585735c 100644 --- a/lib/cArray.ml +++ b/lib/cArray.ml @@ -334,7 +334,7 @@ let smartmap f (ar : 'a array) = Array.unsafe_set ans !i v; incr i; while !i < len do - let v = Array.unsafe_get ar !i in + let v = Array.unsafe_get ans !i in let v' = f v in if v != v' then Array.unsafe_set ans !i v'; incr i @@ -527,7 +527,7 @@ struct Array.unsafe_set ans !i v; incr i; while !i < len do - let v = Array.unsafe_get ar !i in + let v = Array.unsafe_get ans !i in let v' = f arg v in if v != v' then Array.unsafe_set ans !i v'; incr i diff --git a/lib/loc.ml b/lib/loc.ml index 9f036d90f9..4a935a9d9c 100644 --- a/lib/loc.ml +++ b/lib/loc.ml @@ -8,8 +8,12 @@ (* Locations management *) +type source = + | InFile of string + | ToplevelInput + type t = { - fname : string; (** filename *) + fname : source; (** filename or toplevel input *) line_nb : int; (** start line number *) bol_pos : int; (** position of the beginning of start line *) line_nb_last : int; (** end line number *) @@ -23,10 +27,15 @@ let create fname line_nb bol_pos bp ep = { line_nb_last = line_nb; bol_pos_last = bol_pos; bp = bp; ep = ep; } let make_loc (bp, ep) = { - fname = ""; line_nb = -1; bol_pos = 0; line_nb_last = -1; bol_pos_last = 0; + fname = ToplevelInput; line_nb = -1; bol_pos = 0; line_nb_last = -1; bol_pos_last = 0; bp = bp; ep = ep; } +let mergeable loc1 loc2 = + loc1.fname = loc2.fname + let merge loc1 loc2 = + if not (mergeable loc1 loc2) then + failwith "Trying to merge unmergeable locations."; if loc1.bp < loc2.bp then if loc1.ep < loc2.ep then { fname = loc1.fname; @@ -53,6 +62,8 @@ let merge_opt l1 l2 = match l1, l2 with let unloc loc = (loc.bp, loc.ep) +let shift_loc kb kp loc = { loc with bp = loc.bp + kb ; ep = loc.ep + kp } + (** Located type *) type 'a located = t option * 'a diff --git a/lib/loc.mli b/lib/loc.mli index 1fbaae8368..fde490cc8a 100644 --- a/lib/loc.mli +++ b/lib/loc.mli @@ -8,8 +8,12 @@ (** {5 Basic types} *) +type source = + | InFile of string + | ToplevelInput + type t = { - fname : string; (** filename *) + fname : source; (** filename or toplevel input *) line_nb : int; (** start line number *) bol_pos : int; (** position of the beginning of start line *) line_nb_last : int; (** end line number *) @@ -22,7 +26,7 @@ type t = { (** This is inherited from CAMPL4/5. *) -val create : string -> int -> int -> int -> int -> t +val create : source -> int -> int -> int -> int -> t (** Create a location from a filename, a line number, a position of the beginning of the line, a start and end position *) @@ -36,6 +40,11 @@ val merge : t -> t -> t val merge_opt : t option -> t option -> t option (** Merge locations, usually generating the largest possible span *) +val shift_loc : int -> int -> t -> t +(** [shift_loc loc n p] shifts the beginning of location by [n] and + the end by [p]; it is assumed that the shifts do not change the + lines at which the location starts and ends *) + (** {5 Located exceptions} *) val add_loc : Exninfo.info -> t -> Exninfo.info diff --git a/parsing/cLexer.ml4 b/parsing/cLexer.ml4 index 636027f9b4..9c9189ffeb 100644 --- a/parsing/cLexer.ml4 +++ b/parsing/cLexer.ml4 @@ -10,8 +10,19 @@ open Pp open Util open Tok +(** Location utilities *) +let ploc_file_of_coq_file = function +| Loc.ToplevelInput -> "" +| Loc.InFile f -> f + +let coq_file_of_ploc_file s = + if s = "" then Loc.ToplevelInput else Loc.InFile s + +let from_coqloc fname line_nb bol_pos bp ep = + Ploc.make_loc (ploc_file_of_coq_file fname) line_nb bol_pos (bp, ep) "" + let to_coqloc loc = - { Loc.fname = Ploc.file_name loc; + { Loc.fname = coq_file_of_ploc_file (Ploc.file_name loc); Loc.line_nb = Ploc.line_nb loc; Loc.bol_pos = Ploc.bol_pos loc; Loc.bp = Ploc.first_pos loc; @@ -118,14 +129,6 @@ let err loc str = Loc.raise ~loc:(to_coqloc loc) (Error.E str) let bad_token str = raise (Error.E (Bad_token str)) -(** Location utilities *) -let file_loc_of_file = function -| None -> "" -| Some f -> f - -let make_loc fname line_nb bol_pos bp ep = - Ploc.make_loc (file_loc_of_file fname) line_nb bol_pos (bp, ep) "" - (* Update a loc without allocating an intermediate pair *) let set_loc_pos loc bp ep = Ploc.sub loc (bp - Ploc.first_pos loc) (ep - bp) @@ -369,7 +372,7 @@ let rec string loc ~comm_level bp len = parser err loc Unterminated_string (* To associate locations to a file name *) -let current_file = ref None +let current_file = ref Loc.ToplevelInput (* Utilities for comments in beautify *) let comment_begin = ref None @@ -392,7 +395,7 @@ let rec split_comments comacc acc pos = function let extract_comments pos = split_comments [] [] pos !comments (* The state of the lexer visible from outside *) -type lexer_state = int option * string * bool * ((int * int) * string) list * string option +type lexer_state = int option * string * bool * ((int * int) * string) list * Loc.source let init_lexer_state f = (None,"",true,[],f) let set_lexer_state (o,s,b,c,f) = @@ -404,7 +407,7 @@ let set_lexer_state (o,s,b,c,f) = let release_lexer_state () = (!comment_begin, Buffer.contents current_comment, !between_commands, !comments, !current_file) let drop_lexer_state () = - set_lexer_state (init_lexer_state None) + set_lexer_state (init_lexer_state Loc.ToplevelInput) let real_push_char c = Buffer.add_char current_comment c @@ -672,7 +675,7 @@ let token_text = function let func cs = let loct = loct_create () in - let cur_loc = ref (make_loc !current_file 1 0 0 0) in + let cur_loc = ref (from_coqloc !current_file 1 0 0 0) in let ts = Stream.from (fun i -> diff --git a/parsing/cLexer.mli b/parsing/cLexer.mli index 77d652b185..d3ef19873f 100644 --- a/parsing/cLexer.mli +++ b/parsing/cLexer.mli @@ -49,7 +49,7 @@ end (* Mainly for comments state, etc... *) type lexer_state -val init_lexer_state : string option -> lexer_state +val init_lexer_state : Loc.source -> lexer_state val set_lexer_state : lexer_state -> unit val release_lexer_state : unit -> lexer_state val drop_lexer_state : unit -> unit diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index f637e9746c..4e8b98fcf2 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -123,8 +123,8 @@ let name_colon = let aliasvar = function { CAst.loc = loc; CAst.v = CPatAlias (_, id) } -> Some (loc,Name id) | _ -> None GEXTEND Gram - GLOBAL: binder_constr lconstr constr operconstr universe_level sort global - constr_pattern lconstr_pattern Constr.ident + GLOBAL: binder_constr lconstr constr operconstr universe_level sort sort_family + global constr_pattern lconstr_pattern Constr.ident closed_binder open_binders binder binders binders_fixannot record_declaration typeclass_constraint pattern appl_arg; Constr.ident: @@ -149,6 +149,12 @@ GEXTEND Gram | "Type"; "@{"; u = universe; "}" -> GType u ] ] ; + sort_family: + [ [ "Set" -> Sorts.InSet + | "Prop" -> Sorts.InProp + | "Type" -> Sorts.InType + ] ] + ; universe: [ [ IDENT "max"; "("; ids = LIST1 name SEP ","; ")" -> ids | id = name -> [id] @@ -295,7 +301,7 @@ GEXTEND Gram | -> [] ] ] ; instance: - [ [ "@{"; l = LIST1 universe_level; "}" -> Some l + [ [ "@{"; l = LIST0 universe_level; "}" -> Some l | -> None ] ] ; universe_level: diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4 index 42b5bfa935..e2c87bbbf6 100644 --- a/parsing/g_proofs.ml4 +++ b/parsing/g_proofs.ml4 @@ -45,11 +45,9 @@ GEXTEND Gram | IDENT "Existential"; n = natural; c = constr_body -> VernacSolveExistential (n,c) | IDENT "Admitted" -> VernacEndProof Admitted - | IDENT "Qed" -> VernacEndProof (Proved (Opaque None,None)) - | IDENT "Qed"; IDENT "exporting"; l = LIST0 identref SEP "," -> - VernacEndProof (Proved (Opaque (Some l),None)) + | IDENT "Qed" -> VernacEndProof (Proved (Opaque,None)) | IDENT "Save"; id = identref -> - VernacEndProof (Proved (Opaque None, Some id)) + VernacEndProof (Proved (Opaque, Some id)) | IDENT "Defined" -> VernacEndProof (Proved (Transparent,None)) | IDENT "Defined"; id=identref -> VernacEndProof (Proved (Transparent,Some id)) diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 560a9a7578..4a59b85978 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -64,20 +64,6 @@ let parse_compat_version ?(allow_old = true) = let open Flags in function CErrors.user_err ~hdr:"get_compat_version" Pp.(str "Unknown compatibility version \"" ++ str s ++ str "\".") -let extraction_err ~loc = - if not (Mltop.module_is_known "extraction_plugin") then - CErrors.user_err ~loc (str "Please do first a Require Extraction.") - else - (* The right grammar entries should have been loaded. - We could only end here in case of syntax error. *) - raise (Stream.Error "unexpected end of command") - -let funind_err ~loc = - if not (Mltop.module_is_known "recdef_plugin") then - CErrors.user_err ~loc (str "Please do first a Require Import FunInd.") - else - raise (Stream.Error "unexpected end of command") (* Same as above... *) - GEXTEND Gram GLOBAL: vernac gallina_ext noedit_mode subprf; vernac: FIRST @@ -89,10 +75,6 @@ GEXTEND Gram | IDENT "Local"; v = vernac_poly -> VernacLocal (true, v) | IDENT "Global"; v = vernac_poly -> VernacLocal (false, v) - (* Stm backdoor *) - | IDENT "Stm"; IDENT "JoinDocument"; "." -> VernacStm JoinDocument - | IDENT "Stm"; IDENT "Wait"; "." -> VernacStm Wait - | v = vernac_poly -> v ] ] ; @@ -156,13 +138,13 @@ let _ = Hook.set Constrexpr_ops.fresh_var_hook fresh_var (* Gallina declarations *) GEXTEND Gram GLOBAL: gallina gallina_ext thm_token def_body of_type_with_opt_coercion - record_field decl_notation rec_definition pidentref; + record_field decl_notation rec_definition pidentref ident_decl; gallina: (* Definition, Theorem, Variable, Axiom, ... *) - [ [ thm = thm_token; id = pidentref; bl = binders; ":"; c = lconstr; + [ [ thm = thm_token; id = ident_decl; bl = binders; ":"; c = lconstr; l = LIST0 - [ "with"; id = pidentref; bl = binders; ":"; c = lconstr -> + [ "with"; id = ident_decl; bl = binders; ":"; c = lconstr -> (Some id,(bl,c)) ] -> VernacStartTheoremProof (thm, (Some id,(bl,c))::l) | stre = assumption_token; nl = inline; bl = assum_list -> @@ -170,7 +152,7 @@ GEXTEND Gram | (kwd,stre) = assumptions_token; nl = inline; bl = assum_list -> test_plural_form loc kwd bl; VernacAssumption (stre, nl, bl) - | d = def_token; id = pidentref; b = def_body -> + | d = def_token; id = ident_decl; b = def_body -> VernacDefinition (d, id, b) | IDENT "Let"; id = identref; b = def_body -> VernacDefinition ((Some Discharge, Definition), (id, None), b) @@ -242,13 +224,29 @@ GEXTEND Gram | IDENT "Inline" -> DefaultInline | -> NoInline] ] ; - pidentref: - [ [ i = identref; l = OPT [ "@{" ; l = LIST0 identref; "}" -> l ] -> (i,l) ] ] - ; univ_constraint: [ [ l = universe_level; ord = [ "<" -> Univ.Lt | "=" -> Univ.Eq | "<=" -> Univ.Le ]; r = universe_level -> (l, ord, r) ] ] ; + pidentref: + [ [ i = identref; l = OPT [ "@{" ; l = LIST0 identref; "}" -> l ] -> (i,l) ] ] + ; + univ_decl : + [ [ "@{" ; l = LIST0 identref; ext = [ "+" -> true | -> false ]; + cs = [ "|"; l' = LIST0 univ_constraint SEP ","; + ext = [ "+" -> true | -> false ]; "}" -> (l',ext) + | ext = [ "}" -> true | "|}" -> false ] -> ([], ext) ] + -> + { univdecl_instance = l; + univdecl_extensible_instance = ext; + univdecl_constraints = fst cs; + univdecl_extensible_constraints = snd cs } + ] ] + ; + ident_decl: + [ [ i = identref; l = OPT univ_decl -> (i, l) + ] ] + ; finite_token: [ [ IDENT "Inductive" -> (Inductive_kw,Finite) | IDENT "CoInductive" -> (CoInductive,CoFinite) @@ -306,7 +304,7 @@ GEXTEND Gram | -> RecordDecl (None, []) ] ] ; inductive_definition: - [ [ oc = opt_coercion; id = pidentref; indpar = binders; + [ [ oc = opt_coercion; id = ident_decl; indpar = binders; c = OPT [ ":"; c = lconstr -> c ]; lc=opt_constructors_or_fields; ntn = decl_notation -> (((oc,id),indpar,c,lc),ntn) ] ] @@ -332,14 +330,14 @@ GEXTEND Gram ; (* (co)-fixpoints *) rec_definition: - [ [ id = pidentref; + [ [ id = ident_decl; bl = binders_fixannot; ty = type_cstr; def = OPT [":="; def = lconstr -> def]; ntn = decl_notation -> let bl, annot = bl in ((id,annot,bl,ty,def),ntn) ] ] ; corec_definition: - [ [ id = pidentref; bl = binders; ty = type_cstr; + [ [ id = ident_decl; bl = binders; ty = type_cstr; def = OPT [":="; def = lconstr -> def]; ntn = decl_notation -> ((id,bl,ty,def),ntn) ] ] ; @@ -354,13 +352,13 @@ GEXTEND Gram ; scheme_kind: [ [ IDENT "Induction"; "for"; ind = smart_global; - IDENT "Sort"; s = sort-> InductionScheme(true,ind,s) + IDENT "Sort"; s = sort_family-> InductionScheme(true,ind,s) | IDENT "Minimality"; "for"; ind = smart_global; - IDENT "Sort"; s = sort-> InductionScheme(false,ind,s) + IDENT "Sort"; s = sort_family-> InductionScheme(false,ind,s) | IDENT "Elimination"; "for"; ind = smart_global; - IDENT "Sort"; s = sort-> CaseScheme(true,ind,s) + IDENT "Sort"; s = sort_family-> CaseScheme(true,ind,s) | IDENT "Case"; "for"; ind = smart_global; - IDENT "Sort"; s = sort-> CaseScheme(false,ind,s) + IDENT "Sort"; s = sort_family-> CaseScheme(false,ind,s) | IDENT "Equality"; "for" ; ind = smart_global -> EqualityScheme(ind) ] ] ; (* Various Binders *) @@ -411,7 +409,7 @@ GEXTEND Gram [ [ "("; a = simple_assum_coe; ")" -> a ] ] ; simple_assum_coe: - [ [ idl = LIST1 pidentref; oc = of_type_with_opt_coercion; c = lconstr -> + [ [ idl = LIST1 ident_decl; oc = of_type_with_opt_coercion; c = lconstr -> (not (Option.is_empty oc),(idl,c)) ] ] ; @@ -814,7 +812,7 @@ GEXTEND Gram | IDENT "transparent" -> Conv_oracle.transparent ] ] ; instance_name: - [ [ name = pidentref; sup = OPT binders -> + [ [ name = ident_decl; sup = OPT binders -> (let ((loc,id),l) = name in ((loc, Name id),l)), (Option.default [] sup) | -> ((Loc.tag ~loc:!@loc Anonymous), None), [] ] ] @@ -881,22 +879,6 @@ GEXTEND Gram | IDENT "DelPath"; dir = ne_string -> VernacRemoveLoadPath dir - (* Some plugins are not loaded initially anymore : extraction, - and funind. To ease this transition toward a mandatory Require, - we hack here the vernac grammar in order to get customized - error messages telling what to Require instead of the dreadful - "Illegal begin of vernac". Normally, these fake grammar entries - are overloaded later by the grammar extensions in these plugins. - This code is meant to be removed in a few releases, when this - transition is considered finished. *) - - | IDENT "Extraction" -> extraction_err ~loc:!@loc - | IDENT "Extract" -> extraction_err ~loc:!@loc - | IDENT "Recursive"; IDENT "Extraction" -> extraction_err ~loc:!@loc - | IDENT "Separate"; IDENT "Extraction" -> extraction_err ~loc:!@loc - | IDENT "Function" -> funind_err ~loc:!@loc - | IDENT "Functional" -> funind_err ~loc:!@loc - (* Type-Checking (pas dans le refman) *) | "Type"; c = lconstr -> VernacGlobalCheck c @@ -1164,14 +1146,13 @@ GEXTEND Gram | IDENT "Reserved"; IDENT "Infix"; s = ne_lstring; l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ] -> - Metasyntax.check_infix_modifiers l; let (loc,s) = s in - VernacSyntaxExtension (false,((loc,"x '"^s^"' y"),l)) + VernacSyntaxExtension (true, false,((loc,"x '"^s^"' y"),l)) | IDENT "Reserved"; IDENT "Notation"; local = obsolete_locality; s = ne_lstring; l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ] - -> VernacSyntaxExtension (local,(s,l)) + -> VernacSyntaxExtension (false, local,(s,l)) (* "Print" "Grammar" should be here but is in "command" entry in order to factorize with other "Print"-based vernac entries *) diff --git a/parsing/highparsing.mllib b/parsing/highparsing.mllib deleted file mode 100644 index 05e2911c2f..0000000000 --- a/parsing/highparsing.mllib +++ /dev/null @@ -1,4 +0,0 @@ -G_constr -G_vernac -G_prim -G_proofs diff --git a/parsing/parsing.mllib b/parsing/parsing.mllib index 2a73d7bc69..1f29636b2e 100644 --- a/parsing/parsing.mllib +++ b/parsing/parsing.mllib @@ -3,3 +3,7 @@ CLexer Pcoq Egramml Egramcoq +G_constr +G_vernac +G_prim +G_proofs diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 81f02bf955..3d00b220b8 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -15,8 +15,11 @@ let curry f x y = f (x, y) let uncurry f (x,y) = f x y (** Location Utils *) +let coq_file_of_ploc_file s = + if s = "" then Loc.ToplevelInput else Loc.InFile s + let to_coqloc loc = - { Loc.fname = Ploc.file_name loc; + { Loc.fname = coq_file_of_ploc_file (Ploc.file_name loc); Loc.line_nb = Ploc.line_nb loc; Loc.bol_pos = Ploc.bol_pos loc; Loc.bp = Ploc.first_pos loc; @@ -80,7 +83,7 @@ module type S = Gramext.position option * single_extend_statment list type coq_parsable - val parsable : ?file:string -> char Stream.t -> coq_parsable + val parsable : ?file:Loc.source -> char Stream.t -> coq_parsable val action : 'a -> action val entry_create : string -> 'a entry val entry_parse : 'a entry -> coq_parsable -> 'a @@ -104,7 +107,7 @@ end with type 'a Entry.e = 'a Grammar.GMake(CLexer).Entry.e = struct Gramext.position option * single_extend_statment list type coq_parsable = parsable * CLexer.lexer_state ref - let parsable ?file c = + let parsable ?(file=Loc.ToplevelInput) c = let state = ref (CLexer.init_lexer_state file) in CLexer.set_lexer_state !state; let a = parsable c in @@ -442,6 +445,7 @@ module Prim = let name = Gram.entry_create "Prim.name" let identref = Gram.entry_create "Prim.identref" let pidentref = Gram.entry_create "Prim.pidentref" + let ident_decl = Gram.entry_create "Prim.ident_decl" let pattern_ident = Gram.entry_create "pattern_ident" let pattern_identref = Gram.entry_create "pattern_identref" @@ -471,6 +475,7 @@ module Constr = let global = make_gen_entry uconstr "global" let universe_level = make_gen_entry uconstr "universe_level" let sort = make_gen_entry uconstr "sort" + let sort_family = make_gen_entry uconstr "sort_family" let pattern = Gram.entry_create "constr:pattern" let constr_pattern = gec_constr "constr_pattern" let lconstr_pattern = gec_constr "lconstr_pattern" @@ -631,6 +636,7 @@ let () = Grammar.register0 wit_ident (Prim.ident); Grammar.register0 wit_var (Prim.var); Grammar.register0 wit_ref (Prim.reference); + Grammar.register0 wit_sort_family (Constr.sort_family); Grammar.register0 wit_constr (Constr.constr); Grammar.register0 wit_red_expr (Vernac_.red_expr); () diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 445818e130..2f03754193 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -73,7 +73,7 @@ module type S = type coq_parsable - val parsable : ?file:string -> char Stream.t -> coq_parsable + val parsable : ?file:Loc.source -> char Stream.t -> coq_parsable val action : 'a -> action val entry_create : string -> 'a entry val entry_parse : 'a entry -> coq_parsable -> 'a @@ -195,6 +195,7 @@ module Prim : val name : Name.t located Gram.entry val identref : Id.t located Gram.entry val pidentref : (Id.t located * (Id.t located list) option) Gram.entry + val ident_decl : ident_decl Gram.entry val pattern_ident : Id.t Gram.entry val pattern_identref : Id.t located Gram.entry val base_ident : Id.t Gram.entry @@ -225,6 +226,7 @@ module Constr : val global : reference Gram.entry val universe_level : glob_level Gram.entry val sort : glob_sort Gram.entry + val sort_family : Sorts.family Gram.entry val pattern : cases_pattern_expr Gram.entry val constr_pattern : constr_expr Gram.entry val lconstr_pattern : constr_expr Gram.entry diff --git a/plugins/derive/Derive.v b/plugins/derive/Derive.v index 0d5a93b034..d1046ae79b 100644 --- a/plugins/derive/Derive.v +++ b/plugins/derive/Derive.v @@ -1 +1 @@ -Declare ML Module "derive_plugin".
\ No newline at end of file +Declare ML Module "derive_plugin". diff --git a/plugins/extraction/ExtrHaskellNatNum.v b/plugins/extraction/ExtrHaskellNatNum.v index fabe9a4c67..09b0444614 100644 --- a/plugins/extraction/ExtrHaskellNatNum.v +++ b/plugins/extraction/ExtrHaskellNatNum.v @@ -34,4 +34,4 @@ Extract Constant Init.Nat.sub => "(\n m -> Prelude.max 0 (n Prelude.- m))". Extract Constant Nat.div => "(\n m -> if m Prelude.== 0 then 0 else Prelude.div n m)". Extract Constant Nat.modulo => "(\n m -> if m Prelude.== 0 then 0 else Prelude.mod n m)". Extract Constant Init.Nat.div => "(\n m -> if m Prelude.== 0 then 0 else Prelude.div n m)". -Extract Constant Init.Nat.modulo => "(\n m -> if m Prelude.== 0 then 0 else Prelude.mod n m)".
\ No newline at end of file +Extract Constant Init.Nat.modulo => "(\n m -> if m Prelude.== 0 then 0 else Prelude.mod n m)". diff --git a/plugins/extraction/ExtrOcamlIntConv.v b/plugins/extraction/ExtrOcamlIntConv.v index fe6eb7780f..ab13d75ada 100644 --- a/plugins/extraction/ExtrOcamlIntConv.v +++ b/plugins/extraction/ExtrOcamlIntConv.v @@ -96,4 +96,4 @@ Extraction "/tmp/test.ml" pos_of_int int_of_pos z_of_int int_of_z n_of_int int_of_n. -*)
\ No newline at end of file +*) diff --git a/plugins/extraction/Extraction.v b/plugins/extraction/Extraction.v index 1374a91abf..b3f9d6556d 100644 --- a/plugins/extraction/Extraction.v +++ b/plugins/extraction/Extraction.v @@ -6,4 +6,4 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -Declare ML Module "extraction_plugin".
\ No newline at end of file +Declare ML Module "extraction_plugin". diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 513fce2484..409bb89eeb 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -11,7 +11,6 @@ open Tactics open Context.Rel.Declaration open Indfun_common open Functional_principles_proofs -open Misctypes module RelDecl = Context.Rel.Declaration @@ -339,13 +338,14 @@ let generate_functional_principle (evd: Evd.evar_map ref) then (* let id_of_f = Label.to_id (con_label f) in *) let register_with_sort fam_sort = - let evd' = Evd.from_env (Global.env ()) in - let evd',s = Evd.fresh_sort_in_family env evd' fam_sort in - let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in - let evd',value = change_property_sort evd' s new_principle_type new_princ_name in - let evd' = fst (Typing.type_of ~refresh:true (Global.env ()) evd' (EConstr.of_constr value)) in - (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) - let ce = Declare.definition_entry ~poly:(Flags.is_universe_polymorphism ()) ~univs:(snd (Evd.universe_context evd')) value in + let evd' = Evd.from_env (Global.env ()) in + let evd',s = Evd.fresh_sort_in_family env evd' fam_sort in + let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in + let evd',value = change_property_sort evd' s new_principle_type new_princ_name in + let evd' = fst (Typing.type_of ~refresh:true (Global.env ()) evd' (EConstr.of_constr value)) in + (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) + let univs = (snd (Evd.universe_context ~names:[] ~extensible:true evd')) in + let ce = Declare.definition_entry ~poly:(Flags.is_universe_polymorphism ()) ~univs value in ignore( Declare.declare_constant name @@ -463,7 +463,7 @@ let get_funs_constant mp dp = exception No_graph_found exception Found_type of int -let make_scheme evd (fas : (pconstant*glob_sort) list) : Safe_typing.private_constants definition_entry list = +let make_scheme evd (fas : (pconstant*Sorts.family) list) : Safe_typing.private_constants definition_entry list = let env = Global.env () in let funs = List.map fst fas in let first_fun = List.hd funs in @@ -500,7 +500,7 @@ let make_scheme evd (fas : (pconstant*glob_sort) list) : Safe_typing.private_con let i = ref (-1) in let sorts = List.rev_map (fun (_,x) -> - Evarutil.evd_comb1 (Evd.fresh_sort_in_family env) evd (Pretyping.interp_elimination_sort x) + Evarutil.evd_comb1 (Evd.fresh_sort_in_family env) evd x ) fas in @@ -674,7 +674,7 @@ let build_case_scheme fa = let scheme_type = EConstr.Unsafe.to_constr ((Typing.unsafe_type_of env sigma) (EConstr.of_constr scheme)) in let sorts = (fun (_,_,x) -> - Universes.new_sort_in_family (Pretyping.interp_elimination_sort x) + Universes.new_sort_in_family x ) fa in diff --git a/plugins/funind/functional_principles_types.mli b/plugins/funind/functional_principles_types.mli index 5a7ffe0590..2eb1b7935d 100644 --- a/plugins/funind/functional_principles_types.mli +++ b/plugins/funind/functional_principles_types.mli @@ -8,7 +8,6 @@ open Names open Term -open Misctypes val generate_functional_principle : Evd.evar_map ref -> @@ -37,8 +36,7 @@ val compute_new_princ_type_from_rel : constr array -> Sorts.t array -> exception No_graph_found val make_scheme : Evd.evar_map ref -> - (pconstant*glob_sort) list -> Safe_typing.private_constants Entries.definition_entry list - -val build_scheme : (Id.t*Libnames.reference*glob_sort) list -> unit -val build_case_scheme : (Id.t*Libnames.reference*glob_sort) -> unit + (pconstant*Sorts.family) list -> Safe_typing.private_constants Entries.definition_entry list +val build_scheme : (Id.t*Libnames.reference*Sorts.family) list -> unit +val build_case_scheme : (Id.t*Libnames.reference*Sorts.family) -> unit diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 16d9f200f3..62ecaa552b 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -166,11 +166,11 @@ END let pr_fun_scheme_arg (princ_name,fun_name,s) = Names.Id.print princ_name ++ str " :=" ++ spc() ++ str "Induction for " ++ Libnames.pr_reference fun_name ++ spc() ++ str "Sort " ++ - Ppconstr.pr_glob_sort s + Termops.pr_sort_family s VERNAC ARGUMENT EXTEND fun_scheme_arg PRINTED BY pr_fun_scheme_arg -| [ ident(princ_name) ":=" "Induction" "for" reference(fun_name) "Sort" sort(s) ] -> [ (princ_name,fun_name,s) ] +| [ ident(princ_name) ":=" "Induction" "for" reference(fun_name) "Sort" sort_family(s) ] -> [ (princ_name,fun_name,s) ] END diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 8dea6c90f5..5f8d50da12 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -797,7 +797,7 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( (fun entry -> (EConstr.of_constr (fst (fst(Future.force entry.Entries.const_entry_body))), EConstr.of_constr (Option.get entry.Entries.const_entry_type )) ) - (make_scheme evd (Array.map_to_list (fun const -> const,GType []) funs)) + (make_scheme evd (Array.map_to_list (fun const -> const,Sorts.InType) funs)) ) ) in diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 41a10cba3c..7b63366e8a 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -1288,8 +1288,8 @@ let build_new_goal_type () = let is_opaque_constant c = let cb = Global.lookup_constant c in match cb.Declarations.const_body with - | Declarations.OpaqueDef _ -> Vernacexpr.Opaque None - | Declarations.Undef _ -> Vernacexpr.Opaque None + | Declarations.OpaqueDef _ -> Vernacexpr.Opaque + | Declarations.Undef _ -> Vernacexpr.Opaque | Declarations.Def _ -> Vernacexpr.Transparent let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) = @@ -1543,7 +1543,10 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let equation_id = add_suffix function_name "_equation" in let functional_id = add_suffix function_name "_F" in let term_id = add_suffix function_name "_terminate" in - let functional_ref = declare_fun functional_id (IsDefinition Decl_kinds.Definition) ~ctx:(snd (Evd.universe_context evm)) res in + let functional_ref = + let ctx = (snd (Evd.universe_context ~names:[] ~extensible:true evm)) in + declare_fun functional_id (IsDefinition Decl_kinds.Definition) ~ctx res + in (* Refresh the global universes, now including those of _F *) let evm = 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 diff --git a/plugins/ltac/extratactics.ml4 b/plugins/ltac/extratactics.ml4 index 99e4440102..b4c6f9c90e 100644 --- a/plugins/ltac/extratactics.ml4 +++ b/plugins/ltac/extratactics.ml4 @@ -403,38 +403,38 @@ open Leminv let seff id = Vernacexpr.VtSideff [id], Vernacexpr.VtLater -VERNAC ARGUMENT EXTEND sort -| [ "Set" ] -> [ GSet ] -| [ "Prop" ] -> [ GProp ] -| [ "Type" ] -> [ GType [] ] -END +(*VERNAC ARGUMENT EXTEND sort_family +| [ "Set" ] -> [ InSet ] +| [ "Prop" ] -> [ InProp ] +| [ "Type" ] -> [ InType ] +END*) VERNAC COMMAND EXTEND DeriveInversionClear -| [ "Derive" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort(s) ] +| [ "Derive" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort_family(s) ] => [ seff na ] -> [ add_inversion_lemma_exn na c s false inv_clear_tac ] | [ "Derive" "Inversion_clear" ident(na) "with" constr(c) ] => [ seff na ] - -> [ add_inversion_lemma_exn na c GProp false inv_clear_tac ] + -> [ add_inversion_lemma_exn na c InProp false inv_clear_tac ] END VERNAC COMMAND EXTEND DeriveInversion -| [ "Derive" "Inversion" ident(na) "with" constr(c) "Sort" sort(s) ] +| [ "Derive" "Inversion" ident(na) "with" constr(c) "Sort" sort_family(s) ] => [ seff na ] -> [ add_inversion_lemma_exn na c s false inv_tac ] | [ "Derive" "Inversion" ident(na) "with" constr(c) ] => [ seff na ] - -> [ add_inversion_lemma_exn na c GProp false inv_tac ] + -> [ add_inversion_lemma_exn na c InProp false inv_tac ] END VERNAC COMMAND EXTEND DeriveDependentInversion -| [ "Derive" "Dependent" "Inversion" ident(na) "with" constr(c) "Sort" sort(s) ] +| [ "Derive" "Dependent" "Inversion" ident(na) "with" constr(c) "Sort" sort_family(s) ] => [ seff na ] -> [ add_inversion_lemma_exn na c s true dinv_tac ] END VERNAC COMMAND EXTEND DeriveDependentInversionClear -| [ "Derive" "Dependent" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort(s) ] +| [ "Derive" "Dependent" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort_family(s) ] => [ seff na ] -> [ add_inversion_lemma_exn na c s true dinv_clear_tac ] END diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 75b665aad9..3d01cbe8dd 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -1884,7 +1884,7 @@ let declare_projection n instance_id r = in it_mkProd_or_LetIn ccl ctx in let typ = it_mkProd_or_LetIn typ ctx in - let pl, ctx = Evd.universe_context sigma in + let pl, ctx = Evd.universe_context ~names:[] ~extensible:true sigma in let typ = EConstr.to_constr sigma typ in let term = EConstr.to_constr sigma term in let cst = diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index cf676f598f..a8d518fbd8 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -216,7 +216,6 @@ let interp_prod_item = function assert (String.equal s "tactic"); begin match Tacarg.wit_tactic with | ExtraArg tag -> ArgT.Any tag - | _ -> assert false end in let symbol = interp_entry_name interp symbol in diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index d07b2e0b45..99493d6982 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -1773,11 +1773,6 @@ let onClearedName2 id tac = tclTHENLIST [ introduction id1; introduction id2; tac id1 id2 ] end) -let rec is_Prop sigma c = match EConstr.kind sigma c with - | Sort s -> Sorts.is_prop (ESorts.kind sigma s) - | Cast (c,_,_) -> is_Prop sigma c - | _ -> false - let destructure_hyps = Proofview.Goal.enter begin fun gl -> let type_of = Tacmach.New.pf_unsafe_type_of gl in @@ -1809,7 +1804,7 @@ let destructure_hyps = | Kimp(t1,t2) -> (* t1 and t2 might be in Type rather than Prop. For t1, the decidability check will ensure being Prop. *) - if is_Prop sigma (type_of t2) + if Termops.is_Prop sigma (type_of t2) then let d1 = decidability t1 in tclTHENLIST [ diff --git a/plugins/romega/ROmega.v b/plugins/romega/ROmega.v index 3ddb6bed12..657aae90e8 100644 --- a/plugins/romega/ROmega.v +++ b/plugins/romega/ROmega.v @@ -11,4 +11,4 @@ Require Export Setoid. Require Export PreOmega. Require Export ZArith_base. Require Import OmegaPlugin. -Declare ML Module "romega_plugin".
\ No newline at end of file +Declare ML Module "romega_plugin". diff --git a/plugins/setoid_ring/Ring_tac.v b/plugins/setoid_ring/Ring_tac.v index 329fa0ee81..36d1e7c542 100644 --- a/plugins/setoid_ring/Ring_tac.v +++ b/plugins/setoid_ring/Ring_tac.v @@ -460,4 +460,4 @@ Tactic Notation "ring_simplify" "["constr_list(lH)"]" constr_list(rl) "in" hyp(H intro H'; move H' after H; clear H;rename H' into H; - unfold g;clear g.
\ No newline at end of file + unfold g;clear g. diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index d0fe1f9570..b8fae2494f 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -220,7 +220,7 @@ let exec_tactic env evd n f args = let gls = Proofview.V82.of_tactic (Tacinterp.eval_tactic_ist ist (ltac_call f (args@[getter]))) gl in let evd, nf = Evarutil.nf_evars_and_universes (Refiner.project gls) in let nf c = nf (constr_of c) in - Array.map nf !tactic_res, snd (Evd.universe_context evd) + Array.map nf !tactic_res, snd (Evd.universe_context ~names:[] ~extensible:true evd) let stdlib_modules = [["Coq";"Setoids";"Setoid"]; diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 1cc072a2a2..260cd04446 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -9,7 +9,6 @@ open CErrors open Util open Pp -open Flags open Names open Libnames open Globnames @@ -387,7 +386,7 @@ let add_coercion_in_graph (ic,source,target) = old_inheritance_graph end; let is_ambig = match !ambig_paths with [] -> false | _ -> true in - if is_ambig && not !quiet then + if is_ambig && not !Flags.quiet then Feedback.msg_info (message_ambig !ambig_paths) type coercion = { diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index 886cfd880f..ca7f633dc5 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -90,7 +90,8 @@ let rec build_lambda sigma vars ctx m = match vars with let pre, suf = List.chop (pred n) ctx in let (na, t, suf) = match suf with | [] -> assert false - | (_, na, t) :: suf -> (na, t, suf) + | (_, id, t) :: suf -> + (Name id, t, suf) in (** Check that the abstraction is legal by generating a transitive closure of its dependencies. *) @@ -126,11 +127,11 @@ let rec build_lambda sigma vars ctx m = match vars with mkRel 1 :: List.mapi (fun i _ -> mkRel (i + keep + 2)) suf in - let map i (id, na, c) = + let map i (na, id, c) = let i = succ i in let subst = List.skipn i subst in let subst = List.map (fun c -> Vars.lift (- i) c) subst in - (id, na, substl subst c) + (na, id, substl subst c) in let pre = List.mapi map pre in let pre = List.filter_with clear pre in @@ -150,11 +151,10 @@ let rec build_lambda sigma vars ctx m = match vars with let rec extract_bound_aux k accu frels ctx = match ctx with | [] -> accu -| (na1, na2, _) :: ctx -> +| (na, _, _) :: ctx -> if Int.Set.mem k frels then - begin match na1 with + begin match na with | Name id -> - let () = assert (match na2 with Anonymous -> false | Name _ -> true) in let () = if Id.Set.mem id accu then raise PatternMatchingFailure in extract_bound_aux (k + 1) (Id.Set.add id accu) frels ctx | Anonymous -> raise PatternMatchingFailure @@ -167,13 +167,21 @@ let extract_bound_vars frels ctx = let dummy_constr = EConstr.mkProp let make_renaming ids = function -| (Name id, Name _, _) -> +| (Name id, _, _) -> begin try EConstr.mkRel (List.index Id.equal id ids) with Not_found -> dummy_constr end | _ -> dummy_constr +let push_binder na1 na2 t ctx = + let id2 = match na2 with + | Name id2 -> id2 + | Anonymous -> + let avoid = List.map pi2 ctx in + Namegen.next_ident_away Namegen.default_non_dependent_ident avoid in + (na1, id2, t) :: ctx + let to_fix (idx, (nas, cs, ts)) = let inj = EConstr.of_constr in (idx, (nas, Array.map inj cs, Array.map inj ts)) @@ -306,19 +314,19 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels sorec ctx env subst c1 c2 | PProd (na1,c1,d1), Prod(na2,c2,d2) -> - sorec ((na1,na2,c2)::ctx) (EConstr.push_rel (LocalAssum (na2,c2)) env) + sorec (push_binder na1 na2 c2 ctx) (EConstr.push_rel (LocalAssum (na2,c2)) env) (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2 | PLambda (na1,c1,d1), Lambda(na2,c2,d2) -> - sorec ((na1,na2,c2)::ctx) (EConstr.push_rel (LocalAssum (na2,c2)) env) + sorec (push_binder na1 na2 c2 ctx) (EConstr.push_rel (LocalAssum (na2,c2)) env) (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2 | PLetIn (na1,c1,Some t1,d1), LetIn(na2,c2,t2,d2) -> - sorec ((na1,na2,t2)::ctx) (EConstr.push_rel (LocalDef (na2,c2,t2)) env) + sorec (push_binder na1 na2 t2 ctx) (EConstr.push_rel (LocalDef (na2,c2,t2)) env) (add_binders na1 na2 binding_vars (sorec ctx env (sorec ctx env subst c1 c2) t1 t2)) d1 d2 | PLetIn (na1,c1,None,d1), LetIn(na2,c2,t2,d2) -> - sorec ((na1,na2,t2)::ctx) (EConstr.push_rel (LocalDef (na2,c2,t2)) env) + sorec (push_binder na1 na2 t2 ctx) (EConstr.push_rel (LocalDef (na2,c2,t2)) env) (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2 | PIf (a1,b1,b1'), Case (ci,_,a2,[|b2;b2'|]) -> @@ -327,7 +335,7 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels let n = Context.Rel.length ctx_b2 in let n' = Context.Rel.length ctx_b2' in if Vars.noccur_between sigma 1 n b2 && Vars.noccur_between sigma 1 n' b2' then - let f l (LocalAssum (na,t) | LocalDef (na,_,t)) = (Anonymous,na,t)::l in + let f l (LocalAssum (na,t) | LocalDef (na,_,t)) = push_binder Anonymous na t l in let ctx_br = List.fold_left f ctx ctx_b2 in let ctx_br' = List.fold_left f ctx ctx_b2' in let b1 = lift_pattern n b1 and b1' = lift_pattern n' b1' in diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 1eb22cdb81..5e14307418 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -460,8 +460,11 @@ and detype_r d flags avoid env sigma t = in GVar (Id.of_string s)) | Meta n -> (* Meta in constr are not user-parsable and are mapped to Evar *) - (* using numbers to be unparsable *) - GEvar (Id.of_string ("M" ^ string_of_int n), []) + if n = Constr_matching.special_meta then + (* Using a dash to be unparsable *) + GEvar (Id.of_string_soft "CONTEXT-HOLE", []) + else + GEvar (Id.of_string_soft ("INTERNAL#" ^ string_of_int n), []) | Var id -> (try let _ = Global.lookup_named id in GRef (VarRef id, None) with Not_found -> GVar id) diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index c40a24e3b7..e1576b9713 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -234,7 +234,8 @@ let fold_glob_constr_with_binders g f v acc = DAst.(with_val (function let acc = Option.fold_left (f v') acc rtntypopt in List.fold_left fold_pattern acc pl | GLetTuple (nal,rtntyp,b,c) -> - f v (f v (fold_return_type_with_binders f g v acc rtntyp) b) c + f (List.fold_right (Name.fold_right g) nal v) + (f v (fold_return_type_with_binders f g v acc rtntyp) b) c | GIf (c,rtntyp,b1,b2) -> f v (f v (f v (fold_return_type_with_binders f g v acc rtntyp) c) b1) b2 | GRec (_,idl,bll,tyl,bv) -> diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 88ca9b5ca8..b31ee03d8c 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -397,8 +397,8 @@ let get_arity env ((ind,u),params) = mib.mind_params_ctxt else begin assert (Int.equal nparams mib.mind_nparams_rec); - let nnonrecparamdecls = List.length mib.mind_params_ctxt - mib.mind_nparams_rec in - snd (List.chop nnonrecparamdecls mib.mind_params_ctxt) + let nnonrecparamdecls = mib.mind_nparams - mib.mind_nparams_rec in + snd (Termops.context_chop nnonrecparamdecls mib.mind_params_ctxt) end in let parsign = Vars.subst_instance_context u parsign in let arproperlength = List.length mip.mind_arity_ctxt - List.length parsign in diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 79d2c3333b..ea1f2de539 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -222,18 +222,6 @@ let interp_level_info ?loc evd : Misctypes.level_info -> _ = function | None -> new_univ_level_variable ?loc univ_rigid evd | Some (loc,s) -> interp_universe_level_name ~anon_rigidity:univ_flexible evd (Loc.tag ?loc s) -let interp_sort ?loc evd = function - | GProp -> evd, Prop Null - | GSet -> evd, Prop Pos - | GType n -> - let evd, u = interp_universe ?loc evd n in - evd, Type u - -let interp_elimination_sort = function - | GProp -> InProp - | GSet -> InSet - | GType _ -> InType - type inference_hook = env -> evar_map -> evar -> evar_map * constr type inference_flags = { @@ -1103,15 +1091,6 @@ and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update = and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar c = match DAst.get c with | GHole (knd, naming, None) -> let loc = loc_of_glob_constr c in - let rec is_Type c = match EConstr.kind !evdref c with - | Sort s -> - begin match ESorts.kind !evdref s with - | Type _ -> true - | Prop _ -> false - end - | Cast (c, _, _) -> is_Type c - | _ -> false - in (match valcon with | Some v -> let s = @@ -1119,7 +1098,7 @@ and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar c = match D let t = Retyping.get_type_of env.ExtraEnv.env sigma v in match EConstr.kind sigma (whd_all env.ExtraEnv.env sigma t) with | Sort s -> ESorts.kind sigma s - | Evar ev when is_Type (existential_type sigma ev) -> + | Evar ev when is_Type sigma (existential_type sigma ev) -> evd_comb1 (define_evar_as_sort env.ExtraEnv.env) evdref ev | _ -> anomaly (Pp.str "Found a type constraint which is not a type.") in diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index 7395e94a09..5822f5add5 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -18,7 +18,6 @@ open Evd open EConstr open Glob_term open Evarutil -open Misctypes (** An auxiliary function for searching for fixpoint guard indexes *) @@ -119,9 +118,6 @@ val ise_pretype_gen : (** To embed constr in glob_constr *) -val interp_sort : ?loc:Loc.t -> evar_map -> glob_sort -> evar_map * sorts -val interp_elimination_sort : glob_sort -> sorts_family - val register_constr_interp0 : ('r, 'g, 't) Genarg.genarg_type -> (unbound_ltac_var_map -> env -> evar_map -> types -> 'g -> constr * evar_map) -> unit diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib index c8b3307d76..d04dcb8e3b 100644 --- a/pretyping/pretyping.mllib +++ b/pretyping/pretyping.mllib @@ -29,3 +29,4 @@ Indrec Cases Pretyping Unification +Univdecls diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 3563235434..2aa2f90131 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -1438,17 +1438,13 @@ let sigma_univ_state = let infer_conv_gen conv_fun ?(catch_incon=true) ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) env sigma x y = (** FIXME *) - let open Universes in - let x = EConstr.Unsafe.to_constr x in - let y = EConstr.Unsafe.to_constr y in try - let fold cstr accu = Some (Constraints.fold Constraints.add cstr accu) in let b, sigma = let ans = if pb == Reduction.CUMUL then - Universes.leq_constr_univs_infer (Evd.universes sigma) fold x y Constraints.empty + EConstr.leq_constr_universes sigma x y else - Universes.eq_constr_univs_infer (Evd.universes sigma) fold x y Constraints.empty + EConstr.eq_constr_universes sigma x y in let ans = match ans with | None -> None @@ -1462,6 +1458,8 @@ let infer_conv_gen conv_fun ?(catch_incon=true) ?(pb=Reduction.CUMUL) in if b then sigma, true else + let x = EConstr.Unsafe.to_constr x in + let y = EConstr.Unsafe.to_constr y in let sigma' = conv_fun pb ~l2r:false sigma ts env (sigma, sigma_univ_state) x y in diff --git a/pretyping/univdecls.ml b/pretyping/univdecls.ml new file mode 100644 index 0000000000..d7c42d03af --- /dev/null +++ b/pretyping/univdecls.ml @@ -0,0 +1,64 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open Nameops +open CErrors +open Pp + +(** Local universes and constraints declarations *) +type universe_decl = + (Id.t Loc.located list, Univ.Constraint.t) Misctypes.gen_universe_decl + +let default_univ_decl = + let open Misctypes in + { univdecl_instance = []; + univdecl_extensible_instance = true; + univdecl_constraints = Univ.Constraint.empty; + univdecl_extensible_constraints = true } + +let interp_univ_constraints env evd cstrs = + let open Misctypes in + let u_of_id x = + match x with + | Misctypes.GProp -> Loc.tag Univ.Level.prop + | GSet -> Loc.tag Univ.Level.set + | GType None | GType (Some (_, Anonymous)) -> + user_err ~hdr:"interp_constraint" + (str "Cannot declare constraints on anonymous universes") + | GType (Some (loc, Name id)) -> + try loc, Evd.universe_of_name evd (Id.to_string id) + with Not_found -> + user_err ?loc ~hdr:"interp_constraint" (str "Undeclared universe " ++ pr_id id) + in + let interp (evd,cstrs) (u, d, u') = + let lloc, ul = u_of_id u and rloc, u'l = u_of_id u' in + let cstr = (ul,d,u'l) in + let cstrs' = Univ.Constraint.add cstr cstrs in + try let evd = Evd.add_constraints evd (Univ.Constraint.singleton cstr) in + evd, cstrs' + with Univ.UniverseInconsistency e -> + user_err ~hdr:"interp_constraint" (str "Universe inconsistency" (* TODO *)) + in + List.fold_left interp (evd,Univ.Constraint.empty) cstrs + +let interp_univ_decl env decl = + let open Misctypes in + let pl = decl.univdecl_instance in + let evd = Evd.from_ctx (Evd.make_evar_universe_context env (Some pl)) in + let evd, cstrs = interp_univ_constraints env evd decl.univdecl_constraints in + let decl = { univdecl_instance = pl; + univdecl_extensible_instance = decl.univdecl_extensible_instance; + univdecl_constraints = cstrs; + univdecl_extensible_constraints = decl.univdecl_extensible_constraints } + in evd, decl + +let interp_univ_decl_opt env l = + match l with + | None -> Evd.from_env env, default_univ_decl + | Some decl -> interp_univ_decl env decl diff --git a/pretyping/univdecls.mli b/pretyping/univdecls.mli new file mode 100644 index 0000000000..0c3b749cbf --- /dev/null +++ b/pretyping/univdecls.mli @@ -0,0 +1,19 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Local universe and constraint declarations. *) +type universe_decl = + (Names.Id.t Loc.located list, Univ.Constraint.t) Misctypes.gen_universe_decl + +val default_univ_decl : universe_decl + +val interp_univ_decl : Environ.env -> Vernacexpr.universe_decl_expr -> + Evd.evar_map * universe_decl + +val interp_univ_decl_opt : Environ.env -> Vernacexpr.universe_decl_expr option -> + Evd.evar_map * universe_decl diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index 4a103cdd23..102c6ef6de 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -117,7 +117,7 @@ let tag_var = tag Tag.variable let pp1 = str s in return unp pp1 pp2 | UnpBox (b,sub) as unp :: l -> - let pp1 = ppcmd_of_box b (aux sub) in + let pp1 = ppcmd_of_box b (aux (List.map snd sub)) in let pp2 = aux l in return unp pp1 pp2 | UnpCut cut as unp :: l -> @@ -380,9 +380,9 @@ let tag_var = tag Tag.variable match bl with | [CLocalAssum (nal,k,t)] -> kw n ++ pr_binder false pr_c (nal,k,t) - | (CLocalAssum _ | CLocalPattern _) :: _ as bdl -> + | (CLocalAssum _ | CLocalPattern _ | CLocalDef _) :: _ as bdl -> kw n ++ pr_undelimited_binders sep pr_c bdl - | _ -> assert false + | [] -> assert false let pr_binders_gen pr_c sep is_open = if is_open then pr_delimited_binders pr_com_at sep pr_c diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index 4c50c2f368..10dd42ea91 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -37,11 +37,29 @@ open Decl_kinds | Some loc -> let (b,_) = Loc.unloc loc in pr_located pr_id @@ Loc.tag ~loc:(Loc.make_loc (b,b + String.length (Id.to_string id))) id - let pr_plident (lid, l) = - pr_lident lid ++ - (match l with - | Some l -> prlist_with_sep spc pr_lident l - | None -> mt()) + let pr_uconstraint (l, d, r) = + pr_glob_level l ++ spc () ++ Univ.pr_constraint_type d ++ spc () ++ + pr_glob_level r + + let pr_univdecl_instance l extensible = + prlist_with_sep spc pr_lident l ++ + (if extensible then str"+" else mt ()) + + let pr_univdecl_constraints l extensible = + if List.is_empty l && extensible then mt () + else str"|" ++ spc () ++ prlist_with_sep (fun () -> str",") pr_uconstraint l ++ + (if extensible then str"+" else mt()) + + let pr_universe_decl l = + let open Misctypes in + match l with + | None -> mt () + | Some l -> + str"@{" ++ pr_univdecl_instance l.univdecl_instance l.univdecl_extensible_instance ++ + pr_univdecl_constraints l.univdecl_constraints l.univdecl_extensible_constraints ++ str "}" + + let pr_ident_decl (lid, l) = + pr_lident lid ++ pr_universe_decl l let string_of_fqid fqid = String.concat "." (List.map Id.to_string fqid) @@ -275,7 +293,7 @@ open Decl_kinds ) ++ hov 0 ((if dep then keyword "Induction for" else keyword "Minimality for") ++ spc() ++ pr_smart_global ind) ++ spc() ++ - hov 0 (keyword "Sort" ++ spc() ++ pr_glob_sort s) + hov 0 (keyword "Sort" ++ spc() ++ Termops.pr_sort_family s) | CaseScheme (dep,ind,s) -> (match idop with | Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc() @@ -283,7 +301,7 @@ open Decl_kinds ) ++ hov 0 ((if dep then keyword "Elimination for" else keyword "Case for") ++ spc() ++ pr_smart_global ind) ++ spc() ++ - hov 0 (keyword "Sort" ++ spc() ++ pr_glob_sort s) + hov 0 (keyword "Sort" ++ spc() ++ Termops.pr_sort_family s) | EqualityScheme ind -> (match idop with | Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc() @@ -371,24 +389,19 @@ open Decl_kinds | l -> spc() ++ hov 1 (str"(" ++ prlist_with_sep sep_v2 pr_syntax_modifier l ++ str")") - let pr_univs pl = - match pl with - | None -> mt () - | Some pl -> str"@{" ++ prlist_with_sep spc pr_lident pl ++ str"}" - - let pr_rec_definition ((((loc,id),pl),ro,bl,type_,def),ntn) = + let pr_rec_definition ((iddecl,ro,bl,type_,def),ntn) = let pr_pure_lconstr c = Flags.without_option Flags.beautify pr_lconstr c in let annot = pr_guard_annot pr_lconstr_expr bl ro in - pr_id id ++ pr_univs pl ++ pr_binders_arg bl ++ annot + pr_ident_decl iddecl ++ pr_binders_arg bl ++ annot ++ pr_type_option (fun c -> spc() ++ pr_lconstr_expr c) type_ ++ pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_pure_lconstr def) def ++ prlist (pr_decl_notation pr_constr) ntn let pr_statement head (idpl,(bl,c)) = assert (not (Option.is_empty idpl)); - let id, pl = Option.get idpl in + let idpl = Option.get idpl in hov 2 - (head ++ spc() ++ pr_lident id ++ pr_univs pl ++ spc() ++ + (head ++ spc() ++ pr_ident_decl idpl ++ spc() ++ (match bl with [] -> mt() | _ -> pr_binders bl ++ spc()) ++ str":" ++ pr_spc_lconstr c) @@ -524,12 +537,6 @@ open Decl_kinds | VernacLocal (local, v) -> return (pr_locality local ++ spc() ++ pr_vernac_body v) - (* Stm *) - | VernacStm JoinDocument -> - return (keyword "Stm JoinDocument") - | VernacStm Wait -> - return (keyword "Stm Wait") - (* Proof management *) | VernacAbortAll -> return (keyword "Abort All") @@ -656,7 +663,7 @@ open Decl_kinds | None -> mt() | Some sc -> str" :" ++ spc() ++ str sc)) ) - | VernacSyntaxExtension (_,(s,l)) -> + | VernacSyntaxExtension (_, _,(s,l)) -> return ( keyword "Reserved Notation" ++ spc() ++ pr_located qs s ++ pr_syntax_modifiers l @@ -692,7 +699,7 @@ open Decl_kinds return ( hov 2 ( pr_def_token d ++ spc() - ++ pr_plident id ++ binds ++ typ + ++ pr_ident_decl id ++ binds ++ typ ++ (match c with | None -> mt() | Some cc -> str" :=" ++ spc() ++ cc)) @@ -711,10 +718,7 @@ open Decl_kinds match o with | None -> (match opac with | Transparent -> keyword "Defined" - | Opaque None -> keyword "Qed" - | Opaque (Some l) -> - keyword "Qed" ++ spc() ++ str"export" ++ - prlist_with_sep (fun () -> str", ") pr_lident l) + | Opaque -> keyword "Qed") | Some id -> (if opac <> Transparent then keyword "Save" else keyword "Defined") ++ spc() ++ pr_lident id ) | VernacExactProof c -> @@ -722,7 +726,7 @@ open Decl_kinds | VernacAssumption (stre,t,l) -> let n = List.length (List.flatten (List.map fst (List.map snd l))) in let pr_params (c, (xl, t)) = - hov 2 (prlist_with_sep sep pr_plident xl ++ spc() ++ + hov 2 (prlist_with_sep sep pr_ident_decl xl ++ spc() ++ (if c then str":>" else str":" ++ spc() ++ pr_lconstr_expr t)) in let assumptions = prlist_with_sep spc (fun p -> hov 1 (str "(" ++ pr_params p ++ str ")")) l in return (hov 2 (pr_assumption_token (n > 1) stre ++ @@ -743,10 +747,10 @@ open Decl_kinds | RecordDecl (c,fs) -> pr_record_decl b c fs in - let pr_oneind key (((coe,(id,pl)),indpar,s,k,lc),ntn) = + let pr_oneind key (((coe,iddecl),indpar,s,k,lc),ntn) = hov 0 ( str key ++ spc() ++ - (if coe then str"> " else str"") ++ pr_lident id ++ pr_univs pl ++ + (if coe then str"> " else str"") ++ pr_ident_decl iddecl ++ pr_and_type_binders_arg indpar ++ pr_opt (fun s -> str":" ++ spc() ++ pr_lconstr_expr s) s ++ str" :=") ++ pr_constructor_list k lc ++ @@ -791,8 +795,8 @@ open Decl_kinds | Some Local -> keyword "Local" ++ spc () | None | Some Global -> str "" in - let pr_onecorec ((((loc,id),pl),bl,c,def),ntn) = - pr_id id ++ pr_univs pl ++ spc() ++ pr_binders bl ++ spc() ++ str":" ++ + let pr_onecorec ((iddecl,bl,c,def),ntn) = + pr_ident_decl iddecl ++ spc() ++ pr_binders bl ++ spc() ++ str":" ++ spc() ++ pr_lconstr_expr c ++ pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_lconstr def) def ++ prlist (pr_decl_notation pr_constr) ntn @@ -818,10 +822,6 @@ open Decl_kinds prlist_with_sep (fun _ -> str",") pr_lident v) ) | VernacConstraint v -> - let pr_uconstraint (l, d, r) = - pr_glob_level l ++ spc () ++ Univ.pr_constraint_type d ++ spc () ++ - pr_glob_level r - in return ( hov 2 (keyword "Constraint" ++ spc () ++ prlist_with_sep (fun _ -> str",") pr_uconstraint v) @@ -875,7 +875,7 @@ open Decl_kinds (if abst then keyword "Declare" ++ spc () else mt ()) ++ keyword "Instance" ++ (match instid with - | (loc, Name id), l -> spc () ++ pr_plident ((loc, id),l) ++ spc () + | (loc, Name id), l -> spc () ++ pr_ident_decl ((loc, id),l) ++ spc () | (_, Anonymous), _ -> mt ()) ++ pr_and_type_binders_arg sup ++ str":" ++ spc () ++ diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 1937885587..23f96b5a32 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -239,7 +239,6 @@ let get_current_proof_name = Proof_global.get_current_proof_name let get_all_proof_names = Proof_global.get_all_proof_names type lemma_possible_guards = Proof_global.lemma_possible_guards -type universe_binders = Proof_global.universe_binders let delete_proof = Proof_global.discard let delete_current_proof = Proof_global.discard_current @@ -257,6 +256,5 @@ let set_used_variables l = let get_used_variables () = Proof_global.get_used_variables () -let get_universe_binders () = - Proof_global.get_universe_binders () - +let get_universe_decl () = + Proof_global.get_universe_decl () diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index 745ee8f367..6e4ecd13b3 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -23,7 +23,7 @@ open Decl_kinds proof of mutually dependent theorems) *) val start_proof : - Id.t -> ?pl:Proof_global.universe_binders -> goal_kind -> Evd.evar_map -> named_context_val -> EConstr.constr -> + Id.t -> ?pl:Univdecls.universe_decl -> goal_kind -> Evd.evar_map -> named_context_val -> EConstr.constr -> ?init_tac:unit Proofview.tactic -> Proof_global.proof_terminator -> unit @@ -67,6 +67,7 @@ val current_proof_statement : unit -> Id.t * goal_kind * EConstr.types (** {6 ... } *) + (** [solve (SelectNth n) tac] applies tactic [tac] to the [n]th subgoal of the current focused proof or raises a [UserError] if no proof is focused or if there is no [n]th subgoal. [solve SelectAll @@ -185,8 +186,8 @@ val get_used_variables : unit -> Context.Named.t option [@@ocaml.deprecated "use Proof_global.get_used_variables"] (** {6 Universe binders } *) -val get_universe_binders : unit -> Proof_global.universe_binders option -[@@ocaml.deprecated "use Proof_global.get_universe_binders"] +val get_universe_decl : unit -> Univdecls.universe_decl +[@@ocaml.deprecated "use Proof_global.get_universe_decl"] (** {6 ... } *) (** [get_current_proof_name ()] return the name of the current focused @@ -202,7 +203,3 @@ val get_all_proof_names : unit -> Id.t list type lemma_possible_guards = Proof_global.lemma_possible_guards [@@ocaml.deprecated "use Proof_global.lemma_possible_guards"] - -type universe_binders = Proof_global.universe_binders -[@@ocaml.deprecated "use Proof_global.universe_binders"] - diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 2ade797f63..cd4d1dcf64 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -69,7 +69,6 @@ let _ = (* Extra info on proofs. *) type lemma_possible_guards = int list list type proof_universes = Evd.evar_universe_context * Universes.universe_binders option -type universe_binders = Id.t Loc.located list type proof_object = { id : Names.Id.t; @@ -94,7 +93,7 @@ type pstate = { proof : Proof.proof; strength : Decl_kinds.goal_kind; mode : proof_mode CEphemeron.key; - universe_binders: universe_binders option; + universe_decl: Univdecls.universe_decl; } let make_terminator f = f @@ -230,15 +229,22 @@ let activate_proof_mode mode = let disactivate_current_proof_mode () = CEphemeron.iter_opt !current_proof_mode (fun x -> x.reset ()) -(** [start_proof sigma id str goals terminator] starts a proof of name +let default_universe_decl = + let open Misctypes in + { univdecl_instance = []; + univdecl_extensible_instance = true; + univdecl_constraints = Univ.Constraint.empty; + univdecl_extensible_constraints = true } + +(** [start_proof sigma id pl str goals terminator] starts a proof of name [id] with goals [goals] (a list of pairs of environment and conclusion); [str] describes what kind of theorem/definition this is (spiwack: for potential printing, I believe is used only by closing commands and the xml plugin); [terminator] is used at the end of the proof to close the proof. The proof is started in the evar map [sigma] (which can typically contain universe - constraints). *) -let start_proof sigma id ?pl str goals terminator = + constraints), and with universe bindings pl. *) +let start_proof sigma id ?(pl=default_universe_decl) str goals terminator = let initial_state = { pid = id; terminator = CEphemeron.create terminator; @@ -247,10 +253,10 @@ let start_proof sigma id ?pl str goals terminator = section_vars = None; strength = str; mode = find_proof_mode "No"; - universe_binders = pl } in + universe_decl = pl } in push initial_state pstates -let start_dependent_proof id ?pl str goals terminator = +let start_dependent_proof id ?(pl=default_universe_decl) str goals terminator = let initial_state = { pid = id; terminator = CEphemeron.create terminator; @@ -259,11 +265,11 @@ let start_dependent_proof id ?pl str goals terminator = section_vars = None; strength = str; mode = find_proof_mode "No"; - universe_binders = pl } in + universe_decl = pl } in push initial_state pstates let get_used_variables () = (cur_pstate ()).section_vars -let get_universe_binders () = (cur_pstate ()).universe_binders +let get_universe_decl () = (cur_pstate ()).universe_decl let proof_using_auto_clear = ref false let _ = Goptions.declare_bool_option @@ -312,20 +318,21 @@ let get_open_goals () = let constrain_variables init uctx = let levels = Univ.Instance.levels (Univ.UContext.instance init) in - let cstrs = UState.constrain_variables levels uctx in - Univ.ContextSet.add_constraints cstrs (UState.context_set uctx) + UState.constrain_variables levels uctx type closed_proof_output = (Term.constr * Safe_typing.private_constants) list * Evd.evar_universe_context let close_proof ~keep_body_ucst_separate ?feedback_id ~now (fpl : closed_proof_output Future.computation) = - let { pid; section_vars; strength; proof; terminator; universe_binders } = + let { pid; section_vars; strength; proof; terminator; universe_decl } = cur_pstate () in let poly = pi2 strength (* Polymorphic *) in let initial_goals = Proof.initial_goals proof in let initial_euctx = Proof.initial_euctx proof in let fpl, univs = Future.split2 fpl in let universes = if poly || now then Future.force univs else initial_euctx in + let binders, univctx = Evd.check_univ_decl (Evd.from_ctx universes) universe_decl in + let binders = if poly then Some binders else None in (* Because of dependent subgoals at the beginning of proofs, we could have existential variables in the initial types of goals, we need to normalise them for the kernel. *) @@ -349,53 +356,54 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now let initunivs = Evd.evar_context_universe_context initial_euctx in let ctx = constrain_variables initunivs universes in (* For vi2vo compilation proofs are computed now but we need to - * complement the univ constraints of the typ with the ones of - * the body. So we keep the two sets distinct. *) + complement the univ constraints of the typ with the ones of + the body. So we keep the two sets distinct. *) let used_univs = Univ.LSet.union used_univs_body used_univs_typ in - let ctx_body = Univops.restrict_universe_context ctx used_univs in - (initunivs, typ), ((body, ctx_body), eff) + let ctx_body = UState.restrict ctx used_univs in + let _, univs = Evd.check_univ_decl (Evd.from_ctx ctx_body) universe_decl in + (initunivs, typ), ((body, Univ.ContextSet.of_context univs), eff) else - let initunivs = Univ.UContext.empty in - let ctx = constrain_variables initunivs universes in (* Since the proof is computed now, we can simply have 1 set of - * constraints in which we merge the ones for the body and the ones - * for the typ *) + constraints in which we merge the ones for the body and the ones + for the typ. We recheck the declaration after restricting with + the actually used universes. + TODO: check if restrict is really necessary now. *) let used_univs = Univ.LSet.union used_univs_body used_univs_typ in - let ctx = Univops.restrict_universe_context ctx used_univs in - let univs = Univ.ContextSet.to_context ctx in + let ctx = UState.restrict universes used_univs in + let _, univs = Evd.check_univ_decl (Evd.from_ctx ctx) universe_decl in (univs, typ), ((body, Univ.ContextSet.empty), eff) in fun t p -> Future.split2 (Future.chain ~pure:true p (make_body t)) else fun t p -> - let initunivs = Evd.evar_context_universe_context initial_euctx in - Future.from_val (initunivs, nf t), + Future.from_val (univctx, nf t), Future.chain ~pure:true p (fun (pt,eff) -> - (pt,constrain_variables initunivs (Future.force univs)),eff) + (* Deferred proof, we already checked the universe declaration with + the initial universes, ensure that the final universes respect + the declaration as well. If the declaration is non-extensible, + this will prevent the body from adding universes and constraints. *) + let bodyunivs = constrain_variables univctx (Future.force univs) in + let _, univs = Evd.check_univ_decl (Evd.from_ctx bodyunivs) universe_decl in + (pt,Univ.ContextSet.of_context univs),eff) in - let entries = - Future.map2 (fun p (_, t) -> - let t = EConstr.Unsafe.to_constr t in - let univstyp, body = make_body t p in - let univs, typ = Future.force univstyp in - let univs = - if poly then Entries.Polymorphic_const_entry univs - else Entries.Monomorphic_const_entry univs - in - { Entries. - const_entry_body = body; - const_entry_secctx = section_vars; - const_entry_feedback = feedback_id; - const_entry_type = Some typ; - const_entry_inline_code = false; - const_entry_opaque = true; - const_entry_universes = univs; - }) - fpl initial_goals in - let binders = - Option.map (fun names -> fst (Evd.universe_context ~names (Evd.from_ctx universes))) - universe_binders + let entry_fn p (_, t) = + let t = EConstr.Unsafe.to_constr t in + let univstyp, body = make_body t p in + let univs, typ = Future.force univstyp in + let univs = + if poly then Entries.Polymorphic_const_entry univs + else Entries.Monomorphic_const_entry univs + in + {Entries. + const_entry_body = body; + const_entry_secctx = section_vars; + const_entry_feedback = feedback_id; + const_entry_type = Some typ; + const_entry_inline_code = false; + const_entry_opaque = true; + const_entry_universes = univs; } in + let entries = Future.map2 entry_fn fpl initial_goals in { id = pid; entries = entries; persistence = strength; universes = (universes, binders) }, fun pr_ending -> CEphemeron.get terminator pr_ending diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index 52f5f74046..8c0f6ad85f 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -34,7 +34,7 @@ val compact_the_proof : unit -> unit values. *) type lemma_possible_guards = int list list type proof_universes = Evd.evar_universe_context * Universes.universe_binders option -type universe_binders = Names.Id.t Loc.located list + type proof_object = { id : Names.Id.t; entries : Safe_typing.private_constants Entries.definition_entry list; @@ -54,21 +54,23 @@ type closed_proof = proof_object * proof_terminator val make_terminator : (proof_ending -> unit) -> proof_terminator val apply_terminator : proof_terminator -> proof_ending -> unit -(** [start_proof id str goals terminator] starts a proof of name [id] +(** [start_proof id str pl goals terminator] starts a proof of name [id] with goals [goals] (a list of pairs of environment and conclusion); [str] describes what kind of theorem/definition this is (spiwack: for potential printing, I believe is used only by closing commands and the xml plugin); [terminator] is used at the - end of the proof to close the proof. *) + end of the proof to close the proof. The proof is started in the + evar map [sigma] (which can typically contain universe + constraints), and with universe bindings pl. *) val start_proof : - Evd.evar_map -> Names.Id.t -> ?pl:universe_binders -> + Evd.evar_map -> Names.Id.t -> ?pl:Univdecls.universe_decl -> Decl_kinds.goal_kind -> (Environ.env * EConstr.types) list -> proof_terminator -> unit (** Like [start_proof] except that there may be dependencies between initial goals. *) val start_dependent_proof : - Names.Id.t -> ?pl:universe_binders -> Decl_kinds.goal_kind -> + Names.Id.t -> ?pl:Univdecls.universe_decl -> Decl_kinds.goal_kind -> Proofview.telescope -> proof_terminator -> unit (** Update the proofs global environment after a side-effecting command @@ -119,7 +121,8 @@ val set_used_variables : Names.Id.t list -> Context.Named.t * Names.Id.t Loc.located list val get_used_variables : unit -> Context.Named.t option -val get_universe_binders : unit -> universe_binders option +(** Get the universe declaration associated to the current proof. *) +val get_universe_decl : unit -> Univdecls.universe_decl module V82 : sig val get_current_initial_conclusions : unit -> Names.Id.t *(EConstr.types list * diff --git a/proofs/refine.ml b/proofs/refine.ml index 4161d71047..e3f6508481 100644 --- a/proofs/refine.ml +++ b/proofs/refine.ml @@ -102,7 +102,12 @@ let generic_refine ~typecheck f gl = in (** Proceed to the refinement *) let c = EConstr.Unsafe.to_constr c in - let sigma = match evkmain with + let sigma = match Proofview.Unsafe.advance sigma self with + | None -> + (** Nothing to do, the goal has been solved by side-effect *) + sigma + | Some self -> + match evkmain with | None -> Evd.define self c sigma | Some evk -> let id = Evd.evar_ident self sigma in diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index d89bf5d341..5d9b595d36 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -10,7 +10,7 @@ open CErrors open Pp open Util -let stm_pr_err pp = Format.eprintf "%s] @[%a@]%!\n" (System.process_id ()) Pp.pp_with pp +let stm_pr_err pp = Format.eprintf "%s] @[%a@]\n%!" (System.process_id ()) Pp.pp_with pp let stm_prerr_endline s = if !Flags.debug then begin stm_pr_err (str s) end else () diff --git a/stm/stm.ml b/stm/stm.ml index 3386044f26..75ec946f03 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -1049,7 +1049,7 @@ end = struct (* {{{ *) try match v with | VernacResetInitial -> - VtStm (VtBack Stateid.initial, true), VtNow + VtBack (true, Stateid.initial), VtNow | VernacResetName (_,name) -> let id = VCS.get_branch_pos (VCS.current_branch ()) in (try @@ -1057,20 +1057,20 @@ end = struct (* {{{ *) fold_until (fun b (id,_,label,_,_) -> if b then `Stop id else `Cont (List.mem name label)) false id in - VtStm (VtBack oid, true), VtNow + VtBack (true, oid), VtNow with Not_found -> - VtStm (VtBack id, true), VtNow) + VtBack (true, id), VtNow) | VernacBack n -> let id = VCS.get_branch_pos (VCS.current_branch ()) in let oid = fold_until (fun n (id,_,_,_,_) -> if Int.equal n 0 then `Stop id else `Cont (n-1)) n id in - VtStm (VtBack oid, true), VtNow + VtBack (true, oid), VtNow | VernacUndo n -> let id = VCS.get_branch_pos (VCS.current_branch ()) in let oid = fold_until (fun n (id,_,_,tactic,undo) -> let value = (if tactic then 1 else 0) - undo in if Int.equal n 0 then `Stop id else `Cont (n-value)) n id in - VtStm (VtBack oid, true), VtLater + VtBack (true, oid), VtLater | VernacUndoTo _ | VernacRestart as e -> let m = match e with VernacUndoTo m -> m | _ -> 0 in @@ -1087,16 +1087,16 @@ end = struct (* {{{ *) 0 id in let oid = fold_until (fun n (id,_,_,_,_) -> if Int.equal n 0 then `Stop id else `Cont (n-1)) (n-m-1) id in - VtStm (VtBack oid, true), VtLater + VtBack (true, oid), VtLater | VernacAbortAll -> let id = VCS.get_branch_pos (VCS.current_branch ()) in let oid = fold_until (fun () (id,vcs,_,_,_) -> match Vcs_.branches vcs with [_] -> `Stop id | _ -> `Cont ()) () id in - VtStm (VtBack oid, true), VtLater + VtBack (true, oid), VtLater | VernacBacktrack (id,_,_) | VernacBackTo id -> - VtStm (VtBack (Stateid.of_int id), not !Flags.batch_mode), VtNow + VtBack (not !Flags.batch_mode, Stateid.of_int id), VtNow | _ -> VtUnknown, VtNow with | Not_found -> @@ -1385,7 +1385,7 @@ end = struct (* {{{ *) stm_vernac_interp stop ~proof:(pobject, terminator) { verbose = false; loc; indentation = 0; strlen = 0; - expr = (VernacEndProof (Proved (Opaque None,None))) }) in + expr = (VernacEndProof (Proved (Opaque,None))) }) in ignore(Future.join checked_proof); end; RespBuiltProof(proof,time) @@ -1525,7 +1525,7 @@ end = struct (* {{{ *) Reach.known_state ~cache:`No start; stm_vernac_interp stop ~proof { verbose = false; loc; indentation = 0; strlen = 0; - expr = (VernacEndProof (Proved (Opaque None,None))) }; + expr = (VernacEndProof (Proved (Opaque,None))) }; `OK proof end with e -> @@ -1976,7 +1976,6 @@ let collect_proof keep cur hd brkind id = | id :: _ -> Names.Id.to_string id in let loc = (snd cur).loc in let rec is_defined_expr = function - | VernacEndProof (Proved ((Transparent|Opaque (Some _)),_)) -> true | VernacTime (_, e) -> is_defined_expr e | VernacRedirect (_, (_, e)) -> is_defined_expr e | VernacTimeout (_, e) -> is_defined_expr e @@ -2373,6 +2372,7 @@ let finish () = | _ -> () let wait () = + finish (); Slaves.wait_all_done (); VCS.print () @@ -2386,7 +2386,6 @@ let rec join_admitted_proofs id = | _ -> join_admitted_proofs view.next let join () = - finish (); wait (); stm_prerr_endline (fun () -> "Joining the environment"); Global.join_safe_environment (); @@ -2484,14 +2483,8 @@ let process_transaction ?(newtip=Stateid.fresh ()) stm_prerr_endline (fun () -> " classified as: " ^ string_of_vernac_classification c); match c with - (* Joining various parts of the document *) - | VtStm (VtJoinDocument, b), VtNow -> join (); `Ok - | VtStm (VtWait, b), VtNow -> finish (); wait (); `Ok - | VtStm ((VtJoinDocument|VtWait),_), VtLater -> - anomaly(str"classifier: join actions cannot be classified as VtLater.") - (* Back *) - | VtStm (VtBack oid, true), w -> + | VtBack (true, oid), w -> let id = VCS.new_node ~id:newtip () in let { mine; others } = Backtrack.branches_of oid in let valid = VCS.get_branch_pos head in @@ -2510,12 +2503,12 @@ let process_transaction ?(newtip=Stateid.fresh ()) VCS.checkout_shallowest_proof_branch (); VCS.commit id (Alias (oid,x)); Backtrack.record (); if w == VtNow then finish (); `Ok - | VtStm (VtBack id, false), VtNow -> + | VtBack (false, id), VtNow -> stm_prerr_endline (fun () -> "undo to state " ^ Stateid.to_string id); Backtrack.backto id; VCS.checkout_shallowest_proof_branch (); Reach.known_state ~cache:(interactive ()) id; `Ok - | VtStm (VtBack id, false), VtLater -> + | VtBack (false, id), VtLater -> anomaly(str"classifier: VtBack + VtLater must imply part_of_script.") (* Query *) @@ -2779,8 +2772,8 @@ let query ~at ~route s = let clas = classify_vernac ast in let aast = { verbose = true; indentation; strlen; loc; expr = ast } in match clas with - | VtStm (w,_), _ -> - ignore(process_transaction aast (VtStm (w,false), VtNow)) + | VtBack (_,id), _ -> (* TODO: can this still happen ? *) + ignore(process_transaction aast (VtBack (false,id), VtNow)) | _ -> ignore(process_transaction aast (VtQuery (false, route), VtNow))) s diff --git a/stm/stm.mli b/stm/stm.mli index 188b176bab..3f01fca013 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -51,6 +51,9 @@ val edit_at : Stateid.t -> [ `NewTip | `Focus of focus ] (* Evaluates the tip of the current branch *) val finish : unit -> unit +(* Internal use (fake_ide) only, do not use *) +val wait : unit -> unit + val observe : Stateid.t -> unit val stop_worker : string -> unit diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index c2ebea961f..158ad90846 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -31,8 +31,7 @@ let string_of_vernac_type = function Option.default "" proof_block_detection | VtProofMode s -> "ProofMode " ^ s | VtQuery (b, route) -> "Query " ^ string_of_in_script b ^ " route " ^ string_of_int route - | VtStm ((VtJoinDocument|VtWait), b) -> "Stm " ^ string_of_in_script b - | VtStm (VtBack _, b) -> "Stm Back " ^ string_of_in_script b + | VtBack (b, _) -> "Stm Back " ^ string_of_in_script b let string_of_vernac_when = function | VtLater -> "Later" @@ -64,9 +63,6 @@ let rec classify_vernac e = * look at the entire dag to detect this option. *) | VernacSetOption (["Universe"; "Polymorphism"],_) | VernacUnsetOption (["Universe"; "Polymorphism"]) -> VtSideff [], VtNow - (* Stm *) - | VernacStm Wait -> VtStm (VtWait, true), VtNow - | VernacStm JoinDocument -> VtStm (VtJoinDocument, true), VtNow (* Nested vernac exprs *) | VernacProgram e -> classify_vernac e | VernacLocal (_,e) -> classify_vernac e @@ -79,7 +75,7 @@ let rec classify_vernac e = | VernacFail e -> (* Fail Qed or Fail Lemma must not join/fork the DAG *) (match classify_vernac e with | ( VtQuery _ | VtProofStep _ | VtSideff _ - | VtStm _ | VtProofMode _ ), _ as x -> x + | VtBack _ | VtProofMode _ ), _ as x -> x | VtQed _, _ -> VtProofStep { parallel = `No; proof_block_detection = None }, VtNow diff --git a/tactics/hints.ml b/tactics/hints.ml index a572508d47..3ccbab874f 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -56,7 +56,9 @@ let head_constr_bound sigma t = | _ -> raise Bound let head_constr sigma c = - try head_constr_bound sigma c with Bound -> user_err Pp.(str "Bound head variable.") + try head_constr_bound sigma c + with Bound -> user_err (Pp.str "Head identifier must be a constant, section variable, \ + (co)inductive type, (co)inductive type constructor, or projection.") let decompose_app_bound sigma t = let t = strip_outer_cast sigma t in @@ -764,7 +766,9 @@ let rec nb_hyp sigma c = match EConstr.kind sigma c with let try_head_pattern c = try head_pattern_bound c - with BoundPattern -> user_err Pp.(str "Bound head variable.") + with BoundPattern -> + user_err (Pp.str "Head pattern or sub-pattern must be a global constant, a section variable, \ + an if, case, or let expression, an application, or a projection.") let with_uid c = { obj = c; uid = fresh_key () } diff --git a/tactics/leminv.ml b/tactics/leminv.ml index aeb80ae57c..7c488f524f 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -232,7 +232,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = let invProof = it_mkNamedLambda_or_LetIn c !ownSign in let invProof = EConstr.Unsafe.to_constr invProof in let p = Evarutil.nf_evars_universes sigma invProof in - p, Evd.universe_context sigma + p, Evd.universe_context ~names:[] ~extensible:true sigma let add_inversion_lemma name env sigma t sort dep inv_op = let invProof, ctx = inversion_scheme env sigma t sort dep inv_op in @@ -248,9 +248,9 @@ 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 sigma, sort = Pretyping.interp_sort !evd comsort in + let evd, sort = Evd.fresh_sort_in_family ~rigid:univ_rigid env !evd comsort in try - add_inversion_lemma na env sigma c sort bool tac + add_inversion_lemma na env evd 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/tactics/leminv.mli b/tactics/leminv.mli index 41b0e09b42..8745ad3979 100644 --- a/tactics/leminv.mli +++ b/tactics/leminv.mli @@ -15,5 +15,5 @@ val lemInv_clause : quantified_hypothesis -> constr -> Id.t list -> unit Proofview.tactic val add_inversion_lemma_exn : - Id.t -> constr_expr -> glob_sort -> bool -> (Id.t -> unit Proofview.tactic) -> + Id.t -> constr_expr -> Sorts.family -> bool -> (Id.t -> unit Proofview.tactic) -> unit diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 67bc55d3fe..f1dd61358c 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -74,7 +74,7 @@ let _ = let _ = declare_bool_option - { optdepr = false; + { optdepr = true; (* remove in 8.8 *) optname = "trigger bugged context matching compatibility"; optkey = ["Tactic";"Compat";"Context"]; optread = (fun () -> !Flags.tactic_context_compat) ; @@ -2219,27 +2219,27 @@ let check_number_of_constructors expctdnumopt i nconstr = end; if i > nconstr then error "Not enough constructors." -let constructor_tac with_evars expctdnumopt i lbind = +let constructor_core with_evars cstr lbind = Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in + let env = Proofview.Goal.env gl in + let (sigma, (cons, u)) = Evd.fresh_constructor_instance env sigma cstr in + let cons = mkConstructU (cons, EInstance.make u) in + let apply_tac = general_apply true false with_evars None (Loc.tag (cons,lbind)) in + Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) apply_tac + end + +let constructor_tac with_evars expctdnumopt i lbind = + Proofview.Goal.enter begin fun gl -> let cl = Tacmach.New.pf_concl gl in - let reduce_to_quantified_ind = - Tacmach.New.pf_apply Tacred.reduce_to_quantified_ind gl - in - let (mind,redcl) = reduce_to_quantified_ind cl in - let nconstr = - Array.length (snd (Global.lookup_inductive (fst mind))).mind_consnames in - check_number_of_constructors expctdnumopt i nconstr; - - let (sigma, (cons, u)) = Evd.fresh_constructor_instance - (Proofview.Goal.env gl) sigma (fst mind, i) in - let cons = mkConstructU (cons, EInstance.make u) in - - let apply_tac = general_apply true false with_evars None (Loc.tag (cons,lbind)) in - Tacticals.New.tclTHENLIST - [ Proofview.Unsafe.tclEVARS sigma; - convert_concl_no_check redcl DEFAULTcast; - intros; apply_tac] + let ((ind,_),redcl) = Tacmach.New.pf_apply Tacred.reduce_to_quantified_ind gl cl in + let nconstr = Array.length (snd (Global.lookup_inductive ind)).mind_consnames in + check_number_of_constructors expctdnumopt i nconstr; + Tacticals.New.tclTHENLIST [ + convert_concl_no_check redcl DEFAULTcast; + intros; + constructor_core with_evars (ind, i) lbind + ] end let one_constructor i lbind = constructor_tac false None i lbind @@ -2249,24 +2249,26 @@ let one_constructor i lbind = constructor_tac false None i lbind Should be generalize in Constructor (Fun c : I -> tactic) *) -let rec tclANY tac = function -| [] -> Tacticals.New.tclZEROMSG (str "No applicable tactic.") -| arg :: l -> - Tacticals.New.tclORD (tac arg) (fun () -> tclANY tac l) - let any_constructor with_evars tacopt = - let t = match tacopt with None -> Proofview.tclUNIT () | Some t -> t in - let tac i = Tacticals.New.tclTHEN (constructor_tac with_evars None i NoBindings) t in + let one_constr = + let tac cstr = constructor_core with_evars cstr NoBindings in + match tacopt with + | None -> tac + | Some t -> fun cstr -> Tacticals.New.tclTHEN (tac cstr) t in + let rec any_constr ind n i () = + if Int.equal i n then one_constr (ind,i) + else Tacticals.New.tclORD (one_constr (ind,i)) (any_constr ind n (i + 1)) in Proofview.Goal.enter begin fun gl -> let cl = Tacmach.New.pf_concl gl in - let reduce_to_quantified_ind = - Tacmach.New.pf_apply Tacred.reduce_to_quantified_ind gl - in - let mind = fst (reduce_to_quantified_ind cl) in + let (ind,_),redcl = Tacmach.New.pf_apply Tacred.reduce_to_quantified_ind gl cl in let nconstr = - Array.length (snd (Global.lookup_inductive (fst mind))).mind_consnames in + Array.length (snd (Global.lookup_inductive ind)).mind_consnames in if Int.equal nconstr 0 then error "The type has no constructors."; - tclANY tac (List.interval 1 nconstr) + Tacticals.New.tclTHENLIST [ + convert_concl_no_check redcl DEFAULTcast; + intros; + any_constr ind nconstr 1 () + ] end let left_with_bindings with_evars = constructor_tac with_evars (Some 2) 1 @@ -4131,7 +4133,7 @@ let guess_elim isrec dep s hyp0 gl = let env = Tacmach.New.pf_env gl in let sigma = Tacmach.New.project gl in let u = EInstance.kind (Tacmach.New.project gl) u in - if use_dependent_propositions_elimination () && dep + if use_dependent_propositions_elimination () && dep = Some true then let (sigma, ind) = build_case_analysis_scheme env sigma (mind, u) true s in let ind = EConstr.of_constr ind in @@ -4165,7 +4167,7 @@ let find_induction_type isrec elim hyp0 gl = | None -> let sort = Tacticals.New.elimination_sort_of_goal gl in let _, (elimc,elimt),_ = - guess_elim isrec (* dummy: *) true sort hyp0 gl in + guess_elim isrec None sort hyp0 gl in let scheme = compute_elim_sig sigma ~elimc elimt in (* We drop the scheme waiting to know if it is dependent *) scheme, ElimOver (isrec,hyp0) @@ -4199,7 +4201,7 @@ let get_eliminator elim dep s gl = | ElimUsing (elim,indsign) -> Tacmach.New.project gl, (* bugged, should be computed *) true, elim, indsign | ElimOver (isrec,id) -> - let evd, (elimc,elimt),_ as elims = guess_elim isrec dep s id gl in + let evd, (elimc,elimt),_ as elims = guess_elim isrec (Some dep) s id gl in let _, (l, s) = compute_elim_signature elims id in let branchlengthes = List.map (fun d -> assert (RelDecl.is_local_assum d); pi1 (decompose_prod_letin (Tacmach.New.project gl) (RelDecl.get_type d))) (List.rev s.branches) diff --git a/test-suite/bugs/4623.v b/test-suite/bugs/4623.v index 405d09809c..7ecfd98b67 100644 --- a/test-suite/bugs/4623.v +++ b/test-suite/bugs/4623.v @@ -2,4 +2,4 @@ Goal Type -> Type. set (T := Type). clearbody T. refine (@id _). -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/4624.v b/test-suite/bugs/4624.v index a737afcdab..f5ce981cd0 100644 --- a/test-suite/bugs/4624.v +++ b/test-suite/bugs/4624.v @@ -4,4 +4,4 @@ Canonical Structure fooA (T : Type) := mkfoo (T -> T). Definition id (t : foo) (x : type t) := x. -Definition bar := id _ ((fun x : nat => x) : _).
\ No newline at end of file +Definition bar := id _ ((fun x : nat => x) : _). diff --git a/test-suite/bugs/closed/1425.v b/test-suite/bugs/closed/1425.v index 6be30174ae..775d278e74 100644 --- a/test-suite/bugs/closed/1425.v +++ b/test-suite/bugs/closed/1425.v @@ -16,4 +16,4 @@ Goal forall n : nat, recursion nat 0 (fun _ _ => 1) (S n) = 1. intro n. setoid_rewrite recursion_S. reflexivity. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/1738.v b/test-suite/bugs/closed/1738.v index c2926a2b25..ef52c876c1 100644 --- a/test-suite/bugs/closed/1738.v +++ b/test-suite/bugs/closed/1738.v @@ -27,4 +27,4 @@ Module Test (Import M:FSetInterface.S). rewrite H in H0. assumption. Qed. -End Test.
\ No newline at end of file +End Test. diff --git a/test-suite/bugs/closed/1900.v b/test-suite/bugs/closed/1900.v index cf03efda42..6eea5db083 100644 --- a/test-suite/bugs/closed/1900.v +++ b/test-suite/bugs/closed/1900.v @@ -5,4 +5,4 @@ Definition eq_A := @eq A. Goal forall x, eq_A x x. intros. reflexivity. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/1901.v b/test-suite/bugs/closed/1901.v index 7d86adbfb2..98e017f9d6 100644 --- a/test-suite/bugs/closed/1901.v +++ b/test-suite/bugs/closed/1901.v @@ -8,4 +8,4 @@ Record Poset{A:Type}(Le : relation A) : Type := Le_antisym : forall x y : A, Le x y -> Le y x -> x = y }. Definition nat_Poset : Poset Peano.le. -Admitted.
\ No newline at end of file +Admitted. diff --git a/test-suite/bugs/closed/1905.v b/test-suite/bugs/closed/1905.v index 8c81d7510b..3b8a3d2f68 100644 --- a/test-suite/bugs/closed/1905.v +++ b/test-suite/bugs/closed/1905.v @@ -10,4 +10,4 @@ Goal forall a s, Proof. intros a s Ia. rewrite InE in Ia. -Admitted.
\ No newline at end of file +Admitted. diff --git a/test-suite/bugs/closed/1915.v b/test-suite/bugs/closed/1915.v index 7e62437d7b..2b0aed8c7d 100644 --- a/test-suite/bugs/closed/1915.v +++ b/test-suite/bugs/closed/1915.v @@ -3,4 +3,4 @@ Require Import Setoid. Fail Goal forall x, impl True (x = 0) -> x = 0 -> False. (*intros x H E. -rewrite H in E.*)
\ No newline at end of file +rewrite H in E.*) diff --git a/test-suite/bugs/closed/1939.v b/test-suite/bugs/closed/1939.v index 5e61529b4b..7b430ace5e 100644 --- a/test-suite/bugs/closed/1939.v +++ b/test-suite/bugs/closed/1939.v @@ -16,4 +16,4 @@ Require Import Setoid Program.Basics. intros x y H1 H2. rewrite H1. auto. - Qed.
\ No newline at end of file + Qed. diff --git a/test-suite/bugs/closed/1962.v b/test-suite/bugs/closed/1962.v index a6b0fee584..37b0dde06d 100644 --- a/test-suite/bugs/closed/1962.v +++ b/test-suite/bugs/closed/1962.v @@ -52,4 +52,4 @@ unfold triple, couple. Time fsetdec. Qed. -End BuildFSets.
\ No newline at end of file +End BuildFSets. diff --git a/test-suite/bugs/closed/2027.v b/test-suite/bugs/closed/2027.v index fb53c6ef43..ebc2bc070c 100644 --- a/test-suite/bugs/closed/2027.v +++ b/test-suite/bugs/closed/2027.v @@ -8,4 +8,4 @@ Goal forall A (p : T A), P p. Proof. intros. rewrite <- f_id. -Admitted.
\ No newline at end of file +Admitted. diff --git a/test-suite/bugs/closed/2136.v b/test-suite/bugs/closed/2136.v index d2b926f379..2fcfbe40dc 100644 --- a/test-suite/bugs/closed/2136.v +++ b/test-suite/bugs/closed/2136.v @@ -58,4 +58,4 @@ fsetdec. (* Error: Tactic failure: because the goal is beyond the scope of this tactic. *) -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/2137.v b/test-suite/bugs/closed/2137.v index 6c2023ab7b..b1f54b1766 100644 --- a/test-suite/bugs/closed/2137.v +++ b/test-suite/bugs/closed/2137.v @@ -49,4 +49,4 @@ fsetdec. (* Error: Tactic failure: because the goal is beyond the scope of this tactic. *) -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/2141.v b/test-suite/bugs/closed/2141.v index c556ff0b2b..22e33c8e81 100644 --- a/test-suite/bugs/closed/2141.v +++ b/test-suite/bugs/closed/2141.v @@ -13,4 +13,4 @@ Module NatSet' := FSetHide NatSet. Recursive Extraction NatSet'.fold. Extraction TestCompile NatSet'.fold. -(* Extraction "test2141.ml" NatSet'.fold. *)
\ No newline at end of file +(* Extraction "test2141.ml" NatSet'.fold. *) diff --git a/test-suite/bugs/closed/2281.v b/test-suite/bugs/closed/2281.v index 40948d9059..8f549b9201 100644 --- a/test-suite/bugs/closed/2281.v +++ b/test-suite/bugs/closed/2281.v @@ -47,4 +47,4 @@ intros. fsetdec. (* Error: Tactic failure: because the goal is beyond the scope of this tactic. *) -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/2310.v b/test-suite/bugs/closed/2310.v index 7fae328715..14a3e5a7b0 100644 --- a/test-suite/bugs/closed/2310.v +++ b/test-suite/bugs/closed/2310.v @@ -18,4 +18,4 @@ Definition replace a (y:Nest (prod a a)) : a = a -> Nest a. Unset Solve Unification Constraints. (* Keep the unification constraint around *) refine (Cons (cast H _ y)). intros. - refine (Nest (prod X X)). Qed.
\ No newline at end of file + refine (Nest (prod X X)). Qed. diff --git a/test-suite/bugs/closed/2319.v b/test-suite/bugs/closed/2319.v index e06fb97590..73d95e91a1 100644 --- a/test-suite/bugs/closed/2319.v +++ b/test-suite/bugs/closed/2319.v @@ -10,4 +10,4 @@ Section S. with t : A unit := mkA unit (mkA unit t). Timeout 5 Eval vm_compute in s. -End S.
\ No newline at end of file +End S. diff --git a/test-suite/bugs/closed/2464.v b/test-suite/bugs/closed/2464.v index af70858720..b9db30359c 100644 --- a/test-suite/bugs/closed/2464.v +++ b/test-suite/bugs/closed/2464.v @@ -36,4 +36,4 @@ Lemma foo : forall (pu_type : Type) NameSetMod.Equal ns2 (NameSetMod.add (pu_nameOf p) ns). Proof. NameSetDec.fsetdec. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/2473.v b/test-suite/bugs/closed/2473.v index fb676c7e47..0e7c0c25fa 100644 --- a/test-suite/bugs/closed/2473.v +++ b/test-suite/bugs/closed/2473.v @@ -37,4 +37,4 @@ Section S3. rewrite <- H. (* ok *) admit. Qed. -End S3.
\ No newline at end of file +End S3. diff --git a/test-suite/bugs/closed/2584.v b/test-suite/bugs/closed/2584.v index a5f4ae64a0..ef2e4e3555 100644 --- a/test-suite/bugs/closed/2584.v +++ b/test-suite/bugs/closed/2584.v @@ -86,4 +86,4 @@ should be "Prop" or "Set". Elimination of an inductive object of sort Set is not allowed on a predicate in sort Type because strong elimination on non-small inductive types leads to paradoxes. -*)
\ No newline at end of file +*) diff --git a/test-suite/bugs/closed/2586.v b/test-suite/bugs/closed/2586.v index 7e02e7f110..e57bcc25bb 100644 --- a/test-suite/bugs/closed/2586.v +++ b/test-suite/bugs/closed/2586.v @@ -3,4 +3,4 @@ Require Import Setoid SetoidClass Program. Goal forall `(Setoid nat) x y, x == y -> S x == S y. intros. Fail clsubst H0. - Abort.
\ No newline at end of file + Abort. diff --git a/test-suite/bugs/closed/2602.v b/test-suite/bugs/closed/2602.v index f074478868..29c8ac16b2 100644 --- a/test-suite/bugs/closed/2602.v +++ b/test-suite/bugs/closed/2602.v @@ -5,4 +5,4 @@ match goal with match goal with | |- S a > 0 => idtac end -end.
\ No newline at end of file +end. diff --git a/test-suite/bugs/closed/2615.v b/test-suite/bugs/closed/2615.v index 38c1cfc848..26c0f334d0 100644 --- a/test-suite/bugs/closed/2615.v +++ b/test-suite/bugs/closed/2615.v @@ -14,4 +14,4 @@ refine (fun p => match p with _ => _ end). Undo. refine (fun p => match p with foo_intro _ _ => _ end). admit. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/2668.v b/test-suite/bugs/closed/2668.v index 74c8fa347b..d5bbfd3f08 100644 --- a/test-suite/bugs/closed/2668.v +++ b/test-suite/bugs/closed/2668.v @@ -3,4 +3,4 @@ Require Import MSetProperties. Module Pos := MSetPositive.PositiveSet. Module PPPP := MSetProperties.WPropertiesOn(Pos). -Print Module PPPP.
\ No newline at end of file +Print Module PPPP. diff --git a/test-suite/bugs/closed/2734.v b/test-suite/bugs/closed/2734.v index 826361be2b..3210214ea1 100644 --- a/test-suite/bugs/closed/2734.v +++ b/test-suite/bugs/closed/2734.v @@ -12,4 +12,4 @@ Inductive control := Go: expr -> control. Definition program := (Adr.t * (control))%type. -Fail Definition myprog : program := (Adr.nat2t 0, Go (Adr.nat2t 0) ).
\ No newline at end of file +Fail Definition myprog : program := (Adr.nat2t 0, Go (Adr.nat2t 0) ). diff --git a/test-suite/bugs/closed/2750.v b/test-suite/bugs/closed/2750.v index fc580f1018..9d65e51f63 100644 --- a/test-suite/bugs/closed/2750.v +++ b/test-suite/bugs/closed/2750.v @@ -20,4 +20,4 @@ Module Test_ModWithRecord (M : ModWithRecord). {| M.A := 0 ; M.B := 2 |}. -End Test_ModWithRecord.
\ No newline at end of file +End Test_ModWithRecord. diff --git a/test-suite/bugs/closed/2837.v b/test-suite/bugs/closed/2837.v index 5d98446395..52a56c2cff 100644 --- a/test-suite/bugs/closed/2837.v +++ b/test-suite/bugs/closed/2837.v @@ -12,4 +12,4 @@ Fail rewrite test. Fail (intros; rewrite test). (* III) a working variant: *) -intros; rewrite (test n m).
\ No newline at end of file +intros; rewrite (test n m). diff --git a/test-suite/bugs/closed/2848.v b/test-suite/bugs/closed/2848.v index 828e3b8c1f..e234630332 100644 --- a/test-suite/bugs/closed/2848.v +++ b/test-suite/bugs/closed/2848.v @@ -7,4 +7,4 @@ Add Parametric Relation : _ equiv' reflexivity proved by (Equivalence.equiv_reflexive cheat) transitivity proved by (Equivalence.equiv_transitive cheat) as apply_equiv'_rel. -Check apply_equiv'_rel : PreOrder equiv'.
\ No newline at end of file +Check apply_equiv'_rel : PreOrder equiv'. diff --git a/test-suite/bugs/closed/2955.v b/test-suite/bugs/closed/2955.v index 45e24b5f5c..11fd7bada7 100644 --- a/test-suite/bugs/closed/2955.v +++ b/test-suite/bugs/closed/2955.v @@ -49,4 +49,4 @@ Module E. assumption. Qed. -End E.
\ No newline at end of file +End E. diff --git a/test-suite/bugs/closed/2983.v b/test-suite/bugs/closed/2983.v index 15598352b1..ad76350949 100644 --- a/test-suite/bugs/closed/2983.v +++ b/test-suite/bugs/closed/2983.v @@ -5,4 +5,4 @@ End ModB. Module Foo(A : ModA)(B : ModB A). End Foo. -Print Module Foo.
\ No newline at end of file +Print Module Foo. diff --git a/test-suite/bugs/closed/2995.v b/test-suite/bugs/closed/2995.v index ba3acd088d..b6c5b6df44 100644 --- a/test-suite/bugs/closed/2995.v +++ b/test-suite/bugs/closed/2995.v @@ -6,4 +6,4 @@ Module Implementation <: Interface. Definition t := bool. Definition error: t := false. Fail End Implementation. -(* A UserError here is expected, not an uncaught Not_found *)
\ No newline at end of file +(* A UserError here is expected, not an uncaught Not_found *) diff --git a/test-suite/bugs/closed/3008.v b/test-suite/bugs/closed/3008.v index 3f3a979a35..1979eda820 100644 --- a/test-suite/bugs/closed/3008.v +++ b/test-suite/bugs/closed/3008.v @@ -26,4 +26,4 @@ Fail Module Toto (* NB : the Inductive above and the A=A weren't in the initial test, they are here only to force an access to the environment - (cf [Printer.qualid_of_global]) and check that this env is ok. *)
\ No newline at end of file + (cf [Printer.qualid_of_global]) and check that this env is ok. *) diff --git a/test-suite/bugs/closed/3319.v b/test-suite/bugs/closed/3319.v index 3b37e39e52..fbf5d86dcb 100644 --- a/test-suite/bugs/closed/3319.v +++ b/test-suite/bugs/closed/3319.v @@ -23,4 +23,4 @@ Section precategory. = morphism' xa yb. Proof. admit. - Defined.
\ No newline at end of file + Defined. diff --git a/test-suite/bugs/closed/3331.v b/test-suite/bugs/closed/3331.v index 9cd44bd0ca..b7dbb290e1 100644 --- a/test-suite/bugs/closed/3331.v +++ b/test-suite/bugs/closed/3331.v @@ -28,4 +28,4 @@ Section groupoid_category. clear H' foo. Set Typeclasses Debug. pose (_ : Contr (idpath = idpath :> (@paths (@paths X d d) idpath idpath))). -Abort.
\ No newline at end of file +Abort. diff --git a/test-suite/bugs/closed/3352.v b/test-suite/bugs/closed/3352.v index 555accfd51..bf2f7a9d19 100644 --- a/test-suite/bugs/closed/3352.v +++ b/test-suite/bugs/closed/3352.v @@ -32,4 +32,4 @@ simpl. Set Printing Universes. exact hprop_Empty. Defined. -End B.
\ No newline at end of file +End B. diff --git a/test-suite/bugs/closed/3387.v b/test-suite/bugs/closed/3387.v index cb435e7865..1d9e783374 100644 --- a/test-suite/bugs/closed/3387.v +++ b/test-suite/bugs/closed/3387.v @@ -19,4 +19,4 @@ Proof. first [ unify x y | fail 2 "no unify" ]; change x with y at -1. (* Error: Not convertible. *) reflexivity. -Defined.
\ No newline at end of file +Defined. diff --git a/test-suite/bugs/closed/3392.v b/test-suite/bugs/closed/3392.v index 3a59869546..a03db77544 100644 --- a/test-suite/bugs/closed/3392.v +++ b/test-suite/bugs/closed/3392.v @@ -37,4 +37,4 @@ Proof. rewrite eissect; apply apD ). -Defined.
\ No newline at end of file +Defined. diff --git a/test-suite/bugs/closed/3402.v b/test-suite/bugs/closed/3402.v index ed47ec8255..b4705780db 100644 --- a/test-suite/bugs/closed/3402.v +++ b/test-suite/bugs/closed/3402.v @@ -4,4 +4,4 @@ Goal forall A B (p : prod A B), p = let (x, y) := p in pair A B x y. Proof. intros A B p. exact eq_refl. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/3428.v b/test-suite/bugs/closed/3428.v index 3eb75e43ac..16ace90af3 100644 --- a/test-suite/bugs/closed/3428.v +++ b/test-suite/bugs/closed/3428.v @@ -32,4 +32,4 @@ z' : prod A B p : @paths A (foo.fst ?11 ?14 z) (foo.fst ?26 ?29 z') q : @paths ?54 (foo.snd ?42 ?45 z) (foo.snd ?57 ?60 z') The term "p" has type "@paths A (foo.fst ?11 ?14 z) (foo.fst ?26 ?29 z')" -while it is expected to have type "@paths A (foo.fst z) (foo.fst z')". *)
\ No newline at end of file +while it is expected to have type "@paths A (foo.fst z) (foo.fst z')". *) diff --git a/test-suite/bugs/closed/3439.v b/test-suite/bugs/closed/3439.v index 1ea24bf1b8..e8c2d8b8ca 100644 --- a/test-suite/bugs/closed/3439.v +++ b/test-suite/bugs/closed/3439.v @@ -41,4 +41,4 @@ Module prim. Undo. solve [ typeclasses eauto ]. (* Error: No applicable tactic. *) Defined. -End prim.
\ No newline at end of file +End prim. diff --git a/test-suite/bugs/closed/3441.v b/test-suite/bugs/closed/3441.v index 50d2978077..ddfb339443 100644 --- a/test-suite/bugs/closed/3441.v +++ b/test-suite/bugs/closed/3441.v @@ -20,4 +20,4 @@ Timeout 1 let H := fresh "H" in Timeout 1 Time let H := fresh "H" in let x := constr:(let n := 17 in do_n n = do_n n) in let y := (eval lazy in x) in - assert (H := y). (* Finished transaction in 1.19 secs (1.164u,0.024s) (successful) *)
\ No newline at end of file + assert (H := y). (* Finished transaction in 1.19 secs (1.164u,0.024s) (successful) *) diff --git a/test-suite/bugs/closed/3446.v b/test-suite/bugs/closed/3446.v index dce73e1a50..8a0c98c333 100644 --- a/test-suite/bugs/closed/3446.v +++ b/test-suite/bugs/closed/3446.v @@ -48,4 +48,4 @@ Instance isequiv_pr1_contr {A} {P : A -> Type} : IsEquiv (@pr1 A P) | 100. Admitted. Definition path_sigma_hprop {A : Type} {P : A -> Type} (u v : sigT P) : u.1 = v.1 -> u = v := - path_sigma_uncurried P u v o pr1^-1.
\ No newline at end of file + path_sigma_uncurried P u v o pr1^-1. diff --git a/test-suite/bugs/closed/3477.v b/test-suite/bugs/closed/3477.v index e941486472..3ed63604ea 100644 --- a/test-suite/bugs/closed/3477.v +++ b/test-suite/bugs/closed/3477.v @@ -6,4 +6,4 @@ Proof. intros A B. evar (a : prod A B); evar (f : (prod A B -> Set)). let a' := (eval unfold a in a) in - set(foo:=eq_refl : a' = (@pair _ _ (fst a') (snd a'))).
\ No newline at end of file + set(foo:=eq_refl : a' = (@pair _ _ (fst a') (snd a'))). diff --git a/test-suite/bugs/closed/3480.v b/test-suite/bugs/closed/3480.v index a81837e714..35e0c51a93 100644 --- a/test-suite/bugs/closed/3480.v +++ b/test-suite/bugs/closed/3480.v @@ -45,4 +45,4 @@ yb : object StrX x : xa <~=~> yb The term "morphism_isomorphic:@morphism (precategory_of_structures P) xa yb" has type "@morphism (precategory_of_structures P) xa yb" -while it is expected to have type "morphism ?40 ?41 ?42". *)
\ No newline at end of file +while it is expected to have type "morphism ?40 ?41 ?42". *) diff --git a/test-suite/bugs/closed/3482.v b/test-suite/bugs/closed/3482.v index 34a5e73da7..87fd2723c9 100644 --- a/test-suite/bugs/closed/3482.v +++ b/test-suite/bugs/closed/3482.v @@ -8,4 +8,4 @@ Check foo _. (* Toplevel input, characters 6-11: Error: Illegal application (Non-functional construction): The expression "foo" of type "True" cannot be applied to the term - "?36" : "?35" *)
\ No newline at end of file + "?36" : "?35" *) diff --git a/test-suite/bugs/closed/3484.v b/test-suite/bugs/closed/3484.v index dc88a332b4..a0e157303f 100644 --- a/test-suite/bugs/closed/3484.v +++ b/test-suite/bugs/closed/3484.v @@ -28,4 +28,4 @@ T : Type H : sigT T (fun g : T => paths g g) x : T Unable to unify "paths (@projT1 ?24 ?23 ?25) (@projT1 ?24 ?23 ?26)" with - "paths (projT1 H) (projT1 {| projT1 := x; projT2 := idpath |})". *)
\ No newline at end of file + "paths (projT1 H) (projT1 {| projT1 := x; projT2 := idpath |})". *) diff --git a/test-suite/bugs/closed/3513.v b/test-suite/bugs/closed/3513.v index 9ed0926a66..5adc48215e 100644 --- a/test-suite/bugs/closed/3513.v +++ b/test-suite/bugs/closed/3513.v @@ -91,4 +91,4 @@ Debug: 2.2.1.1.1.1: apply ILFun_ILogic on (ILogic OPred) Set Printing All. (* As in 8.5, allow a shelved subgoal to remain *) apply reflexivity. -
\ No newline at end of file + diff --git a/test-suite/bugs/closed/3531.v b/test-suite/bugs/closed/3531.v index 764a7334e8..3502b4f549 100644 --- a/test-suite/bugs/closed/3531.v +++ b/test-suite/bugs/closed/3531.v @@ -51,4 +51,4 @@ Goal forall b, (exists e1 e2 e3, admit. admit. Show Universes. -Time Qed.
\ No newline at end of file +Time Qed. diff --git a/test-suite/bugs/closed/3560.v b/test-suite/bugs/closed/3560.v index 65ce4fb6b0..a740675f30 100644 --- a/test-suite/bugs/closed/3560.v +++ b/test-suite/bugs/closed/3560.v @@ -12,4 +12,4 @@ Goal forall (A B : Type) (C : Type), Equiv (A -> B -> C) (A * B -> C). Proof. intros. exists (fun u => fun x => u (fst x) (snd x)). -Abort.
\ No newline at end of file +Abort. diff --git a/test-suite/bugs/closed/3561.v b/test-suite/bugs/closed/3561.v index f6cbc92992..ef4422eeac 100644 --- a/test-suite/bugs/closed/3561.v +++ b/test-suite/bugs/closed/3561.v @@ -21,4 +21,4 @@ Goal forall (H0 H2 : Type) x p, intros. match goal with | [ |- context[x (?f _)] ] => set(foo':=f) - end.
\ No newline at end of file + end. diff --git a/test-suite/bugs/closed/3567.v b/test-suite/bugs/closed/3567.v index cb16b3ae4a..00c9c05469 100644 --- a/test-suite/bugs/closed/3567.v +++ b/test-suite/bugs/closed/3567.v @@ -65,4 +65,4 @@ ap (path_prod_uncurried z0 z') which is ill-typed. Reason is: Pattern-matching expression on an object of inductive type prod has invalid information. - *)
\ No newline at end of file + *) diff --git a/test-suite/bugs/closed/3584.v b/test-suite/bugs/closed/3584.v index 3d4660b487..37fe46376e 100644 --- a/test-suite/bugs/closed/3584.v +++ b/test-suite/bugs/closed/3584.v @@ -13,4 +13,4 @@ Definition sum_of_sigT A B (x : sigT (fun b : bool => if b then A else B)) | existT _ false b => inr b end. (* Toplevel input, characters 0-182: Error: Pattern-matching expression on an object of inductive type sigT -has invalid information. *)
\ No newline at end of file +has invalid information. *) diff --git a/test-suite/bugs/closed/3590.v b/test-suite/bugs/closed/3590.v index 3ef9270d40..9fded85a8d 100644 --- a/test-suite/bugs/closed/3590.v +++ b/test-suite/bugs/closed/3590.v @@ -9,4 +9,4 @@ Qed. (* Toplevel input, characters 20-58: Error: Failed to get enough information from the left-hand side to type the -right-hand side. *)
\ No newline at end of file +right-hand side. *) diff --git a/test-suite/bugs/closed/3594.v b/test-suite/bugs/closed/3594.v index d1aae7b440..1f86f4bd70 100644 --- a/test-suite/bugs/closed/3594.v +++ b/test-suite/bugs/closed/3594.v @@ -48,4 +48,4 @@ while it is expected to have type object := opposite D; morphism := fun s d : opposite D => morphism (opposite D) d s |}" and "opposite D"). - *)
\ No newline at end of file + *) diff --git a/test-suite/bugs/closed/3596.v b/test-suite/bugs/closed/3596.v index 49dd7be5a8..1ee9a5d8c1 100644 --- a/test-suite/bugs/closed/3596.v +++ b/test-suite/bugs/closed/3596.v @@ -16,4 +16,4 @@ Goal forall f b, Bar b = Bar b -> Foo f = Foo f. Fail progress unfold Bar. (* success *) Fail progress unfold Foo. (* failed to progress *) reflexivity. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/3618.v b/test-suite/bugs/closed/3618.v index dc560ad525..674b4cc2f4 100644 --- a/test-suite/bugs/closed/3618.v +++ b/test-suite/bugs/closed/3618.v @@ -100,4 +100,4 @@ Hint Mode IsEquiv - - + : typeclass_instances. Fail Definition equiv_O_rectnd {fs : Funext} {subU : ReflectiveSubuniverse} (P Q : Type) {Q_inO : inO_internal Q} -: IsEquiv (fun f : O P -> P => compose f (O_unit P)) := _.
\ No newline at end of file +: IsEquiv (fun f : O P -> P => compose f (O_unit P)) := _. diff --git a/test-suite/bugs/closed/3624.v b/test-suite/bugs/closed/3624.v index a05d5eb215..024243cfd3 100644 --- a/test-suite/bugs/closed/3624.v +++ b/test-suite/bugs/closed/3624.v @@ -8,4 +8,4 @@ Module Prim. Set Primitive Projections. Class foo (m : Set) := { pf : m = m }. Notation pf' m := (pf (m:=m)). (* Wrong argument name: m. *) -End Prim.
\ No newline at end of file +End Prim. diff --git a/test-suite/bugs/closed/3633.v b/test-suite/bugs/closed/3633.v index 6a952377ce..52bb307271 100644 --- a/test-suite/bugs/closed/3633.v +++ b/test-suite/bugs/closed/3633.v @@ -7,4 +7,4 @@ Proof. (* Ensure the constraints are solved independently, otherwise a frozen ?A makes a search for Contr ?A fail when finishing to apply (fun x => x) *) apply (fun x => x), center. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/3638.v b/test-suite/bugs/closed/3638.v index 70144174d7..5441fbedce 100644 --- a/test-suite/bugs/closed/3638.v +++ b/test-suite/bugs/closed/3638.v @@ -22,4 +22,4 @@ Goal forall (A B : Type) (x : O A * O B) (x0 : B), (* Toplevel input, characters 15-114: -Anomaly: Bad recursive type. Please report. *)
\ No newline at end of file +Anomaly: Bad recursive type. Please report. *) diff --git a/test-suite/bugs/closed/3640.v b/test-suite/bugs/closed/3640.v index bdbfbb152b..5dff98ba23 100644 --- a/test-suite/bugs/closed/3640.v +++ b/test-suite/bugs/closed/3640.v @@ -28,4 +28,4 @@ Proof. simpl in *. Fail match type of H with | _ = negb ?T => unify T (f.1 true); fail 1 "still has f.1 true" - end. (* Error: Tactic failure: still has f.1 true. *)
\ No newline at end of file + end. (* Error: Tactic failure: still has f.1 true. *) diff --git a/test-suite/bugs/closed/3641.v b/test-suite/bugs/closed/3641.v index f47f64ead7..730ab3f431 100644 --- a/test-suite/bugs/closed/3641.v +++ b/test-suite/bugs/closed/3641.v @@ -18,4 +18,4 @@ Goal forall (A B : Type) (x : O A * O B) (x0 : B), match goal with | [ |- context[?e] ] => is_evar e; let e' := fresh "e'" in pose (e' := e) end. - Fail change ?g with e'. (* Stack overflow *)
\ No newline at end of file + Fail change ?g with e'. (* Stack overflow *) diff --git a/test-suite/bugs/closed/3648.v b/test-suite/bugs/closed/3648.v index ba6006ed93..58aa161403 100644 --- a/test-suite/bugs/closed/3648.v +++ b/test-suite/bugs/closed/3648.v @@ -80,4 +80,4 @@ Error: Found no subterm matching "F _1 (identity (fst x))" in the current goal. *) rewrite identity_of. (* Toplevel input, characters 15-34: Error: -Found no subterm matching "morphism_of ?202 (identity ?203)" in the current goal. *)
\ No newline at end of file +Found no subterm matching "morphism_of ?202 (identity ?203)" in the current goal. *) diff --git a/test-suite/bugs/closed/3658.v b/test-suite/bugs/closed/3658.v index 622c3c94ac..74f4e82dbb 100644 --- a/test-suite/bugs/closed/3658.v +++ b/test-suite/bugs/closed/3658.v @@ -72,4 +72,4 @@ Module Prim. end. (* Error: Tactic failure: bad H1. *) admit. Defined. -End Prim.
\ No newline at end of file +End Prim. diff --git a/test-suite/bugs/closed/3661.v b/test-suite/bugs/closed/3661.v index fdca49bc42..1f13ffcf34 100644 --- a/test-suite/bugs/closed/3661.v +++ b/test-suite/bugs/closed/3661.v @@ -85,4 +85,4 @@ Goal forall (x3 x9 : PreCategory) (x12 f0 : Functor x9 x3) (@morphism_inverse _ _ _ (@morphism_isomorphic (functor_category x9 x3) f0 x12 x35) _) x37) -*)
\ No newline at end of file +*) diff --git a/test-suite/bugs/closed/3664.v b/test-suite/bugs/closed/3664.v index 63a81b6d01..cd1427a143 100644 --- a/test-suite/bugs/closed/3664.v +++ b/test-suite/bugs/closed/3664.v @@ -21,4 +21,4 @@ Module Prim. Fail progress cbn. (* [cbn] succeeds incorrectly, giving [d x] *) admit. Defined. -End Prim.
\ No newline at end of file +End Prim. diff --git a/test-suite/bugs/closed/3666.v b/test-suite/bugs/closed/3666.v index e69ec10976..c7bc2f22a8 100644 --- a/test-suite/bugs/closed/3666.v +++ b/test-suite/bugs/closed/3666.v @@ -48,4 +48,4 @@ H' : H_f a (h c) = H_g b (h c) Unable to unify "hproptype (H_f a (h c))" with "?T (H_f a (h c))". *) Defined. -End Prim.
\ No newline at end of file +End Prim. diff --git a/test-suite/bugs/closed/3668.v b/test-suite/bugs/closed/3668.v index da01ed00e4..1add3dba1e 100644 --- a/test-suite/bugs/closed/3668.v +++ b/test-suite/bugs/closed/3668.v @@ -51,4 +51,4 @@ Module Prim. end. (* Tactic failure: bad *) all:admit. Defined. -End Prim.
\ No newline at end of file +End Prim. diff --git a/test-suite/bugs/closed/3672.v b/test-suite/bugs/closed/3672.v index 283be49587..b355e7e9db 100644 --- a/test-suite/bugs/closed/3672.v +++ b/test-suite/bugs/closed/3672.v @@ -24,4 +24,4 @@ Record Ar3 C (A:AT) := ; id3 : forall X, ar3 X X }. (* The command has indeed failed with message: => Anomaly: Bad recursive type. Please report. -*)
\ No newline at end of file +*) diff --git a/test-suite/bugs/closed/3698.v b/test-suite/bugs/closed/3698.v index 31de8ec45b..3882eee97c 100644 --- a/test-suite/bugs/closed/3698.v +++ b/test-suite/bugs/closed/3698.v @@ -23,4 +23,4 @@ Proof. assert (H'' : forall g : X = Y -> (issig_hSet^-1 X).1 = (issig_hSet^-1 Y).1, g = g -> IsEquiv g) by admit. Eval compute in (@projT1 Type IsHSet (@equiv_inv _ _ _ (equiv_isequiv _ _ issig_hSet) X)). - Fail apply H''. (* stack overflow *)
\ No newline at end of file + Fail apply H''. (* stack overflow *) diff --git a/test-suite/bugs/closed/3699.v b/test-suite/bugs/closed/3699.v index efa4325264..dbb10f94f2 100644 --- a/test-suite/bugs/closed/3699.v +++ b/test-suite/bugs/closed/3699.v @@ -156,4 +156,4 @@ Module Prim. | fail 1 "destruct should generate unfolded projections, as should [let], goal:" G ]. admit. Defined. -End Prim.
\ No newline at end of file +End Prim. diff --git a/test-suite/bugs/closed/3700.v b/test-suite/bugs/closed/3700.v index 4e226524cb..bac443e337 100644 --- a/test-suite/bugs/closed/3700.v +++ b/test-suite/bugs/closed/3700.v @@ -81,4 +81,4 @@ Goal (forall x : NonPrim.prod Set Set, match x with NonPrim.pair a b => a = a /\ and (@eq Set (@Prim.fst Set Set x) (@Prim.fst Set Set x)) (@eq Set (@Prim.snd Set Set x) (@Prim.snd Set Set x))) *) Unset Printing All. -Abort.
\ No newline at end of file +Abort. diff --git a/test-suite/bugs/closed/3703.v b/test-suite/bugs/closed/3703.v index 7282500769..feeb04d64e 100644 --- a/test-suite/bugs/closed/3703.v +++ b/test-suite/bugs/closed/3703.v @@ -29,4 +29,4 @@ Module Keyed. rewrite <- H'. admit. Defined. -End Keyed.
\ No newline at end of file +End Keyed. diff --git a/test-suite/bugs/closed/3732.v b/test-suite/bugs/closed/3732.v index 76beedf687..09f1149c20 100644 --- a/test-suite/bugs/closed/3732.v +++ b/test-suite/bugs/closed/3732.v @@ -102,4 +102,4 @@ cannot be applied to the terms "G0" : "list Type" The 2nd term has type "Type@{Top.53}" which should be coercible to "Type@{Top.12}". - *)
\ No newline at end of file + *) diff --git a/test-suite/bugs/closed/3735.v b/test-suite/bugs/closed/3735.v index a50572ace0..aced9615ee 100644 --- a/test-suite/bugs/closed/3735.v +++ b/test-suite/bugs/closed/3735.v @@ -1,4 +1,4 @@ Require Import Coq.Program.Tactics. Class Foo := { bar : Type }. Fail Lemma foo : Foo -> bar. (* 'Command has indeed failed.' in both 8.4 and trunk *) -Fail Program Lemma foo : Foo -> bar.
\ No newline at end of file +Fail Program Lemma foo : Foo -> bar. diff --git a/test-suite/bugs/closed/3743.v b/test-suite/bugs/closed/3743.v index c799d4393f..ca78987bf3 100644 --- a/test-suite/bugs/closed/3743.v +++ b/test-suite/bugs/closed/3743.v @@ -8,4 +8,4 @@ Add Parametric Relation A transitivity proved by transitivity as refine_rel. (* Toplevel input, characters 20-118: -Anomaly: index to an anonymous variable. Please report. *)
\ No newline at end of file +Anomaly: index to an anonymous variable. Please report. *) diff --git a/test-suite/bugs/closed/3753.v b/test-suite/bugs/closed/3753.v index 5bfbee9494..f586438cdd 100644 --- a/test-suite/bugs/closed/3753.v +++ b/test-suite/bugs/closed/3753.v @@ -1,4 +1,4 @@ Axiom foo : Type -> Type. Axiom bar : forall (T : Type), T -> foo T. Arguments bar A x : rename. -About bar.
\ No newline at end of file +About bar. diff --git a/test-suite/bugs/closed/3782.v b/test-suite/bugs/closed/3782.v index 2dc50c17d0..16b0b8b603 100644 --- a/test-suite/bugs/closed/3782.v +++ b/test-suite/bugs/closed/3782.v @@ -61,4 +61,4 @@ The term "e'" has type "@IsEquiv md mc e" while it is expected to have type *) admit. Defined. -End Prim.
\ No newline at end of file +End Prim. diff --git a/test-suite/bugs/closed/3783.v b/test-suite/bugs/closed/3783.v index e217129688..f7e2b54353 100644 --- a/test-suite/bugs/closed/3783.v +++ b/test-suite/bugs/closed/3783.v @@ -30,4 +30,4 @@ Module Prim. Timeout 1 cbv beta in y. (* takes around 2s. Grows with the value passed to [exp] above *) admit. Defined. -End Prim.
\ No newline at end of file +End Prim. diff --git a/test-suite/bugs/closed/3807.v b/test-suite/bugs/closed/3807.v index 108ebf592b..a6286f0377 100644 --- a/test-suite/bugs/closed/3807.v +++ b/test-suite/bugs/closed/3807.v @@ -30,4 +30,4 @@ Axiom f@{i} : Type@{i}. (* *** [ f@{i} : Type@{i} ] (* i |= *) -*)
\ No newline at end of file +*) diff --git a/test-suite/bugs/closed/3808.v b/test-suite/bugs/closed/3808.v index a5c84e6856..ac6a850193 100644 --- a/test-suite/bugs/closed/3808.v +++ b/test-suite/bugs/closed/3808.v @@ -1,3 +1,3 @@ Unset Strict Universe Declaration. Inductive Foo : (let enforce := (fun x => x) : Type@{j} -> Type@{i} in Type@{i}) - := foo : Foo.
\ No newline at end of file + := foo : Foo. diff --git a/test-suite/bugs/closed/3819.v b/test-suite/bugs/closed/3819.v index 355d23a58b..0b9c3183cc 100644 --- a/test-suite/bugs/closed/3819.v +++ b/test-suite/bugs/closed/3819.v @@ -6,4 +6,4 @@ Lemma test1 (X:Type) : eq (op OpType X) X. Proof eq_refl. Definition test2 (A:Type) : eq (op _ A) A. -Proof eq_refl.
\ No newline at end of file +Proof eq_refl. diff --git a/test-suite/bugs/closed/3881.v b/test-suite/bugs/closed/3881.v index bb6af6a66c..7c60ddf347 100644 --- a/test-suite/bugs/closed/3881.v +++ b/test-suite/bugs/closed/3881.v @@ -32,4 +32,4 @@ Proof. apply (@isequiv_homotopic _ _ ((g o f) o f^-1) g _ (fun b => ap g (eisretr f b))). Qed. -
\ No newline at end of file + diff --git a/test-suite/bugs/closed/3886.v b/test-suite/bugs/closed/3886.v index 2ac4abe54f..b523b117e5 100644 --- a/test-suite/bugs/closed/3886.v +++ b/test-suite/bugs/closed/3886.v @@ -20,4 +20,4 @@ Obligation 1 of doubleO. apply cheat. Qed. -Check doubleE.
\ No newline at end of file +Check doubleE. diff --git a/test-suite/bugs/closed/3899.v b/test-suite/bugs/closed/3899.v index e83166aaec..7754934c0b 100644 --- a/test-suite/bugs/closed/3899.v +++ b/test-suite/bugs/closed/3899.v @@ -8,4 +8,4 @@ Fail Check fun x y : unit => eq_refl : x = y. Record ok : Set := tt' { a : unit }. Record nonprim : Prop := { undef : unit }. -Record prim : Prop := { def : True }.
\ No newline at end of file +Record prim : Prop := { def : True }. diff --git a/test-suite/bugs/closed/3943.v b/test-suite/bugs/closed/3943.v index 5e5ba816f9..ac9c50369b 100644 --- a/test-suite/bugs/closed/3943.v +++ b/test-suite/bugs/closed/3943.v @@ -47,4 +47,4 @@ Definition path_isomorphic (i j : Isomorphic s d) Admitted. Definition ap_morphism_inverse_path_isomorphic (i j : Isomorphic s d) p q -: ap (fun e : Isomorphic s d => e^-1)%morphism (path_isomorphic i j p) = q.
\ No newline at end of file +: ap (fun e : Isomorphic s d => e^-1)%morphism (path_isomorphic i j p) = q. diff --git a/test-suite/bugs/closed/3956.v b/test-suite/bugs/closed/3956.v index 66dee702aa..4957cc740d 100644 --- a/test-suite/bugs/closed/3956.v +++ b/test-suite/bugs/closed/3956.v @@ -140,4 +140,4 @@ Module Comodality_Theory (F : Comodality). End cip_FPHM. End isequiv_F_prod_cmp_M. -End Comodality_Theory.
\ No newline at end of file +End Comodality_Theory. diff --git a/test-suite/bugs/closed/3960.v b/test-suite/bugs/closed/3960.v index e56dcef74f..3527312486 100644 --- a/test-suite/bugs/closed/3960.v +++ b/test-suite/bugs/closed/3960.v @@ -23,4 +23,4 @@ Class myClassP (A : Type) := Instance myInstanceP : myClassP nat := { barP := fooP - }.
\ No newline at end of file + }. diff --git a/test-suite/bugs/closed/3974.v b/test-suite/bugs/closed/3974.v index b6be159595..3d9e06b612 100644 --- a/test-suite/bugs/closed/3974.v +++ b/test-suite/bugs/closed/3974.v @@ -4,4 +4,4 @@ End S. Module Type M (X : S). Fail Module P (X : S). (* Used to say: Anomaly: X already exists. Please report. *) - (* Should rather say now: Error: X already exists. *)
\ No newline at end of file + (* Should rather say now: Error: X already exists. *) diff --git a/test-suite/bugs/closed/3975.v b/test-suite/bugs/closed/3975.v index 95851c8137..c7616b3ab6 100644 --- a/test-suite/bugs/closed/3975.v +++ b/test-suite/bugs/closed/3975.v @@ -5,4 +5,4 @@ Module M (X:S). End M. Module Type P (X : S). Print M. (* Used to say: Anomaly: X already exists. Please report. *) - (* Should rather : print something :-) *)
\ No newline at end of file + (* Should rather : print something :-) *) diff --git a/test-suite/bugs/closed/3998.v b/test-suite/bugs/closed/3998.v index ced13839dd..e17550e904 100644 --- a/test-suite/bugs/closed/3998.v +++ b/test-suite/bugs/closed/3998.v @@ -21,4 +21,4 @@ Axiom ex : RecordOf _ I1FieldType. Definition works := (fun ex' => update ex' C true) (update ex C false). Set Typeclasses Debug. -Definition doesnt := update (update ex C false) C true.
\ No newline at end of file +Definition doesnt := update (update ex C false) C true. diff --git a/test-suite/bugs/closed/4031.v b/test-suite/bugs/closed/4031.v index 2b8641ebb0..6c23baffa0 100644 --- a/test-suite/bugs/closed/4031.v +++ b/test-suite/bugs/closed/4031.v @@ -11,4 +11,4 @@ Proof. change mytt with (@something _ mytt) in x. subst x. (* Proof works if this line is removed *) reflexivity. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/4069.v b/test-suite/bugs/closed/4069.v index 61527764e2..606c6e0845 100644 --- a/test-suite/bugs/closed/4069.v +++ b/test-suite/bugs/closed/4069.v @@ -101,4 +101,4 @@ Variable T : Type. Goal @eq Type T T. congruence. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/4095.v b/test-suite/bugs/closed/4095.v index ffd33d3813..8d7dfbd49b 100644 --- a/test-suite/bugs/closed/4095.v +++ b/test-suite/bugs/closed/4095.v @@ -84,4 +84,4 @@ O1 : T -> PointedOPred tr : T -> T O2 : PointedOPred x0 : T -H : forall x0 : T, catOP (O0 x0) (O1 (tr x0)) |-- O1 x0 *)
\ No newline at end of file +H : forall x0 : T, catOP (O0 x0) (O1 (tr x0)) |-- O1 x0 *) diff --git a/test-suite/bugs/closed/4097.v b/test-suite/bugs/closed/4097.v index 02aa25e09f..183b860d1f 100644 --- a/test-suite/bugs/closed/4097.v +++ b/test-suite/bugs/closed/4097.v @@ -62,4 +62,4 @@ Definition path_path_sigma {A : Type} (P : A -> Type) (u v : sigT P) (r : p..1 = q..1) (s : transport (fun x => transport P x u.2 = v.2) r p..2 = q..2) : p = q - := path_path_sigma_uncurried P u v p q (r; s).
\ No newline at end of file + := path_path_sigma_uncurried P u v p q (r; s). diff --git a/test-suite/bugs/closed/4101.v b/test-suite/bugs/closed/4101.v index a38b050966..75a26a0670 100644 --- a/test-suite/bugs/closed/4101.v +++ b/test-suite/bugs/closed/4101.v @@ -16,4 +16,4 @@ Lemma sigT_obj_eq Proof. intros. Set Debug Tactic Unification. - apply path_forall.
\ No newline at end of file + apply path_forall. diff --git a/test-suite/bugs/closed/4120.v b/test-suite/bugs/closed/4120.v index 00db8f7f3c..315dc0d242 100644 --- a/test-suite/bugs/closed/4120.v +++ b/test-suite/bugs/closed/4120.v @@ -2,4 +2,4 @@ Definition id {T} (x : T) := x. Goal sigT (fun x => id x)%type. change (fun x => ?f x) with f. exists Type. exact Set. -Defined. (* Error: Attempt to save a proof with shelved goals (in proof Unnamed_thm) *)
\ No newline at end of file +Defined. (* Error: Attempt to save a proof with shelved goals (in proof Unnamed_thm) *) diff --git a/test-suite/bugs/closed/4151.v b/test-suite/bugs/closed/4151.v index fec64555f4..fc0b58cfe1 100644 --- a/test-suite/bugs/closed/4151.v +++ b/test-suite/bugs/closed/4151.v @@ -400,4 +400,4 @@ Section sound. Undo. assumption. Undo. - eassumption. (* no applicable tactic *)
\ No newline at end of file + eassumption. (* no applicable tactic *) diff --git a/test-suite/bugs/closed/4161.v b/test-suite/bugs/closed/4161.v index aa2b189b67..d2003ab1f0 100644 --- a/test-suite/bugs/closed/4161.v +++ b/test-suite/bugs/closed/4161.v @@ -24,4 +24,4 @@ Inductive t : Type -> Type := Fixpoint test {A : Type} (x : t A) : t (A + unit) := match x in t A with | Just B x => @test B x - end.
\ No newline at end of file + end. diff --git a/test-suite/bugs/closed/4203.v b/test-suite/bugs/closed/4203.v index 076a3c3d68..eb6867a033 100644 --- a/test-suite/bugs/closed/4203.v +++ b/test-suite/bugs/closed/4203.v @@ -16,4 +16,4 @@ Definition t' := Eval vm_compute in constant_ok nat_ops nat_ops_ok. Definition t'' := Eval native_compute in constant_ok nat_ops nat_ops_ok. Check (eq_refl t : t = t'). -Check (eq_refl t : t = t'').
\ No newline at end of file +Check (eq_refl t : t = t''). diff --git a/test-suite/bugs/closed/4214.v b/test-suite/bugs/closed/4214.v index d684e8cf4b..2e620fce2a 100644 --- a/test-suite/bugs/closed/4214.v +++ b/test-suite/bugs/closed/4214.v @@ -3,4 +3,4 @@ Goal forall A (a b c : A), b = a -> b = c -> a = c. intros. subst. reflexivity. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/4250.v b/test-suite/bugs/closed/4250.v index 74cacf559a..f5d0d1a523 100644 --- a/test-suite/bugs/closed/4250.v +++ b/test-suite/bugs/closed/4250.v @@ -8,4 +8,4 @@ Function f2 {A:Type} {n:nat} {v:Vector.t A n} : nat := n. (* fails with "The reference A was not found in the current environment." *) Function f3 `{n:nat , u:Vector.t A n} := u. -Check R_f3_complete.
\ No newline at end of file +Check R_f3_complete. diff --git a/test-suite/bugs/closed/4251.v b/test-suite/bugs/closed/4251.v index 66343d6671..f112e7b4d5 100644 --- a/test-suite/bugs/closed/4251.v +++ b/test-suite/bugs/closed/4251.v @@ -14,4 +14,4 @@ Check array Type. Check fun A : Type => Ref A. Definition abs_val (a : Type) := - bind (ref a) (fun r : array Type => array_make tt).
\ No newline at end of file + bind (ref a) (fun r : array Type => array_make tt). diff --git a/test-suite/bugs/closed/4273.v b/test-suite/bugs/closed/4273.v index 591ea4b5b2..401e86649b 100644 --- a/test-suite/bugs/closed/4273.v +++ b/test-suite/bugs/closed/4273.v @@ -6,4 +6,4 @@ Theorem onefiber' (q : total2 (fun y => y = 0)) : True. Proof. assert (foo:=pr2 _ q). simpl in foo. destruct foo. (* Error: q is used in conclusion. *) exact I. Qed. -Print onefiber'.
\ No newline at end of file +Print onefiber'. diff --git a/test-suite/bugs/closed/4276.v b/test-suite/bugs/closed/4276.v index ba82e6c376..ea9cbb210f 100644 --- a/test-suite/bugs/closed/4276.v +++ b/test-suite/bugs/closed/4276.v @@ -8,4 +8,4 @@ Definition bad' : True := mybox.(unwrap _ _). Fail Definition bad : False := unwrap _ _ mybox. -(* Closed under the global context *)
\ No newline at end of file +(* Closed under the global context *) diff --git a/test-suite/bugs/closed/4287.v b/test-suite/bugs/closed/4287.v index 43c9b51295..757b71b2dd 100644 --- a/test-suite/bugs/closed/4287.v +++ b/test-suite/bugs/closed/4287.v @@ -120,4 +120,4 @@ Definition setle (B : Type@{i}) := Fail Check @setlt@{j Prop}. Fail Definition foo := @setle@{j Prop}. Check setlt@{Set i}. -Check setlt@{Set j}.
\ No newline at end of file +Check setlt@{Set j}. diff --git a/test-suite/bugs/closed/4293.v b/test-suite/bugs/closed/4293.v index 3671c931b7..21d333fa63 100644 --- a/test-suite/bugs/closed/4293.v +++ b/test-suite/bugs/closed/4293.v @@ -4,4 +4,4 @@ End Foo. Module M : Foo. Definition T := let X := Type in Type. -End M.
\ No newline at end of file +End M. diff --git a/test-suite/bugs/closed/4299.v b/test-suite/bugs/closed/4299.v index 955c3017d7..a1daa193ae 100644 --- a/test-suite/bugs/closed/4299.v +++ b/test-suite/bugs/closed/4299.v @@ -9,4 +9,4 @@ End Foo. Module M : Foo with Definition U := Type : Type. Definition U := let X := Type in Type. Definition eq : Type = U := eq_refl. -Fail End M.
\ No newline at end of file +Fail End M. diff --git a/test-suite/bugs/closed/4306.v b/test-suite/bugs/closed/4306.v index 4aef5bb95e..28f028ad89 100644 --- a/test-suite/bugs/closed/4306.v +++ b/test-suite/bugs/closed/4306.v @@ -29,4 +29,4 @@ Function bar (xys : (list nat * list nat)) {measure (fun xys => length (fst xys) | Eq => x :: foo (xs', ys') | Gt => y :: foo (xs, ys') end - end.
\ No newline at end of file + end. diff --git a/test-suite/bugs/closed/4328.v b/test-suite/bugs/closed/4328.v index 8e1bb31007..b40b3a4830 100644 --- a/test-suite/bugs/closed/4328.v +++ b/test-suite/bugs/closed/4328.v @@ -3,4 +3,4 @@ Axiom pi : forall (P : Prop) (p : P), Prop. Definition test1 A (x : _) := pi A x. (* success *) Fail Definition test2 A (x : A) := pi A x. (* failure ??? *) Fail Definition test3 A (x : A) (_ : M A) := pi A x. (* failure *) -Fail Definition test4 A (_ : M A) (x : A) := pi A x. (* success ??? *)
\ No newline at end of file +Fail Definition test4 A (_ : M A) (x : A) := pi A x. (* success ??? *) diff --git a/test-suite/bugs/closed/4354.v b/test-suite/bugs/closed/4354.v index e71ddaf71f..c55b4cf02a 100644 --- a/test-suite/bugs/closed/4354.v +++ b/test-suite/bugs/closed/4354.v @@ -8,4 +8,4 @@ Proof. auto using closed_increment. Show Universes. Qed. (* also fails with -nois, so the content of the hint database does not matter -*)
\ No newline at end of file +*) diff --git a/test-suite/bugs/closed/4375.v b/test-suite/bugs/closed/4375.v index 71e3a75187..468bade1cc 100644 --- a/test-suite/bugs/closed/4375.v +++ b/test-suite/bugs/closed/4375.v @@ -104,4 +104,4 @@ with cb@{i} (t : Type@{i}) : foo@{i} t := Print ca. Print cb. -
\ No newline at end of file + diff --git a/test-suite/bugs/closed/4416.v b/test-suite/bugs/closed/4416.v index 3189685ec0..62b90b4286 100644 --- a/test-suite/bugs/closed/4416.v +++ b/test-suite/bugs/closed/4416.v @@ -1,4 +1,4 @@ Goal exists x, x. Unset Solve Unification Constraints. unshelve refine (ex_intro _ _ _); match goal with _ => refine (_ _) end. -(* Error: Incorrect number of goals (expected 2 tactics). *)
\ No newline at end of file +(* Error: Incorrect number of goals (expected 2 tactics). *) diff --git a/test-suite/bugs/closed/4433.v b/test-suite/bugs/closed/4433.v index 9eeb864689..83c0e3f81f 100644 --- a/test-suite/bugs/closed/4433.v +++ b/test-suite/bugs/closed/4433.v @@ -26,4 +26,4 @@ Proof. case proof_admitted. Unshelve. all:constructor. -Defined.
\ No newline at end of file +Defined. diff --git a/test-suite/bugs/closed/4443.v b/test-suite/bugs/closed/4443.v index 66dfa0e685..a3a8717d98 100644 --- a/test-suite/bugs/closed/4443.v +++ b/test-suite/bugs/closed/4443.v @@ -28,4 +28,4 @@ Defined. Set Printing Universes. Check PROD@{i i i}. Check PRODinj@{i j}. -Fail Check PRODinj@{j i}.
\ No newline at end of file +Fail Check PRODinj@{j i}. diff --git a/test-suite/bugs/closed/4450.v b/test-suite/bugs/closed/4450.v index ecebaba812..c1fe44315a 100644 --- a/test-suite/bugs/closed/4450.v +++ b/test-suite/bugs/closed/4450.v @@ -55,4 +55,4 @@ Proof. eauto using foo. Show Universes. Undo. eauto using foop. Show Proof. Show Universes. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/4480.v b/test-suite/bugs/closed/4480.v index 08a86330f2..98c05ee1a8 100644 --- a/test-suite/bugs/closed/4480.v +++ b/test-suite/bugs/closed/4480.v @@ -9,4 +9,4 @@ Admitted. Goal True. Fail setoid_rewrite foo. Fail setoid_rewrite trueI. -
\ No newline at end of file + diff --git a/test-suite/bugs/closed/4498.v b/test-suite/bugs/closed/4498.v index ccdb2dddda..379e46b3e3 100644 --- a/test-suite/bugs/closed/4498.v +++ b/test-suite/bugs/closed/4498.v @@ -21,4 +21,4 @@ Require Export Coq.Setoids.Setoid. Add Parametric Morphism `{C : Category} {A B C} : (@compose _ A B C) with signature equiv ==> equiv ==> equiv as compose_mor. -Proof. apply comp_respects. Qed.
\ No newline at end of file +Proof. apply comp_respects. Qed. diff --git a/test-suite/bugs/closed/4503.v b/test-suite/bugs/closed/4503.v index f54d6433d8..5162f352df 100644 --- a/test-suite/bugs/closed/4503.v +++ b/test-suite/bugs/closed/4503.v @@ -34,4 +34,4 @@ Section Embed_ILogic_Pre. Polymorphic Universes A T. Fail Context {A : Type@{A}} {ILA: ILogic.ILogic@{A} A}. -End Embed_ILogic_Pre.
\ No newline at end of file +End Embed_ILogic_Pre. diff --git a/test-suite/bugs/closed/4519.v b/test-suite/bugs/closed/4519.v index ccbc47d20f..945183fae7 100644 --- a/test-suite/bugs/closed/4519.v +++ b/test-suite/bugs/closed/4519.v @@ -18,4 +18,4 @@ Check qux nat nat nat : Set. Check qux nat nat Set : Set. (* Error: The term "qux@{Top.50 Top.51} ?T ?T0 Set" has type "Type@{Top.50}" while it is expected to have type "Set" -(universe inconsistency: Cannot enforce Top.50 = Set because Set < Top.50). *)
\ No newline at end of file +(universe inconsistency: Cannot enforce Top.50 = Set because Set < Top.50). *) diff --git a/test-suite/bugs/closed/4603.v b/test-suite/bugs/closed/4603.v index e7567623a6..2c90044dc7 100644 --- a/test-suite/bugs/closed/4603.v +++ b/test-suite/bugs/closed/4603.v @@ -7,4 +7,4 @@ Abort. Goal True. Definition foo (A : Type) : Prop:= True. set (x:=foo). split. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/4627.v b/test-suite/bugs/closed/4627.v index e1206bb37a..4f56e19584 100644 --- a/test-suite/bugs/closed/4627.v +++ b/test-suite/bugs/closed/4627.v @@ -46,4 +46,4 @@ The term "predicate nat (Build_sa nat)" has type while it is expected to have type "Type@{Top.208}" (universe inconsistency: Cannot enforce Top.205 <= Top.208 because Top.208 < Top.205). -*)
\ No newline at end of file +*) diff --git a/test-suite/bugs/closed/4679.v b/test-suite/bugs/closed/4679.v index c94fa31a9d..3f41c5d6b1 100644 --- a/test-suite/bugs/closed/4679.v +++ b/test-suite/bugs/closed/4679.v @@ -15,4 +15,4 @@ Proof. Undo. setoid_rewrite H. (* Error: Tactic failure: setoid rewrite failed: Nothing to rewrite. *) reflexivity. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/4723.v b/test-suite/bugs/closed/4723.v index 8884812102..5fb9696f3f 100644 --- a/test-suite/bugs/closed/4723.v +++ b/test-suite/bugs/closed/4723.v @@ -25,4 +25,4 @@ Program Fact kp_assoc (x: Matrix xr xc) (y: Matrix yr yc) (z: Matrix zr zc): kp x (kp y z) = kp (kp x y) z. admit. -Admitted.
\ No newline at end of file +Admitted. diff --git a/test-suite/bugs/closed/4754.v b/test-suite/bugs/closed/4754.v index 5bb3cd1be7..67d645a68f 100644 --- a/test-suite/bugs/closed/4754.v +++ b/test-suite/bugs/closed/4754.v @@ -32,4 +32,4 @@ Proof. pose proof (_ : (Proper (_ ==> eq ==> _) and)). setoid_rewrite (FG _ _); [ | reflexivity.. ]. Undo. - setoid_rewrite (FG _ eq_refl). (* Error: Tactic failure: setoid rewrite failed: Nothing to rewrite. in 8.5 *) Admitted.
\ No newline at end of file + setoid_rewrite (FG _ eq_refl). (* Error: Tactic failure: setoid rewrite failed: Nothing to rewrite. in 8.5 *) Admitted. diff --git a/test-suite/bugs/closed/4763.v b/test-suite/bugs/closed/4763.v index ae8ed0e6e8..9613b5c248 100644 --- a/test-suite/bugs/closed/4763.v +++ b/test-suite/bugs/closed/4763.v @@ -10,4 +10,4 @@ Goal forall x y z, leb x y -> leb y z -> True. => pose proof (transitivity H H' : is_true (R x z)) end. exact I. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/4769.v b/test-suite/bugs/closed/4769.v index 33a1d1a50b..f0c91f7b49 100644 --- a/test-suite/bugs/closed/4769.v +++ b/test-suite/bugs/closed/4769.v @@ -91,4 +91,4 @@ Section Adjunction. (oppositeC C) D C (identityF (oppositeC C)) G)) }. -End Adjunction.
\ No newline at end of file +End Adjunction. diff --git a/test-suite/bugs/closed/4869.v b/test-suite/bugs/closed/4869.v index 6d21b66fe9..ac5d7ea287 100644 --- a/test-suite/bugs/closed/4869.v +++ b/test-suite/bugs/closed/4869.v @@ -15,4 +15,4 @@ Section Foo. Constraint Set < j. Definition foo := Type@{j}. -End Foo.
\ No newline at end of file +End Foo. diff --git a/test-suite/bugs/closed/4873.v b/test-suite/bugs/closed/4873.v index f2f917b4e7..3be36d8475 100644 --- a/test-suite/bugs/closed/4873.v +++ b/test-suite/bugs/closed/4873.v @@ -69,4 +69,4 @@ Proof. destruct xs; simpl; intros; subst; auto. generalize dependent t. simpl in *. induction xs; simpl in *; intros; congruence. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/4877.v b/test-suite/bugs/closed/4877.v index 7e3c78dc2e..7d153d9828 100644 --- a/test-suite/bugs/closed/4877.v +++ b/test-suite/bugs/closed/4877.v @@ -9,4 +9,4 @@ Ltac induction_last := Goal forall n m : nat, True -> n = m -> m = n. induction_last. reflexivity. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/5036.v b/test-suite/bugs/closed/5036.v index 12c958be67..83f1677455 100644 --- a/test-suite/bugs/closed/5036.v +++ b/test-suite/bugs/closed/5036.v @@ -7,4 +7,4 @@ Section foo. autorewrite with core. constructor. Qed. -End foo. (* Anomaly: Universe Top.16 undefined. Please report. *)
\ No newline at end of file +End foo. (* Anomaly: Universe Top.16 undefined. Please report. *) diff --git a/test-suite/bugs/closed/5065.v b/test-suite/bugs/closed/5065.v index 6bd677ba6f..932fee8b3b 100644 --- a/test-suite/bugs/closed/5065.v +++ b/test-suite/bugs/closed/5065.v @@ -3,4 +3,4 @@ Inductive foo := C1 : bar -> foo with bar := C2 : foo -> bar. Lemma L1 : foo -> True with L2 : bar -> True. intros; clear L1 L2; abstract (exact I). intros; exact I. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/5123.v b/test-suite/bugs/closed/5123.v index bcde510ee6..17231bffcf 100644 --- a/test-suite/bugs/closed/5123.v +++ b/test-suite/bugs/closed/5123.v @@ -30,4 +30,4 @@ Goal True. all:cycle 3. eapply existT. (*This does no typeclass resultion, which is correct.*) Focus 5. -Abort.
\ No newline at end of file +Abort. diff --git a/test-suite/bugs/closed/5180.v b/test-suite/bugs/closed/5180.v index 261092ee6d..05603a048c 100644 --- a/test-suite/bugs/closed/5180.v +++ b/test-suite/bugs/closed/5180.v @@ -61,4 +61,4 @@ The term "x" has type "TypeOfTypei' (Typei 0)" while it is expected to have type "TypeOfTypei' (Typei 1)" (universe inconsistency: Cannot enforce b = a because a < b). *) all:compute in *. - all:exact x.
\ No newline at end of file + all:exact x. diff --git a/test-suite/bugs/closed/5203.v b/test-suite/bugs/closed/5203.v index ed137395fc..3428e1a450 100644 --- a/test-suite/bugs/closed/5203.v +++ b/test-suite/bugs/closed/5203.v @@ -2,4 +2,4 @@ Goal True. Typeclasses eauto := debug. Fail solve [ typeclasses eauto ]. Fail typeclasses eauto. -
\ No newline at end of file + diff --git a/test-suite/bugs/closed/5315.v b/test-suite/bugs/closed/5315.v index f1f1b8c051..d8824bff87 100644 --- a/test-suite/bugs/closed/5315.v +++ b/test-suite/bugs/closed/5315.v @@ -7,4 +7,4 @@ Function dumb_nope (a:nat) {struct a} := match (id (fun x => x)) a with O => O | S n' => dumb_nope n' end. (* This check is just present to ensure Function worked well *) -Check R_dumb_nope_complete.
\ No newline at end of file +Check R_dumb_nope_complete. diff --git a/test-suite/bugs/closed/5434.v b/test-suite/bugs/closed/5434.v new file mode 100644 index 0000000000..5d2460face --- /dev/null +++ b/test-suite/bugs/closed/5434.v @@ -0,0 +1,18 @@ +(* About binders which remain unnamed after typing *) + +Global Set Asymmetric Patterns. + +Definition proj2_sig_map {A} {P Q : A -> Prop} (f : forall a, P a -> Q a) (x : +@sig A P) : @sig A Q + := let 'exist a p := x in exist Q a (f a p). +Axioms (feBW' : Type) (g : Prop -> Prop) (f' : feBW' -> Prop). +Definition foo := @proj2_sig_map feBW' (fun H => True = f' _) (fun H => + g True = g (f' H)) + (fun (a : feBW') (p : (fun H : feBW' => True = + f' H) a) => @f_equal Prop Prop g True (f' a) p). +Print foo. +Goal True. + lazymatch type of foo with + | sig (fun a : ?A => ?P) -> _ + => pose (fun a : A => a = a /\ P = P) + end. diff --git a/test-suite/bugs/closed/5578.v b/test-suite/bugs/closed/5578.v index 5bcdaa2f18..b9f0bc45c6 100644 --- a/test-suite/bugs/closed/5578.v +++ b/test-suite/bugs/closed/5578.v @@ -54,4 +54,4 @@ Goal forall (Rat : Set) (PositiveMap_t : Set -> Set) f eta ( (Bind (k eta) (fun rands => ret_bool (interp_term_fixed_t_x eta (adv' eta) rands ?= interp_term_fixed_t_x eta (adv' eta) rands)))))). - (* Error: Anomaly "Signature and its instance do not match." Please report at http://coq.inria.fr/bugs/. *)
\ No newline at end of file + (* Error: Anomaly "Signature and its instance do not match." Please report at http://coq.inria.fr/bugs/. *) diff --git a/test-suite/bugs/closed/5618.v b/test-suite/bugs/closed/5618.v index ab88a88f44..47e0e92d2a 100644 --- a/test-suite/bugs/closed/5618.v +++ b/test-suite/bugs/closed/5618.v @@ -6,4 +6,4 @@ Function test {T} (v : T) (x : nat) : nat := | S x' => test v x' end. -Check R_test_complete.
\ No newline at end of file +Check R_test_complete. diff --git a/test-suite/bugs/closed/5666.v b/test-suite/bugs/closed/5666.v new file mode 100644 index 0000000000..d55a6e57b4 --- /dev/null +++ b/test-suite/bugs/closed/5666.v @@ -0,0 +1,4 @@ +Inductive foo := Foo : False -> foo. +Goal foo. +try (constructor ; fail 0). +Fail try (constructor ; fail 1). diff --git a/test-suite/bugs/closed/5707.v b/test-suite/bugs/closed/5707.v new file mode 100644 index 0000000000..785844c66d --- /dev/null +++ b/test-suite/bugs/closed/5707.v @@ -0,0 +1,12 @@ +(* Destruct and primitive projections *) + +(* Checking the (superficial) part of #5707: + "destruct" should be able to use non-dependent case analysis when + dependent case analysis is not available and unneeded *) + +Set Primitive Projections. + +Inductive foo := Foo { proj1 : nat; proj2 : nat }. + +Goal forall x : foo, True. +Proof. intros x. destruct x. diff --git a/test-suite/bugs/closed/5713.v b/test-suite/bugs/closed/5713.v new file mode 100644 index 0000000000..9daf9647fc --- /dev/null +++ b/test-suite/bugs/closed/5713.v @@ -0,0 +1,15 @@ +(* Checking that classical_right/classical_left work in an empty context *) + +Require Import Classical. + +Parameter A:Prop. + +Goal A \/ ~A. +classical_right. +assumption. +Qed. + +Goal ~A \/ A. +classical_left. +assumption. +Qed. diff --git a/test-suite/bugs/closed/5749.v b/test-suite/bugs/closed/5749.v new file mode 100644 index 0000000000..81bfe351c5 --- /dev/null +++ b/test-suite/bugs/closed/5749.v @@ -0,0 +1,18 @@ +(* Checking computation of free vars of a term for generalization *) + +Definition Decision := fun P : Prop => {P} + {~ P}. +Class SetUnfold (P Q : Prop) : Prop := Build_SetUnfold { set_unfold : P <-> Q +}. + +Section Filter_Help. + + Context {A: Type}. + Context (fold_right : forall A B : Type, (B -> A -> A) -> A -> list B -> A). + Definition lType2 := (sigT (fun (P : A -> Prop) => forall a, Decision (P +a))). + Definition test (X: lType2) := let (x, _) := X in x. + + Global Instance foo `{fhl1 : list lType2} m Q: + SetUnfold (Q) + (fold_right _ _ (fun (s : lType2) => let (P, _) := s in and (P +m)) (Q) (fhl1)). diff --git a/test-suite/bugs/closed/5750.v b/test-suite/bugs/closed/5750.v new file mode 100644 index 0000000000..6d0e21f5d0 --- /dev/null +++ b/test-suite/bugs/closed/5750.v @@ -0,0 +1,3 @@ +(* Check printability of the hole of the context *) +Goal 0 = 0. +match goal with |- context c [0] => idtac c end. diff --git a/test-suite/bugs/closed/5755.v b/test-suite/bugs/closed/5755.v new file mode 100644 index 0000000000..e07fdcf831 --- /dev/null +++ b/test-suite/bugs/closed/5755.v @@ -0,0 +1,16 @@ +(* Sections taking care of let-ins for inductive types *) + +Section Foo. + +Inductive foo (A : Type) (x : A) (y := x) (y : A) := Foo. + +End Foo. + +Section Foo2. + +Variable B : Type. +Variable b : B. +Let c := b. +Inductive foo2 (A : Type) (x : A) (y := x) (y : A) := Foo2 : c=c -> foo2 A x y. + +End Foo2. diff --git a/test-suite/bugs/closed/808_2411.v b/test-suite/bugs/closed/808_2411.v index 1c13e74547..1169b2036b 100644 --- a/test-suite/bugs/closed/808_2411.v +++ b/test-suite/bugs/closed/808_2411.v @@ -24,4 +24,4 @@ rewrite bar'. now apply le_S. Qed. -End test.
\ No newline at end of file +End test. diff --git a/test-suite/bugs/closed/HoTT_coq_014.v b/test-suite/bugs/closed/HoTT_coq_014.v index 223a98de1c..5c45036643 100644 --- a/test-suite/bugs/closed/HoTT_coq_014.v +++ b/test-suite/bugs/closed/HoTT_coq_014.v @@ -199,4 +199,4 @@ Fail Admitted. Polymorphic Definition UnderlyingGraphFunctor_MorphismOf (C D : SmallCategory) (F : SpecializedFunctor C D) : Morphism (FunctorCategory GraphIndexingCategory TypeCat) (UnderlyingGraph C) (UnderlyingGraph D). (* Anomaly: apply_coercion. Please report.*) Proof. -Admitted.
\ No newline at end of file +Admitted. diff --git a/test-suite/bugs/closed/HoTT_coq_080.v b/test-suite/bugs/closed/HoTT_coq_080.v index 6b07c30404..a9e0bd2676 100644 --- a/test-suite/bugs/closed/HoTT_coq_080.v +++ b/test-suite/bugs/closed/HoTT_coq_080.v @@ -24,4 +24,4 @@ Goal forall C D (x y : ob (sum_category C D)), Type. intros C D x y. hnf in x, y. exact (hom (sum_category _ _) x y). -Defined.
\ No newline at end of file +Defined. diff --git a/test-suite/bugs/opened/1596.v b/test-suite/bugs/opened/1596.v index 7c5dc41679..0b576db6b3 100644 --- a/test-suite/bugs/opened/1596.v +++ b/test-suite/bugs/opened/1596.v @@ -258,4 +258,4 @@ n). apply SynInc;apply H.mem_2;trivial. rewrite H in H0. discriminate. (* !! impossible here !! *) Qed. -End B.
\ No newline at end of file +End B. diff --git a/test-suite/bugs/opened/1811.v b/test-suite/bugs/opened/1811.v index 10c988fc02..57c1744313 100644 --- a/test-suite/bugs/opened/1811.v +++ b/test-suite/bugs/opened/1811.v @@ -7,4 +7,4 @@ Goal forall b1 b2, (negb b1 = b2) -> xorb true b1 = b2. Proof. intros b1 b2. Fail rewrite neg2xor. -Abort.
\ No newline at end of file +Abort. diff --git a/test-suite/bugs/opened/3794.v b/test-suite/bugs/opened/3794.v index 99ca6cb39d..e4711a38c0 100644 --- a/test-suite/bugs/opened/3794.v +++ b/test-suite/bugs/opened/3794.v @@ -4,4 +4,4 @@ Hint Unfold not : core. Goal true<>false. Set Typeclasses Debug. Fail typeclasses eauto with core. -Abort.
\ No newline at end of file +Abort. diff --git a/test-suite/bugs/opened/3948.v b/test-suite/bugs/opened/3948.v index 165813084d..5c4b4277b2 100644 --- a/test-suite/bugs/opened/3948.v +++ b/test-suite/bugs/opened/3948.v @@ -22,4 +22,4 @@ Module DepMap : Interface. let _ := @Dom.fold in tt. End DepMap. -Print Assumptions DepMap.constant.
\ No newline at end of file +Print Assumptions DepMap.constant. diff --git a/test-suite/complexity/constructor.v b/test-suite/complexity/constructor.v new file mode 100644 index 0000000000..c5e1953829 --- /dev/null +++ b/test-suite/complexity/constructor.v @@ -0,0 +1,216 @@ +(* Checks that constructor does not repeat the reduction of the conclusion *) +(* Expected time < 3.00s *) + +(* Note: on i7 2.2GZ, time decreases from 85s to 0.1s *) + +Inductive T : bool -> Prop := +| C000 : T true | C001 : T true | C002 : T true | C003 : T true | C004 : T true +| C005 : T true | C006 : T true | C007 : T true | C008 : T true | C009 : T true +| C010 : T true | C011 : T true | C012 : T true | C013 : T true | C014 : T true +| C015 : T true | C016 : T true | C017 : T true | C018 : T true | C019 : T true +| C020 : T true | C021 : T true | C022 : T true | C023 : T true | C024 : T true +| C025 : T true | C026 : T true | C027 : T true | C028 : T true | C029 : T true +| C030 : T true | C031 : T true | C032 : T true | C033 : T true | C034 : T true +| C035 : T true | C036 : T true | C037 : T true | C038 : T true | C039 : T true +| C040 : T true | C041 : T true | C042 : T true | C043 : T true | C044 : T true +| C045 : T true | C046 : T true | C047 : T true | C048 : T true | C049 : T true +| C050 : T true | C051 : T true | C052 : T true | C053 : T true | C054 : T true +| C055 : T true | C056 : T true | C057 : T true | C058 : T true | C059 : T true +| C060 : T true | C061 : T true | C062 : T true | C063 : T true | C064 : T true +| C065 : T true | C066 : T true | C067 : T true | C068 : T true | C069 : T true +| C070 : T true | C071 : T true | C072 : T true | C073 : T true | C074 : T true +| C075 : T true | C076 : T true | C077 : T true | C078 : T true | C079 : T true +| C080 : T true | C081 : T true | C082 : T true | C083 : T true | C084 : T true +| C085 : T true | C086 : T true | C087 : T true | C088 : T true | C089 : T true +| C090 : T true | C091 : T true | C092 : T true | C093 : T true | C094 : T true +| C095 : T true | C096 : T true | C097 : T true | C098 : T true | C099 : T true +| C100 : T true | C101 : T true | C102 : T true | C103 : T true | C104 : T true +| C105 : T true | C106 : T true | C107 : T true | C108 : T true | C109 : T true +| C110 : T true | C111 : T true | C112 : T true | C113 : T true | C114 : T true +| C115 : T true | C116 : T true | C117 : T true | C118 : T true | C119 : T true +| C120 : T true | C121 : T true | C122 : T true | C123 : T true | C124 : T true +| C125 : T true | C126 : T true | C127 : T true | C128 : T true | C129 : T true +| C130 : T true | C131 : T true | C132 : T true | C133 : T true | C134 : T true +| C135 : T true | C136 : T true | C137 : T true | C138 : T true | C139 : T true +| C140 : T true | C141 : T true | C142 : T true | C143 : T true | C144 : T true +| C145 : T true | C146 : T true | C147 : T true | C148 : T true | C149 : T true +| C150 : T true | C151 : T true | C152 : T true | C153 : T true | C154 : T true +| C155 : T true | C156 : T true | C157 : T true | C158 : T true | C159 : T true +| C160 : T true | C161 : T true | C162 : T true | C163 : T true | C164 : T true +| C165 : T true | C166 : T true | C167 : T true | C168 : T true | C169 : T true +| C170 : T true | C171 : T true | C172 : T true | C173 : T true | C174 : T true +| C175 : T true | C176 : T true | C177 : T true | C178 : T true | C179 : T true +| C180 : T true | C181 : T true | C182 : T true | C183 : T true | C184 : T true +| C185 : T true | C186 : T true | C187 : T true | C188 : T true | C189 : T true +| C190 : T true | C191 : T true | C192 : T true | C193 : T true | C194 : T true +| C195 : T true | C196 : T true | C197 : T true | C198 : T true | C199 : T true +| C200 : T true | C201 : T true | C202 : T true | C203 : T true | C204 : T true +| C205 : T true | C206 : T true | C207 : T true | C208 : T true | C209 : T true +| C210 : T true | C211 : T true | C212 : T true | C213 : T true | C214 : T true +| C215 : T true | C216 : T true | C217 : T true | C218 : T true | C219 : T true +| C220 : T true | C221 : T true | C222 : T true | C223 : T true | C224 : T true +| C225 : T true | C226 : T true | C227 : T true | C228 : T true | C229 : T true +| C230 : T true | C231 : T true | C232 : T true | C233 : T true | C234 : T true +| C235 : T true | C236 : T true | C237 : T true | C238 : T true | C239 : T true +| C240 : T true | C241 : T true | C242 : T true | C243 : T true | C244 : T true +| C245 : T true | C246 : T true | C247 : T true | C248 : T true | C249 : T true +| C250 : T true | C251 : T true | C252 : T true | C253 : T true | C254 : T true +| C255 : T true | C256 : T true | C257 : T true | C258 : T true | C259 : T true +| C260 : T true | C261 : T true | C262 : T true | C263 : T true | C264 : T true +| C265 : T true | C266 : T true | C267 : T true | C268 : T true | C269 : T true +| C270 : T true | C271 : T true | C272 : T true | C273 : T true | C274 : T true +| C275 : T true | C276 : T true | C277 : T true | C278 : T true | C279 : T true +| C280 : T true | C281 : T true | C282 : T true | C283 : T true | C284 : T true +| C285 : T true | C286 : T true | C287 : T true | C288 : T true | C289 : T true +| C290 : T true | C291 : T true | C292 : T true | C293 : T true | C294 : T true +| C295 : T true | C296 : T true | C297 : T true | C298 : T true | C299 : T true +| C300 : T true | C301 : T true | C302 : T true | C303 : T true | C304 : T true +| C305 : T true | C306 : T true | C307 : T true | C308 : T true | C309 : T true +| C310 : T true | C311 : T true | C312 : T true | C313 : T true | C314 : T true +| C315 : T true | C316 : T true | C317 : T true | C318 : T true | C319 : T true +| C320 : T true | C321 : T true | C322 : T true | C323 : T true | C324 : T true +| C325 : T true | C326 : T true | C327 : T true | C328 : T true | C329 : T true +| C330 : T true | C331 : T true | C332 : T true | C333 : T true | C334 : T true +| C335 : T true | C336 : T true | C337 : T true | C338 : T true | C339 : T true +| C340 : T true | C341 : T true | C342 : T true | C343 : T true | C344 : T true +| C345 : T true | C346 : T true | C347 : T true | C348 : T true | C349 : T true +| C350 : T true | C351 : T true | C352 : T true | C353 : T true | C354 : T true +| C355 : T true | C356 : T true | C357 : T true | C358 : T true | C359 : T true +| C360 : T true | C361 : T true | C362 : T true | C363 : T true | C364 : T true +| C365 : T true | C366 : T true | C367 : T true | C368 : T true | C369 : T true +| C370 : T true | C371 : T true | C372 : T true | C373 : T true | C374 : T true +| C375 : T true | C376 : T true | C377 : T true | C378 : T true | C379 : T true +| C380 : T true | C381 : T true | C382 : T true | C383 : T true | C384 : T true +| C385 : T true | C386 : T true | C387 : T true | C388 : T true | C389 : T true +| C390 : T true | C391 : T true | C392 : T true | C393 : T true | C394 : T true +| C395 : T true | C396 : T true | C397 : T true | C398 : T true | C399 : T true +| C400 : T true | C401 : T true | C402 : T true | C403 : T true | C404 : T true +| C405 : T true | C406 : T true | C407 : T true | C408 : T true | C409 : T true +| C410 : T true | C411 : T true | C412 : T true | C413 : T true | C414 : T true +| C415 : T true | C416 : T true | C417 : T true | C418 : T true | C419 : T true +| C420 : T true | C421 : T true | C422 : T true | C423 : T true | C424 : T true +| C425 : T true | C426 : T true | C427 : T true | C428 : T true | C429 : T true +| C430 : T true | C431 : T true | C432 : T true | C433 : T true | C434 : T true +| C435 : T true | C436 : T true | C437 : T true | C438 : T true | C439 : T true +| C440 : T true | C441 : T true | C442 : T true | C443 : T true | C444 : T true +| C445 : T true | C446 : T true | C447 : T true | C448 : T true | C449 : T true +| C450 : T true | C451 : T true | C452 : T true | C453 : T true | C454 : T true +| C455 : T true | C456 : T true | C457 : T true | C458 : T true | C459 : T true +| C460 : T true | C461 : T true | C462 : T true | C463 : T true | C464 : T true +| C465 : T true | C466 : T true | C467 : T true | C468 : T true | C469 : T true +| C470 : T true | C471 : T true | C472 : T true | C473 : T true | C474 : T true +| C475 : T true | C476 : T true | C477 : T true | C478 : T true | C479 : T true +| C480 : T true | C481 : T true | C482 : T true | C483 : T true | C484 : T true +| C485 : T true | C486 : T true | C487 : T true | C488 : T true | C489 : T true +| C490 : T true | C491 : T true | C492 : T true | C493 : T true | C494 : T true +| C495 : T true | C496 : T true | C497 : T true | C498 : T true | C499 : T true +| C500 : T true | C501 : T true | C502 : T true | C503 : T true | C504 : T true +| C505 : T true | C506 : T true | C507 : T true | C508 : T true | C509 : T true +| C510 : T true | C511 : T true | C512 : T true | C513 : T true | C514 : T true +| C515 : T true | C516 : T true | C517 : T true | C518 : T true | C519 : T true +| C520 : T true | C521 : T true | C522 : T true | C523 : T true | C524 : T true +| C525 : T true | C526 : T true | C527 : T true | C528 : T true | C529 : T true +| C530 : T true | C531 : T true | C532 : T true | C533 : T true | C534 : T true +| C535 : T true | C536 : T true | C537 : T true | C538 : T true | C539 : T true +| C540 : T true | C541 : T true | C542 : T true | C543 : T true | C544 : T true +| C545 : T true | C546 : T true | C547 : T true | C548 : T true | C549 : T true +| C550 : T true | C551 : T true | C552 : T true | C553 : T true | C554 : T true +| C555 : T true | C556 : T true | C557 : T true | C558 : T true | C559 : T true +| C560 : T true | C561 : T true | C562 : T true | C563 : T true | C564 : T true +| C565 : T true | C566 : T true | C567 : T true | C568 : T true | C569 : T true +| C570 : T true | C571 : T true | C572 : T true | C573 : T true | C574 : T true +| C575 : T true | C576 : T true | C577 : T true | C578 : T true | C579 : T true +| C580 : T true | C581 : T true | C582 : T true | C583 : T true | C584 : T true +| C585 : T true | C586 : T true | C587 : T true | C588 : T true | C589 : T true +| C590 : T true | C591 : T true | C592 : T true | C593 : T true | C594 : T true +| C595 : T true | C596 : T true | C597 : T true | C598 : T true | C599 : T true +| C600 : T true | C601 : T true | C602 : T true | C603 : T true | C604 : T true +| C605 : T true | C606 : T true | C607 : T true | C608 : T true | C609 : T true +| C610 : T true | C611 : T true | C612 : T true | C613 : T true | C614 : T true +| C615 : T true | C616 : T true | C617 : T true | C618 : T true | C619 : T true +| C620 : T true | C621 : T true | C622 : T true | C623 : T true | C624 : T true +| C625 : T true | C626 : T true | C627 : T true | C628 : T true | C629 : T true +| C630 : T true | C631 : T true | C632 : T true | C633 : T true | C634 : T true +| C635 : T true | C636 : T true | C637 : T true | C638 : T true | C639 : T true +| C640 : T true | C641 : T true | C642 : T true | C643 : T true | C644 : T true +| C645 : T true | C646 : T true | C647 : T true | C648 : T true | C649 : T true +| C650 : T true | C651 : T true | C652 : T true | C653 : T true | C654 : T true +| C655 : T true | C656 : T true | C657 : T true | C658 : T true | C659 : T true +| C660 : T true | C661 : T true | C662 : T true | C663 : T true | C664 : T true +| C665 : T true | C666 : T true | C667 : T true | C668 : T true | C669 : T true +| C670 : T true | C671 : T true | C672 : T true | C673 : T true | C674 : T true +| C675 : T true | C676 : T true | C677 : T true | C678 : T true | C679 : T true +| C680 : T true | C681 : T true | C682 : T true | C683 : T true | C684 : T true +| C685 : T true | C686 : T true | C687 : T true | C688 : T true | C689 : T true +| C690 : T true | C691 : T true | C692 : T true | C693 : T true | C694 : T true +| C695 : T true | C696 : T true | C697 : T true | C698 : T true | C699 : T true +| C700 : T true | C701 : T true | C702 : T true | C703 : T true | C704 : T true +| C705 : T true | C706 : T true | C707 : T true | C708 : T true | C709 : T true +| C710 : T true | C711 : T true | C712 : T true | C713 : T true | C714 : T true +| C715 : T true | C716 : T true | C717 : T true | C718 : T true | C719 : T true +| C720 : T true | C721 : T true | C722 : T true | C723 : T true | C724 : T true +| C725 : T true | C726 : T true | C727 : T true | C728 : T true | C729 : T true +| C730 : T true | C731 : T true | C732 : T true | C733 : T true | C734 : T true +| C735 : T true | C736 : T true | C737 : T true | C738 : T true | C739 : T true +| C740 : T true | C741 : T true | C742 : T true | C743 : T true | C744 : T true +| C745 : T true | C746 : T true | C747 : T true | C748 : T true | C749 : T true +| C750 : T true | C751 : T true | C752 : T true | C753 : T true | C754 : T true +| C755 : T true | C756 : T true | C757 : T true | C758 : T true | C759 : T true +| C760 : T true | C761 : T true | C762 : T true | C763 : T true | C764 : T true +| C765 : T true | C766 : T true | C767 : T true | C768 : T true | C769 : T true +| C770 : T true | C771 : T true | C772 : T true | C773 : T true | C774 : T true +| C775 : T true | C776 : T true | C777 : T true | C778 : T true | C779 : T true +| C780 : T true | C781 : T true | C782 : T true | C783 : T true | C784 : T true +| C785 : T true | C786 : T true | C787 : T true | C788 : T true | C789 : T true +| C790 : T true | C791 : T true | C792 : T true | C793 : T true | C794 : T true +| C795 : T true | C796 : T true | C797 : T true | C798 : T true | C799 : T true +| C800 : T true | C801 : T true | C802 : T true | C803 : T true | C804 : T true +| C805 : T true | C806 : T true | C807 : T true | C808 : T true | C809 : T true +| C810 : T true | C811 : T true | C812 : T true | C813 : T true | C814 : T true +| C815 : T true | C816 : T true | C817 : T true | C818 : T true | C819 : T true +| C820 : T true | C821 : T true | C822 : T true | C823 : T true | C824 : T true +| C825 : T true | C826 : T true | C827 : T true | C828 : T true | C829 : T true +| C830 : T true | C831 : T true | C832 : T true | C833 : T true | C834 : T true +| C835 : T true | C836 : T true | C837 : T true | C838 : T true | C839 : T true +| C840 : T true | C841 : T true | C842 : T true | C843 : T true | C844 : T true +| C845 : T true | C846 : T true | C847 : T true | C848 : T true | C849 : T true +| C850 : T true | C851 : T true | C852 : T true | C853 : T true | C854 : T true +| C855 : T true | C856 : T true | C857 : T true | C858 : T true | C859 : T true +| C860 : T true | C861 : T true | C862 : T true | C863 : T true | C864 : T true +| C865 : T true | C866 : T true | C867 : T true | C868 : T true | C869 : T true +| C870 : T true | C871 : T true | C872 : T true | C873 : T true | C874 : T true +| C875 : T true | C876 : T true | C877 : T true | C878 : T true | C879 : T true +| C880 : T true | C881 : T true | C882 : T true | C883 : T true | C884 : T true +| C885 : T true | C886 : T true | C887 : T true | C888 : T true | C889 : T true +| C890 : T true | C891 : T true | C892 : T true | C893 : T true | C894 : T true +| C895 : T true | C896 : T true | C897 : T true | C898 : T true | C899 : T true +| C900 : T true | C901 : T true | C902 : T true | C903 : T true | C904 : T true +| C905 : T true | C906 : T true | C907 : T true | C908 : T true | C909 : T true +| C910 : T true | C911 : T true | C912 : T true | C913 : T true | C914 : T true +| C915 : T true | C916 : T true | C917 : T true | C918 : T true | C919 : T true +| C920 : T true | C921 : T true | C922 : T true | C923 : T true | C924 : T true +| C925 : T true | C926 : T true | C927 : T true | C928 : T true | C929 : T true +| C930 : T true | C931 : T true | C932 : T true | C933 : T true | C934 : T true +| C935 : T true | C936 : T true | C937 : T true | C938 : T true | C939 : T true +| C940 : T true | C941 : T true | C942 : T true | C943 : T true | C944 : T true +| C945 : T true | C946 : T true | C947 : T true | C948 : T true | C949 : T true +| C950 : T true | C951 : T true | C952 : T true | C953 : T true | C954 : T true +| C955 : T true | C956 : T true | C957 : T true | C958 : T true | C959 : T true +| C960 : T true | C961 : T true | C962 : T true | C963 : T true | C964 : T true +| C965 : T true | C966 : T true | C967 : T true | C968 : T true | C969 : T true +| C970 : T true | C971 : T true | C972 : T true | C973 : T true | C974 : T true +| C975 : T true | C976 : T true | C977 : T true | C978 : T true | C979 : T true +| C980 : T true | C981 : T true | C982 : T true | C983 : T true | C984 : T true +| C985 : T true | C986 : T true | C987 : T true | C988 : T true | C989 : T true +| C990 : T true | C991 : T true | C992 : T true | C993 : T true | C994 : T true +| C995 : T true | C996 : T true | C997 : T true | C998 : T true | C999 : T true +| C1000 : T false. + +Fixpoint expand (n : nat) : Prop := + match n with + | O => T false + | S n => expand n + end. + +Example Expand : expand 2500. +Time constructor. (* ~0.45 secs *) diff --git a/test-suite/coq-makefile/template/init.sh b/test-suite/coq-makefile/template/init.sh index 803fe8029a..c4bd11c57d 100755 --- a/test-suite/coq-makefile/template/init.sh +++ b/test-suite/coq-makefile/template/init.sh @@ -2,6 +2,7 @@ set -e set -o pipefail export PATH=$COQBIN:$PATH +export LC_ALL=C rm -rf theories src Makefile Makefile.conf tmp git clean -dfx || true diff --git a/test-suite/coqchk/cumulativity.v b/test-suite/coqchk/cumulativity.v index 7906a5b15e..d63a3548e5 100644 --- a/test-suite/coqchk/cumulativity.v +++ b/test-suite/coqchk/cumulativity.v @@ -64,4 +64,4 @@ I disable these tests because cqochk can't process them when compiled with (* Inductive TP2 := tp2 : Type@{i} -> Type@{j} -> TP2. *) -(* End subtyping_test. *)
\ No newline at end of file +(* End subtyping_test. *) diff --git a/test-suite/coqdoc/bug5700.html.out b/test-suite/coqdoc/bug5700.html.out new file mode 100644 index 0000000000..0e05660d6c --- /dev/null +++ b/test-suite/coqdoc/bug5700.html.out @@ -0,0 +1,50 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" +"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1" /> +<link href="coqdoc.css" rel="stylesheet" type="text/css" /> +<title>Coqdoc.bug5700</title> +</head> + +<body> + +<div id="page"> + +<div id="header"> +</div> + +<div id="main"> + +<h1 class="libtitle">Library Coqdoc.bug5700</h1> + +<div class="code"> +</div> + +<div class="doc"> +<pre>foo (* bar *) </pre> + +</div> +<div class="code"> +<span class="id" title="keyword">Definition</span> <a name="const1"><span class="id" title="definition">const1</span></a> := 1.<br/> + +<br/> +</div> + +<div class="doc"> +<pre>more (* nested (* comments *) within verbatim *) </pre> + +</div> +<div class="code"> +<span class="id" title="keyword">Definition</span> <a name="const2"><span class="id" title="definition">const2</span></a> := 2.<br/> +</div> +</div> + +<div id="footer"> +<hr/><a href="index.html">Index</a><hr/>This page has been generated by <a href="http://coq.inria.fr/">coqdoc</a> +</div> + +</div> + +</body> +</html>
\ No newline at end of file diff --git a/test-suite/coqdoc/bug5700.tex.out b/test-suite/coqdoc/bug5700.tex.out new file mode 100644 index 0000000000..33990cb89f --- /dev/null +++ b/test-suite/coqdoc/bug5700.tex.out @@ -0,0 +1,24 @@ +\documentclass[12pt]{report} +\usepackage[]{inputenc} +\usepackage[T1]{fontenc} +\usepackage{fullpage} +\usepackage{coqdoc} +\usepackage{amsmath,amssymb} +\usepackage{url} +\begin{document} +\coqlibrary{Coqdoc.bug5700}{Library }{Coqdoc.bug5700} + +\begin{coqdoccode} +\end{coqdoccode} +\begin{verbatim}foo (* bar *) \end{verbatim} + \begin{coqdoccode} +\coqdocnoindent +\coqdockw{Definition} \coqdef{Coqdoc.bug5700.const1}{const1}{\coqdocdefinition{const1}} := 1.\coqdoceol +\coqdocemptyline +\end{coqdoccode} +\begin{verbatim}more (* nested (* comments *) within verbatim *) \end{verbatim} + \begin{coqdoccode} +\coqdocnoindent +\coqdockw{Definition} \coqdef{Coqdoc.bug5700.const2}{const2}{\coqdocdefinition{const2}} := 2.\coqdoceol +\end{coqdoccode} +\end{document} diff --git a/test-suite/coqdoc/bug5700.v b/test-suite/coqdoc/bug5700.v new file mode 100644 index 0000000000..839034a48f --- /dev/null +++ b/test-suite/coqdoc/bug5700.v @@ -0,0 +1,5 @@ +(** << foo (* bar *) >> *) +Definition const1 := 1. + +(** << more (* nested (* comments *) within verbatim *) >> *) +Definition const2 := 2. diff --git a/test-suite/failure/circular_subtyping.v b/test-suite/failure/circular_subtyping.v index ceccd4607d..9eb7e3bc20 100644 --- a/test-suite/failure/circular_subtyping.v +++ b/test-suite/failure/circular_subtyping.v @@ -7,4 +7,4 @@ Module NN <: T. Module M:=N. End NN. Fail Module P <: T with Module M:=NN := NN. Module F (X:S) (Y:T with Module M:=X). End F. -Fail Module G := F N N.
\ No newline at end of file +Fail Module G := F N N. diff --git a/test-suite/failure/cofixpoint.v b/test-suite/failure/cofixpoint.v index cb39893f47..d193dc484f 100644 --- a/test-suite/failure/cofixpoint.v +++ b/test-suite/failure/cofixpoint.v @@ -12,4 +12,4 @@ Fail CoFixpoint loop : CoFalse := (cofix f := I with g := loop for g). Fail CoFixpoint loop : CoFalse := - (cofix f := loop with g := I for f).
\ No newline at end of file + (cofix f := loop with g := I for f). diff --git a/test-suite/failure/guard-cofix.v b/test-suite/failure/guard-cofix.v index eda4a18673..3ae8770546 100644 --- a/test-suite/failure/guard-cofix.v +++ b/test-suite/failure/guard-cofix.v @@ -40,4 +40,4 @@ Fail CoFixpoint loop' : CoFalse := Omega match eq_sym H in _ = T return T with eq_refl => loop' end end. -Fail Definition ff' : False := match loop' with CF _ t => t end.
\ No newline at end of file +Fail Definition ff' : False := match loop' with CF _ t => t end. diff --git a/test-suite/failure/sortelim.v b/test-suite/failure/sortelim.v index 2b3cf10660..3d2eef6a98 100644 --- a/test-suite/failure/sortelim.v +++ b/test-suite/failure/sortelim.v @@ -146,4 +146,4 @@ Qed. Print Assumptions pandora. -*)
\ No newline at end of file +*) diff --git a/test-suite/ideal-features/implicit_binders.v b/test-suite/ideal-features/implicit_binders.v index 2ec7278080..d75620c257 100644 --- a/test-suite/ideal-features/implicit_binders.v +++ b/test-suite/ideal-features/implicit_binders.v @@ -121,4 +121,4 @@ Definition qux₁ {( F : `(SomeStruct a) )} : nat := 0. (** *** Questions - Autres propositions de syntaxe ? - Réactions sur la construction ? - *)
\ No newline at end of file + *) diff --git a/test-suite/interactive/ParalITP.v b/test-suite/interactive/ParalITP.v index a96d4a5c7f..7fab2a58e8 100644 --- a/test-suite/interactive/ParalITP.v +++ b/test-suite/interactive/ParalITP.v @@ -44,4 +44,4 @@ split. exact a. Qed. -End Demo.
\ No newline at end of file +End Demo. diff --git a/test-suite/interactive/proof_block.v b/test-suite/interactive/proof_block.v index 31e3493768..a865632e8c 100644 --- a/test-suite/interactive/proof_block.v +++ b/test-suite/interactive/proof_block.v @@ -63,4 +63,4 @@ split. split. split. - solve [ trivial ]. - solve [ trivial ]. - exact 6. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/modules/Demo.v b/test-suite/modules/Demo.v index 1f27fe1ba1..820fda172a 100644 --- a/test-suite/modules/Demo.v +++ b/test-suite/modules/Demo.v @@ -52,4 +52,4 @@ Print N'''.x. Import N'''. -Print t.
\ No newline at end of file +Print t. diff --git a/test-suite/modules/Nat.v b/test-suite/modules/Nat.v index 57878a5f15..d2116d2183 100644 --- a/test-suite/modules/Nat.v +++ b/test-suite/modules/Nat.v @@ -16,4 +16,4 @@ Qed. Lemma le_antis : forall n m : nat, le n m -> le m n -> n = m. eauto with arith. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/modules/PO.v b/test-suite/modules/PO.v index 6198f29a0d..8ba8525c66 100644 --- a/test-suite/modules/PO.v +++ b/test-suite/modules/PO.v @@ -54,4 +54,4 @@ Module NN := Pair Nat Nat. Lemma zz_min : forall p : NN.T, NN.le (0, 0) p. info auto with arith. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/modules/Tescik.v b/test-suite/modules/Tescik.v index 1d1b1e0ab2..ea49553942 100644 --- a/test-suite/modules/Tescik.v +++ b/test-suite/modules/Tescik.v @@ -27,4 +27,4 @@ Module List (X: ELEM). End List. -Module N := List Nat.
\ No newline at end of file +Module N := List Nat. diff --git a/test-suite/modules/grammar.v b/test-suite/modules/grammar.v index 9657c685d0..11ad205e40 100644 --- a/test-suite/modules/grammar.v +++ b/test-suite/modules/grammar.v @@ -12,4 +12,4 @@ Check (f 0 0). Check (f 0 0). Import M. Check (f 0 0). -Check (N.f 0 0).
\ No newline at end of file +Check (N.f 0 0). diff --git a/test-suite/modules/injection_discriminate_inversion.v b/test-suite/modules/injection_discriminate_inversion.v index d4ac7b3a24..8b5969dd76 100644 --- a/test-suite/modules/injection_discriminate_inversion.v +++ b/test-suite/modules/injection_discriminate_inversion.v @@ -31,4 +31,4 @@ Goal forall x, M.C x = M1.C 0 -> x = 0. par des modules differents *) inversion H. reflexivity. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/modules/modeq.v b/test-suite/modules/modeq.v index 1238ee9deb..c8129eec5e 100644 --- a/test-suite/modules/modeq.v +++ b/test-suite/modules/modeq.v @@ -19,4 +19,4 @@ Module Z. Module N := M. End Z. -Module A : SIG := Z.
\ No newline at end of file +Module A : SIG := Z. diff --git a/test-suite/modules/pliczek.v b/test-suite/modules/pliczek.v index f806a7c412..51f5f40078 100644 --- a/test-suite/modules/pliczek.v +++ b/test-suite/modules/pliczek.v @@ -1,3 +1,3 @@ Require Export plik. -Definition tutu (X : Set) := toto X.
\ No newline at end of file +Definition tutu (X : Set) := toto X. diff --git a/test-suite/modules/plik.v b/test-suite/modules/plik.v index 50bfd96046..c2f0fe3cee 100644 --- a/test-suite/modules/plik.v +++ b/test-suite/modules/plik.v @@ -1,3 +1,3 @@ Definition toto (x : Set) := x. -(* <Warning> : Grammar is replaced by Notation *)
\ No newline at end of file +(* <Warning> : Grammar is replaced by Notation *) diff --git a/test-suite/modules/pseudo_circular_with.v b/test-suite/modules/pseudo_circular_with.v index 9e46d17ed9..6bf067fd18 100644 --- a/test-suite/modules/pseudo_circular_with.v +++ b/test-suite/modules/pseudo_circular_with.v @@ -3,4 +3,4 @@ Module Type T. Declare Module M:S. End T. Module N:S. End N. Module NN:T. Module M:=N. End NN. -Module Type U := T with Module M:=NN.
\ No newline at end of file +Module Type U := T with Module M:=NN. diff --git a/test-suite/modules/sig.v b/test-suite/modules/sig.v index da5d25fa2e..fc936a515a 100644 --- a/test-suite/modules/sig.v +++ b/test-suite/modules/sig.v @@ -26,4 +26,4 @@ Module Type SIG. Parameter x : T. End SIG. -Module J : SIG := M.N.
\ No newline at end of file +Module J : SIG := M.N. diff --git a/test-suite/output/CompactContexts.v b/test-suite/output/CompactContexts.v index 07588d34f9..c409c0ee46 100644 --- a/test-suite/output/CompactContexts.v +++ b/test-suite/output/CompactContexts.v @@ -2,4 +2,4 @@ Set Printing Compact Contexts. Lemma f (hP1:True) (a:nat) (b:list nat) (h:forall (x:nat) , { y:nat | y > x}) (h2:True): False. Show. -Abort.
\ No newline at end of file +Abort. diff --git a/test-suite/output/Notations.out b/test-suite/output/Notations.out index 9d106d2dac..7bcd7b041c 100644 --- a/test-suite/output/Notations.out +++ b/test-suite/output/Notations.out @@ -133,3 +133,5 @@ fun (x : nat) (p : x = x) => match p with | 1 => 1 end = p : forall x : nat, x = x -> Prop +bar 0 + : nat diff --git a/test-suite/output/Notations.v b/test-suite/output/Notations.v index b9985a594f..fe6c05c39e 100644 --- a/test-suite/output/Notations.v +++ b/test-suite/output/Notations.v @@ -291,3 +291,11 @@ Check fun (x:nat) (p : x=x) => match p with ONE => ONE end = p. Notation "1" := eq_refl. Check fun (x:nat) (p : x=x) => match p with 1 => 1 end = p. +(* Check bug 5693 *) + +Module M. +Definition A := 0. +Definition bar (a b : nat) := plus a b. +Notation "" := A (format "", only printing). +Check (bar A 0). +End M. diff --git a/test-suite/output/Notations3.out b/test-suite/output/Notations3.out index e5dbfcb4be..65efe228af 100644 --- a/test-suite/output/Notations3.out +++ b/test-suite/output/Notations3.out @@ -122,3 +122,5 @@ return (1, 2, 3, 4) : nat * nat * nat * nat {{ 1 | 1 // 1 }} : nat +!!! _ _ : nat, True + : (nat -> Prop) * ((nat -> Prop) * Prop) diff --git a/test-suite/output/Notations3.v b/test-suite/output/Notations3.v index b1015137d6..ea372ad1a3 100644 --- a/test-suite/output/Notations3.v +++ b/test-suite/output/Notations3.v @@ -186,3 +186,7 @@ Check letpair x [1] = {0}; return (1,2,3,4). Notation "{ { xL | xR // xcut } }" := (xL+xR+xcut) (at level 0, xR at level 39, format "{ { xL | xR // xcut } }"). Check 1+1+1. + +(* Test presence of notation variables in the recursive parts (introduced in dfdaf4de) *) +Notation "!!! x .. y , b" := ((fun x => b), .. ((fun y => b), True) ..) (at level 200, x binder). +Check !!! (x y:nat), True. diff --git a/test-suite/output/SearchPattern.v b/test-suite/output/SearchPattern.v index bde195a511..de9f48873a 100644 --- a/test-suite/output/SearchPattern.v +++ b/test-suite/output/SearchPattern.v @@ -33,4 +33,4 @@ Goal forall n (P:nat -> Prop), P n -> ~P n -> False. Search (P _) -"h'". (* search hypothesis also for patterns *) Search (P _) -not. (* search hypothesis also for patterns *) -Abort.
\ No newline at end of file +Abort. diff --git a/test-suite/output/UnivBinders.out b/test-suite/output/UnivBinders.out index 128bc77673..904ff68aa7 100644 --- a/test-suite/output/UnivBinders.out +++ b/test-suite/output/UnivBinders.out @@ -4,3 +4,9 @@ bar@{u} = nat *) bar is universe polymorphic +foo@{u Top.8 v} = +Type@{Top.8} -> Type@{v} -> Type@{u} + : Type@{max(u+1, Top.8+1, v+1)} +(* u Top.8 v |= *) + +foo is universe polymorphic diff --git a/test-suite/output/UnivBinders.v b/test-suite/output/UnivBinders.v index d9e89e43c6..8656ff1a39 100644 --- a/test-suite/output/UnivBinders.v +++ b/test-suite/output/UnivBinders.v @@ -1,7 +1,13 @@ Set Universe Polymorphism. Set Printing Universes. +Unset Strict Universe Declaration. Class Wrap A := wrap : A. Instance bar@{u} : Wrap@{u} Set. Proof nat. Print bar. + +(* The universes in the binder come first, then the extra universes in + order of appearance. *) +Definition foo@{u +} := Type -> Type@{v} -> Type@{u}. +Print foo. diff --git a/test-suite/output/ltac_missing_args.v b/test-suite/output/ltac_missing_args.v index 8ecd97aa56..91331a1de5 100644 --- a/test-suite/output/ltac_missing_args.v +++ b/test-suite/output/ltac_missing_args.v @@ -16,4 +16,4 @@ Goal True. Fail (fun _ => idtac). Fail rec True. Fail let rec tac x := tac in tac True. -Abort.
\ No newline at end of file +Abort. diff --git a/test-suite/success/Inductive.v b/test-suite/success/Inductive.v index f746def5cb..06f807f29a 100644 --- a/test-suite/success/Inductive.v +++ b/test-suite/success/Inductive.v @@ -183,3 +183,20 @@ Module PolyNoLowerProp. Fail Check Foo True : Prop. End PolyNoLowerProp. + +(* Test building of elimination scheme with noth let-ins and + non-recursively uniform parameters *) + +Module NonRecLetIn. + + Unset Implicit Arguments. + + Inductive Ind (b:=2) (a:nat) (c:=1) : Type := + | Base : Ind a + | Rec : Ind (S a) -> Ind a. + + Check Ind_rect (fun n (b:Ind n) => b = b) + (fun n => eq_refl) + (fun n b c => f_equal (Rec n) eq_refl) 0 (Rec 0 (Base 1)). + +End NonRecLetIn. diff --git a/test-suite/success/Notations.v b/test-suite/success/Notations.v index 837f2efd06..4d04f2cf9b 100644 --- a/test-suite/success/Notations.v +++ b/test-suite/success/Notations.v @@ -142,3 +142,8 @@ Fail Notation "'foobarkeyword'" := (@nil) (only parsing, only printing). Reserved Notation "x === y" (at level 50). Inductive EQ {A} (x:A) : A -> Prop := REFL : x === x where "x === y" := (EQ x y). + +(* Check that strictly ident or _ are coerced to a name *) + +Fail Check {x@{u},y|x=x}. +Fail Check {?[n],y|0=0}. diff --git a/test-suite/success/ProgramWf.v b/test-suite/success/ProgramWf.v index 681c4716b6..85d7a770fc 100644 --- a/test-suite/success/ProgramWf.v +++ b/test-suite/success/ProgramWf.v @@ -102,4 +102,4 @@ Qed. Program Fixpoint check_n' (n : nat) (m : {m:nat | m = n}) (p : nat) (q:{q : nat | q = p}) {measure (p - n) p} : nat := - _.
\ No newline at end of file + _. diff --git a/test-suite/success/cbn.v b/test-suite/success/cbn.v index 6aeb05f54e..c98689c234 100644 --- a/test-suite/success/cbn.v +++ b/test-suite/success/cbn.v @@ -15,4 +15,4 @@ Goal forall n, foo (S n) = g n. match goal with |- g _ = g _ => reflexivity end. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/success/clear.v b/test-suite/success/clear.v index e25510cf09..03034cf130 100644 --- a/test-suite/success/clear.v +++ b/test-suite/success/clear.v @@ -30,4 +30,4 @@ Section Foo. assert(b:=Build_A). solve [ typeclasses eauto ]. Qed. -End Foo.
\ No newline at end of file +End Foo. diff --git a/test-suite/success/coercions.v b/test-suite/success/coercions.v index b538d2ed27..9b11bc011c 100644 --- a/test-suite/success/coercions.v +++ b/test-suite/success/coercions.v @@ -130,4 +130,4 @@ Local Coercion l2v2 : list >-> vect. of coercions *) Fail Check (fun l : list (T1 * T1) => (l : vect _ _)). Check (fun l : list (T1 * T1) => (l2v2 l : vect _ _)). -Section what_we_could_do.
\ No newline at end of file +Section what_we_could_do. diff --git a/test-suite/success/guard.v b/test-suite/success/guard.v index b9181d430a..83d47dc683 100644 --- a/test-suite/success/guard.v +++ b/test-suite/success/guard.v @@ -9,3 +9,20 @@ Check let x (f:nat->nat) k := f k in | 0 => 0 | S k => f F k (* here Rel 3 = F ! *) end. + +(** Commutation of guard condition allows recursive calls on functional arguments, + despite rewriting in their domain types. *) +Inductive foo : Type -> Type := +| End A : foo A +| Next A : (A -> foo A) -> foo A. + +Definition nat : Type := nat. + +Fixpoint bar (A : Type) (e : nat = A) (f : foo A) {struct f} : nat := +match f with +| End _ => fun _ => O +| Next A g => fun e => + match e in (_ = B) return (B -> foo A) -> nat with + | eq_refl => fun (g' : nat -> foo A) => bar A e (g' O) + end g +end e.
\ No newline at end of file diff --git a/test-suite/success/hintdb_in_ltac_bis.v b/test-suite/success/hintdb_in_ltac_bis.v index f5c25540ef..2bc3f9d22a 100644 --- a/test-suite/success/hintdb_in_ltac_bis.v +++ b/test-suite/success/hintdb_in_ltac_bis.v @@ -12,4 +12,4 @@ Goal Foo. progress foo mybase. Undo. progress bar mybase. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/success/indelim.v b/test-suite/success/indelim.v index 91b6dee2ec..a962c29f44 100644 --- a/test-suite/success/indelim.v +++ b/test-suite/success/indelim.v @@ -58,4 +58,4 @@ Inductive color := Red | Black. Inductive option (A : Type) : Type := | None : option A -| Some : A -> option A.
\ No newline at end of file +| Some : A -> option A. diff --git a/test-suite/success/keyedrewrite.v b/test-suite/success/keyedrewrite.v index b88c142be1..5638a7d3eb 100644 --- a/test-suite/success/keyedrewrite.v +++ b/test-suite/success/keyedrewrite.v @@ -59,4 +59,4 @@ Qed. Lemma test b : b && true = b. Fail rewrite andb_true_l. Admitted. -
\ No newline at end of file + diff --git a/test-suite/success/ltac_match_pattern_names.v b/test-suite/success/ltac_match_pattern_names.v index 7363294960..790cd1b3a7 100644 --- a/test-suite/success/ltac_match_pattern_names.v +++ b/test-suite/success/ltac_match_pattern_names.v @@ -25,4 +25,4 @@ Ltac multiple_branches := let P := fresh P in let Q := fresh Q in idtac - end.
\ No newline at end of file + end. diff --git a/test-suite/success/ltac_plus.v b/test-suite/success/ltac_plus.v index 8a08d64650..01d477bdf9 100644 --- a/test-suite/success/ltac_plus.v +++ b/test-suite/success/ltac_plus.v @@ -9,4 +9,4 @@ Proof. Fail ((apply h0+apply h2) || apply h1); apply h3. (* interaction with || *) ((apply h0+apply h1) || apply h2); apply h3. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/success/polymorphism.v b/test-suite/success/polymorphism.v index ecc988507c..7eaafc3545 100644 --- a/test-suite/success/polymorphism.v +++ b/test-suite/success/polymorphism.v @@ -156,6 +156,52 @@ Polymorphic Definition twoprojs (d : dyn) := dyn_proof d = dyn_proof d. End structures. + +Module binders. + + Definition mynat@{|} := nat. + + Definition foo@{i j | i < j, i < j} (A : Type@{i}) : Type@{j}. + exact A. + Defined. + + Definition nomoreu@{i j | i < j +} (A : Type@{i}) : Type@{j}. + pose(foo:=Type). + exact A. + Fail Defined. + Abort. + + Polymorphic Definition moreu@{i j +} (A : Type@{i}) : Type@{j}. + pose(foo:=Type). + exact A. + Defined. + + Check moreu@{_ _ _ _}. + + Fail Definition morec@{i j|} (A : Type@{i}) : Type@{j} := A. + + (* By default constraints are extensible *) + Polymorphic Definition morec@{i j} (A : Type@{i}) : Type@{j} := A. + Check morec@{_ _}. + + (* Handled in proofs as well *) + Lemma bar@{i j | } : Type@{i}. + exact Type@{j}. + Fail Defined. + Abort. + + Lemma bar@{i j| i < j} : Type@{j}. + Proof. + exact Type@{i}. + Qed. + + Lemma barext@{i j|+} : Type@{j}. + Proof. + exact Type@{i}. + Qed. + +End binders. + Section cats. Local Set Universe Polymorphism. Require Import Utf8. diff --git a/test-suite/success/programequality.v b/test-suite/success/programequality.v index 414c572f81..05f4a71856 100644 --- a/test-suite/success/programequality.v +++ b/test-suite/success/programequality.v @@ -10,4 +10,4 @@ Proof. pi_eq_proofs. clear e. destruct e'. simpl. change (P a eq_refl). -Abort.
\ No newline at end of file +Abort. diff --git a/test-suite/success/qed_export.v b/test-suite/success/qed_export.v deleted file mode 100644 index b3e41ab1fb..0000000000 --- a/test-suite/success/qed_export.v +++ /dev/null @@ -1,18 +0,0 @@ -Lemma a : True. -Proof. -assert True as H. - abstract (trivial) using exported_seff. -exact H. -Fail Qed exporting a_subproof. -Qed exporting exported_seff. -Check ( exported_seff : True ). - -Lemma b : True. -Proof. -assert True as H. - abstract (trivial) using exported_seff2. -exact H. -Qed. - -Fail Check ( exported_seff2 : True ). - diff --git a/test-suite/success/rewrite_dep.v b/test-suite/success/rewrite_dep.v index d0aafd3833..d73864e4e0 100644 --- a/test-suite/success/rewrite_dep.v +++ b/test-suite/success/rewrite_dep.v @@ -31,4 +31,4 @@ Proof. intros. rewrite H0. reflexivity. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/success/rewrite_strat.v b/test-suite/success/rewrite_strat.v index 04c675563e..a6e59fdda0 100644 --- a/test-suite/success/rewrite_strat.v +++ b/test-suite/success/rewrite_strat.v @@ -50,4 +50,4 @@ Proof. Time Qed. (* 0.06 s *) Set Printing All. -Set Printing Depth 100000.
\ No newline at end of file +Set Printing Depth 100000. diff --git a/test-suite/success/univers.v b/test-suite/success/univers.v index 269359ae62..fc74225d76 100644 --- a/test-suite/success/univers.v +++ b/test-suite/success/univers.v @@ -76,4 +76,4 @@ End Ind. Module Rec. Record box_in : myType := BoxIn { coord :> nat * nat; _ : is_box_in_shape coord }. -End Rec.
\ No newline at end of file +End Rec. diff --git a/test-suite/typeclasses/deftwice.v b/test-suite/typeclasses/deftwice.v index 439782c9e5..1394477027 100644 --- a/test-suite/typeclasses/deftwice.v +++ b/test-suite/typeclasses/deftwice.v @@ -6,4 +6,4 @@ Instance inhab_C : C Type := Inhab. Variable full : forall A (X : C A), forall x : A, c x. -Definition truc {A : Type} : Inhab A := (full _ _ _).
\ No newline at end of file +Definition truc {A : Type} : Inhab A := (full _ _ _). diff --git a/test-suite/typeclasses/unification_delta.v b/test-suite/typeclasses/unification_delta.v index 663a837f36..518912433d 100644 --- a/test-suite/typeclasses/unification_delta.v +++ b/test-suite/typeclasses/unification_delta.v @@ -43,4 +43,4 @@ Proof. (* Breaks if too much delta in unification *) rewrite H. reflexivity. -Qed.
\ No newline at end of file +Qed. diff --git a/theories/Arith/Peano_dec.v b/theories/Arith/Peano_dec.v index 88cda79d82..247ea20a88 100644 --- a/theories/Arith/Peano_dec.v +++ b/theories/Arith/Peano_dec.v @@ -57,4 +57,4 @@ now rewrite H. Qed. (** For compatibility *) -Require Import Le Lt.
\ No newline at end of file +Require Import Le Lt. diff --git a/theories/FSets/FSets.v b/theories/FSets/FSets.v index 572f286545..e03fb2236a 100644 --- a/theories/FSets/FSets.v +++ b/theories/FSets/FSets.v @@ -20,4 +20,4 @@ Require Export FSetEqProperties. Require Export FSetWeakList. Require Export FSetList. Require Export FSetPositive. -Require Export FSetAVL.
\ No newline at end of file +Require Export FSetAVL. diff --git a/theories/Logic/Classical_Prop.v b/theories/Logic/Classical_Prop.v index f7b53f1dc2..a5ae07b64c 100644 --- a/theories/Logic/Classical_Prop.v +++ b/theories/Logic/Classical_Prop.v @@ -97,12 +97,12 @@ Proof proof_irrelevance_cci classic. (* classical_left transforms |- A \/ B into ~B |- A *) (* classical_right transforms |- A \/ B into ~A |- B *) -Ltac classical_right := match goal with - | _:_ |-?X1 \/ _ => (elim (classic X1);intro;[left;trivial|right]) +Ltac classical_right := match goal with +|- ?X \/ _ => (elim (classic X);intro;[left;trivial|right]) end. Ltac classical_left := match goal with -| _:_ |- _ \/?X1 => (elim (classic X1);intro;[right;trivial|left]) +|- _ \/ ?X => (elim (classic X);intro;[right;trivial|left]) end. Require Export EqdepFacts. diff --git a/theories/MSets/MSetGenTree.v b/theories/MSets/MSetGenTree.v index 036ff1aa4b..9fb8e499ba 100644 --- a/theories/MSets/MSetGenTree.v +++ b/theories/MSets/MSetGenTree.v @@ -1144,4 +1144,4 @@ Proof. apply mindepth_cardinal. Qed. -End Props.
\ No newline at end of file +End Props. diff --git a/theories/MSets/MSets.v b/theories/MSets/MSets.v index f179bcd1d7..1ee485cc13 100644 --- a/theories/MSets/MSets.v +++ b/theories/MSets/MSets.v @@ -18,4 +18,4 @@ Require Export MSetEqProperties. Require Export MSetWeakList. Require Export MSetList. Require Export MSetPositive. -Require Export MSetAVL.
\ No newline at end of file +Require Export MSetAVL. diff --git a/theories/NArith/BinNatDef.v b/theories/NArith/BinNatDef.v index ba923d0624..6771e57add 100644 --- a/theories/NArith/BinNatDef.v +++ b/theories/NArith/BinNatDef.v @@ -378,4 +378,4 @@ Definition iter (n:N) {A} (f:A->A) (x:A) : A := | pos p => Pos.iter f x p end. -End N.
\ No newline at end of file +End N. diff --git a/theories/Numbers/NatInt/NZParity.v b/theories/Numbers/NatInt/NZParity.v index de3bbbca76..626d59d73e 100644 --- a/theories/Numbers/NatInt/NZParity.v +++ b/theories/Numbers/NatInt/NZParity.v @@ -260,4 +260,4 @@ Proof. intros. apply odd_add_mul_even. apply even_spec, even_2. Qed. -End NZParityProp.
\ No newline at end of file +End NZParityProp. diff --git a/theories/Program/Tactics.v b/theories/Program/Tactics.v index 9aca56f479..b06562fc4f 100644 --- a/theories/Program/Tactics.v +++ b/theories/Program/Tactics.v @@ -328,4 +328,4 @@ Ltac program_simpl := program_simplify ; try typeclasses eauto with program ; tr Obligation Tactic := program_simpl. -Definition obligation (A : Type) {a : A} := a.
\ No newline at end of file +Definition obligation (A : Type) {a : A} := a. diff --git a/theories/QArith/Qcabs.v b/theories/QArith/Qcabs.v index 1883c77be5..09908665e1 100644 --- a/theories/QArith/Qcabs.v +++ b/theories/QArith/Qcabs.v @@ -126,4 +126,4 @@ Proof. destruct (proj1 (Qcabs_Qcle_condition x 0)) as [A B]. + rewrite H; apply Qcle_refl. + apply Qcle_antisym; auto. -Qed.
\ No newline at end of file +Qed. diff --git a/theories/Reals/Ranalysis.v b/theories/Reals/Ranalysis.v index 66e37e867e..9b0357f033 100644 --- a/theories/Reals/Ranalysis.v +++ b/theories/Reals/Ranalysis.v @@ -26,4 +26,4 @@ Require Export RList. Require Export Sqrt_reg. Require Export Ranalysis4. Require Export Rpower. -Require Export Ranalysis_reg.
\ No newline at end of file +Require Export Ranalysis_reg. diff --git a/theories/Vectors/Vector.v b/theories/Vectors/Vector.v index 672858fa51..19d749fc85 100644 --- a/theories/Vectors/Vector.v +++ b/theories/Vectors/Vector.v @@ -21,4 +21,4 @@ Require VectorSpec. Require VectorEq. Include VectorDef. Include VectorSpec. -Include VectorEq.
\ No newline at end of file +Include VectorEq. diff --git a/theories/ZArith/BinIntDef.v b/theories/ZArith/BinIntDef.v index 7686fbae87..443667f48b 100644 --- a/theories/ZArith/BinIntDef.v +++ b/theories/ZArith/BinIntDef.v @@ -616,4 +616,4 @@ Definition lxor a b := | neg a, neg b => of_N (N.lxor (Pos.pred_N a) (Pos.pred_N b)) end. -End Z.
\ No newline at end of file +End Z. diff --git a/theories/ZArith/Zsqrt_compat.v b/theories/ZArith/Zsqrt_compat.v index fb7f71b4b5..cccd970dad 100644 --- a/theories/ZArith/Zsqrt_compat.v +++ b/theories/ZArith/Zsqrt_compat.v @@ -229,4 +229,4 @@ Proof. symmetry. apply Z.sqrt_unique; trivial. now apply Zsqrt_interval. now destruct n. -Qed.
\ No newline at end of file +Qed. diff --git a/tools/CoqMakefile.in b/tools/CoqMakefile.in index f4d1118d0f..afe8e62ee3 100644 --- a/tools/CoqMakefile.in +++ b/tools/CoqMakefile.in @@ -207,8 +207,8 @@ else TIMING_ARG= endif -# Retro compatibility (DESTDIR is standard on Unix, DESTROOT is not) -ifneq "$(DSTROOT)" "" +# Retro compatibility (DESTDIR is standard on Unix, DSTROOT is not) +ifdef DSTROOT DESTDIR := $(DSTROOT) endif @@ -500,7 +500,7 @@ uninstall:: instf="$(COQLIBINSTALL)/$$df/`basename $$f`" &&\ rm -f "$$instf" &&\ echo RM "$$instf" &&\ - (rmdir "$(call concat_path,,$(COQLIBINSTALL)/$$df/)" || true); \ + (rmdir "$(call concat_path,,$(COQLIBINSTALL)/$$df/)" 2>/dev/null || true); \ done .PHONY: uninstall diff --git a/tools/coqc.ml b/tools/coqc.ml index 862225d3d1..b381c5ba42 100644 --- a/tools/coqc.ml +++ b/tools/coqc.ml @@ -93,7 +93,7 @@ let parse_args () = | ("-bt"|"-debug"|"-nolib"|"-boot"|"-time"|"-profile-ltac" |"-batch"|"-noinit"|"-nois"|"-noglob"|"-no-glob" - |"-q"|"-profile"|"-just-parsing"|"-echo" |"-quiet" + |"-q"|"-profile"|"-echo" |"-quiet" |"-silent"|"-m"|"-beautify"|"-strict-implicit" |"-impredicative-set"|"-vm"|"-native-compiler" |"-indices-matter"|"-quick"|"-type-in-type" diff --git a/tools/coqdoc/cpretty.mll b/tools/coqdoc/cpretty.mll index 60a245dc4d..186f6cf6cf 100644 --- a/tools/coqdoc/cpretty.mll +++ b/tools/coqdoc/cpretty.mll @@ -682,7 +682,7 @@ and doc_bol = parse | space* nl+ { Output.paragraph (); doc_bol lexbuf } | "<<" space* - { Output.start_verbatim false; verbatim false lexbuf; doc_bol lexbuf } + { Output.start_verbatim false; verbatim 0 false lexbuf; doc_bol lexbuf } | eof { true } | '_' @@ -707,7 +707,7 @@ and doc_list_bol indents = parse } | "<<" space* { Output.start_verbatim false; - verbatim false lexbuf; + verbatim 0 false lexbuf; doc_list_bol indents lexbuf } | "[[" nl { formatted := true; @@ -852,7 +852,7 @@ and doc indents = parse Output.char (lexeme_char lexbuf 1); doc indents lexbuf } | "<<" space* - { Output.start_verbatim true; verbatim true lexbuf; doc_bol lexbuf } + { Output.start_verbatim true; verbatim 0 true lexbuf; doc_bol lexbuf } | '"' { if !Cdglobals.plain_comments then Output.char '"' @@ -892,13 +892,20 @@ and escaped_html = parse { backtrack lexbuf } | _ { Output.html_char (lexeme_char lexbuf 0); escaped_html lexbuf } -and verbatim inline = parse +and verbatim depth inline = parse | nl ">>" space* nl { Output.verbatim_char inline '\n'; Output.stop_verbatim inline } | nl ">>" { Output.verbatim_char inline '\n'; Output.stop_verbatim inline } | ">>" { Output.stop_verbatim inline } - | "*)" { Output.stop_verbatim inline; backtrack lexbuf } + | "(*" { Output.verbatim_char inline '('; + Output.verbatim_char inline '*'; + verbatim (depth+1) inline lexbuf } + | "*)" { if (depth == 0) + then (Output.stop_verbatim inline; backtrack lexbuf) + else (Output.verbatim_char inline '*'; + Output.verbatim_char inline ')'; + verbatim (depth-1) inline lexbuf) } | eof { Output.stop_verbatim inline } - | _ { Output.verbatim_char inline (lexeme_char lexbuf 0); verbatim inline lexbuf } + | _ { Output.verbatim_char inline (lexeme_char lexbuf 0); verbatim depth inline lexbuf } and url = parse | "}}" { Output.url (Buffer.contents url_buffer) None; Buffer.clear url_buffer } diff --git a/tools/fake_ide.ml b/tools/fake_ide.ml index a9da27ba23..79723431cf 100644 --- a/tools/fake_ide.ml +++ b/tools/fake_ide.ml @@ -252,11 +252,9 @@ let eval_print l coq = let to_id, _ = get_id id in eval_call (query (0,(phrase, to_id))) coq | [ Tok(_,"WAIT") ] -> - let phrase = "Stm Wait." in - eval_call (query (0,(phrase,tip_id()))) coq + eval_call (wait ()) coq | [ Tok(_,"JOIN") ] -> - let phrase = "Stm JoinDocument." in - eval_call (query (0,(phrase,tip_id()))) coq + eval_call (status true) coq | [ Tok(_,"ASSERT"); Tok(_,"TIP"); Tok(_,id) ] -> let to_id, _ = get_id id in if not(Stateid.equal (Document.tip doc) to_id) then error "Wrong tip" diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index d76703d980..444bf8a8f7 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -155,14 +155,16 @@ let error_info_for_buffer ?loc buf = let fname = loc.Loc.fname in let hl, loc = (* We are in the toplevel *) - if CString.equal fname "" then + match fname with + | Loc.ToplevelInput -> let nloc = adjust_loc_buf buf loc in if valid_buffer_loc buf loc then (fnl () ++ print_highlight_location buf nloc, nloc) (* in the toplevel, but not a valid buffer *) else (mt (), nloc) (* we are in batch mode, don't adjust location *) - else (mt (), loc) + | Loc.InFile _ -> + (mt (), loc) in Topfmt.pr_loc loc ++ hl ) loc diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 0f8524e923..c1cdaa5a34 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -8,7 +8,6 @@ open Pp open CErrors -open Flags open Libnames open Coqinit @@ -31,7 +30,7 @@ let print_header () = Feedback.msg_notice (str "Welcome to Coq " ++ str ver ++ str " (" ++ str rev ++ str ")"); flush_all () -let warning s = with_option Flags.warn Feedback.msg_warning (strbrk s) +let warning s = Flags.(with_option warn Feedback.msg_warning (strbrk s)) let toploop = ref None @@ -87,7 +86,7 @@ let console_toploop_run () = (* We initialize the console only if we run the toploop_run *) let tl_feed = Feedback.add_feeder Coqloop.coqloop_feed in if Dumpglob.dump () then begin - if_verbose warning "Dumpglob cannot be used in interactive mode."; + Flags.if_verbose warning "Dumpglob cannot be used in interactive mode."; Dumpglob.noglob () end; Coqloop.loop(); @@ -130,7 +129,7 @@ let set_type_in_type () = let engage () = Global.set_engagement !impredicative_set -let set_batch_mode () = batch_mode := true +let set_batch_mode () = Flags.batch_mode := true let toplevel_default_name = Names.(DirPath.make [Id.of_string "Top"]) let toplevel_name = ref toplevel_default_name @@ -177,7 +176,7 @@ let load_vernacular sid = (fun sid (s,v) -> let s = Loadpath.locate_file s in if !Flags.beautify then - with_option beautify_file (Vernac.load_vernac v sid) s + Flags.(with_option beautify_file (Vernac.load_vernac v sid) s) else Vernac.load_vernac v sid s) sid (List.rev !load_vernacular_list) @@ -199,7 +198,7 @@ let require_prelude () = let require_list = ref ([] : string list) let add_require s = require_list := s :: !require_list let require () = - let () = if !load_init then silently require_prelude () in + let () = if !Flags.load_init then Flags.silently require_prelude () in let map dir = Qualid (Loc.tag @@ qualid_of_string dir) in Vernacentries.vernac_require None (Some false) (List.rev_map map !require_list) @@ -229,7 +228,7 @@ let add_compile verbose s = let compile_file (v,f) = if !Flags.beautify then - with_option beautify_file (Vernac.compile v) f + Flags.(with_option beautify_file (Vernac.compile v) f) else Vernac.compile v f @@ -304,7 +303,7 @@ let usage () = init_load_path (); with NoCoqLib -> usage_no_coqlib () end; - if !batch_mode then Usage.print_usage_coqc () + if !Flags.batch_mode then Usage.print_usage_coqc () else begin Mltop.load_ml_objects_raw_rex (Str.regexp (if Mltop.is_native then "^.*top.cmxs$" else "^.*top.cma$")); @@ -538,7 +537,7 @@ let parse_args arglist = |"-with-geoproof" -> Coq_config.with_geoproof := get_bool opt (next ()) |"-main-channel" -> Spawned.main_channel := get_host_port opt (next()) |"-control-channel" -> Spawned.control_channel := get_host_port opt (next()) - |"-vio2vo" -> add_compile false (next ()); Flags.compilation_mode := Vio2Vo + |"-vio2vo" -> add_compile false (next ()); Flags.compilation_mode := Flags.Vio2Vo |"-toploop" -> set_toploop (next ()) |"-w" | "-W" -> CWarnings.set_flags (CWarnings.normalize_flags_string (next ())) |"-o" -> Flags.compilation_output_name := Some (next()) @@ -551,9 +550,9 @@ let parse_args arglist = |"-async-proofs-never-reopen-branch" -> Flags.async_proofs_never_reopen_branch := true; |"-batch" -> set_batch_mode () - |"-test-mode" -> test_mode := true - |"-beautify" -> beautify := true - |"-boot" -> boot := true; no_load_rc () + |"-test-mode" -> Flags.test_mode := true + |"-beautify" -> Flags.beautify := true + |"-boot" -> Flags.boot := true; no_load_rc () |"-bt" -> Backtrace.record_backtrace true |"-color" -> set_color (next ()) |"-config"|"--config" -> print_config := true @@ -565,19 +564,18 @@ let parse_args arglist = |"-ideslave" -> set_ideslave () |"-impredicative-set" -> set_impredicative_set () |"-indices-matter" -> Indtypes.enforce_indices_matter () - |"-just-parsing" -> warning "-just-parsing option has been removed in 8.6" |"-m"|"--memory" -> memory_stat := true - |"-noinit"|"-nois" -> load_init := false + |"-noinit"|"-nois" -> Flags.load_init := false |"-no-glob"|"-noglob" -> Dumpglob.noglob (); glob_opt := true |"-native-compiler" -> if Coq_config.no_native_compiler then warning "Native compilation was disabled at configure time." - else native_compiler := true + else Flags.native_compiler := true |"-output-context" -> output_context := true |"-profile-ltac" -> Flags.profile_ltac := true |"-q" -> no_load_rc () |"-quiet"|"-silent" -> Flags.quiet := true; Flags.make_warn false - |"-quick" -> Flags.compilation_mode := BuildVio + |"-quick" -> Flags.compilation_mode := Flags.BuildVio |"-list-tags" -> print_tags := true |"-time" -> Flags.time := true |"-type-in-type" -> set_type_in_type () @@ -620,11 +618,11 @@ let init_toplevel arglist = prerr_endline "See -help for the list of supported options"; exit 1 end; - if_verbose print_header (); + Flags.if_verbose print_header (); inputstate (); Mltop.init_known_plugins (); engage (); - if (not !batch_mode || CList.is_empty !compile_list) + if (not !Flags.batch_mode || CList.is_empty !compile_list) && Global.env_is_initial () then Declaremods.start_library !toplevel_name; init_library_roots (); @@ -645,16 +643,16 @@ let init_toplevel arglist = with any -> flush_all(); let extra = - if !batch_mode && not Stateid.(equal (Stm.get_current_state ()) dummy) + if !Flags.batch_mode && not Stateid.(equal (Stm.get_current_state ()) dummy) then None else Some (str "Error during initialization: ") in fatal_error ?extra any end; - if !batch_mode then begin + if !Flags.batch_mode then begin flush_all(); if !output_context then - Feedback.msg_notice (with_option raw_print Prettyp.print_full_pure_context () ++ fnl ()); + Feedback.msg_notice Flags.(with_option raw_print Prettyp.print_full_pure_context () ++ fnl ()); Profile.print_profile (); exit 0 end; diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index bfab447706..4b97ee0dde 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -11,7 +11,6 @@ open Pp open CErrors open Util -open Flags open Vernacexpr open Vernacprop @@ -53,7 +52,7 @@ let set_formatter_translator ch = let pr_new_syntax_in_context ?loc chan_beautify ocom = let loc = Option.cata Loc.unloc (0,0) loc in - if !beautify_file then set_formatter_translator chan_beautify; + if !Flags.beautify_file then set_formatter_translator chan_beautify; let fs = States.freeze ~marshallable:`No in (* The content of this is not supposed to fail, but if ever *) try @@ -63,7 +62,7 @@ let pr_new_syntax_in_context ?loc chan_beautify ocom = | Some com -> Ppvernac.pr_vernac com | None -> mt() in let after = comment (CLexer.extract_comments (snd loc)) in - if !beautify_file then + if !Flags.beautify_file then (Pp.pp_with !Topfmt.std_ft (hov 0 (before ++ com ++ after)); Format.pp_print_flush !Topfmt.std_ft ()) else @@ -134,7 +133,7 @@ let rec interp_vernac sid (loc,com) = document. Hopefully this is fixed when VtBack can be removed and Undo etc... are just interpreted regularly. *) let is_proof_step = match fst (Vernac_classifier.classify_vernac v) with - | VtProofStep _ | VtStm (VtBack _, _) | VtStartProof _ -> true + | VtProofStep _ | VtBack (_, _) | VtStartProof _ -> true | _ -> false in @@ -182,7 +181,7 @@ and load_vernac verbosely sid file = if !Flags.beautify_file then open_out (file^beautify_suffix) else stdout in let in_chan = open_utf8_file_in file in let in_echo = if verbosely then Some (open_utf8_file_in file) else None in - let in_pa = Pcoq.Gram.parsable ~file (Stream.of_channel in_chan) in + let in_pa = Pcoq.Gram.parsable ~file:(Loc.InFile file) (Stream.of_channel in_chan) in let rsid = ref sid in try (* we go out of the following infinite loop when a End_of_input is @@ -209,7 +208,7 @@ and load_vernac verbosely sid file = *) in (* Printing of vernacs *) - if !beautify then pr_new_syntax ?loc in_pa chan_beautify (Some ast); + if !Flags.beautify then pr_new_syntax ?loc in_pa chan_beautify (Some ast); Option.iter (vernac_echo ?loc) in_echo; checknav_simple (loc, ast); @@ -224,7 +223,7 @@ and load_vernac verbosely sid file = match e with | Stm.End_of_input -> (* Is this called so comments at EOF are printed? *) - if !beautify then + if !Flags.beautify then pr_new_syntax ~loc:(Loc.make_loc (max_int,max_int)) in_pa chan_beautify None; if !Flags.beautify_file then close_out chan_beautify; !rsid @@ -290,7 +289,7 @@ let compile verbosely f = ++ str ".") in match !Flags.compilation_mode with - | BuildVo -> + | Flags.BuildVo -> let long_f_dot_v = ensure_v f in ensure_exists long_f_dot_v; let long_f_dot_vo = @@ -314,7 +313,7 @@ let compile verbosely f = (Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1)); Aux_file.stop_aux_file (); Dumpglob.end_dump_glob () - | BuildVio -> + | Flags.BuildVio -> let long_f_dot_v = ensure_v f in ensure_exists long_f_dot_v; let long_f_dot_vio = @@ -329,7 +328,7 @@ let compile verbosely f = check_pending_proofs (); Stm.snapshot_vio ldir long_f_dot_vio; Stm.reset_task_queue () - | Vio2Vo -> + | Flags.Vio2Vo -> let open Filename in let open Library in Dumpglob.noglob (); diff --git a/vernac/class.ml b/vernac/class.ml index be682977e5..3915148a08 100644 --- a/vernac/class.ml +++ b/vernac/class.ml @@ -222,9 +222,10 @@ let build_id_coercion idf_opt source poly = Id.of_string ("Id_"^(ident_key_of_class source)^"_"^ (ident_key_of_class cl)) in + let univs = (snd (Evd.universe_context ~names:[] ~extensible:true sigma)) in let constr_entry = (* Cast is necessary to express [val_f] is identity *) DefinitionEntry - (definition_entry ~types:typ_f ~poly ~univs:(snd (Evd.universe_context sigma)) + (definition_entry ~types:typ_f ~poly ~univs ~inline:true (mkCast (val_f, DEFAULTcast, typ_f))) in let decl = (constr_entry, IsDefinition IdentityCoercion) in diff --git a/vernac/classes.ml b/vernac/classes.ml index ab1892a18e..c21345a2aa 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -111,14 +111,14 @@ let instance_hook k info global imps ?hook cst = Typeclasses.declare_instance (Some info) (not global) cst; (match hook with Some h -> h cst | None -> ()) -let declare_instance_constant k info global imps ?hook id pl poly evm term termtype = +let declare_instance_constant k info global imps ?hook id decl poly evm term termtype = let kind = IsDefinition Instance in let evm = let levels = Univ.LSet.union (Univops.universes_of_constr termtype) (Univops.universes_of_constr term) in Evd.restrict_universe_context evm levels in - let pl, uctx = Evd.universe_context ?names:pl evm in + let pl, uctx = Evd.check_univ_decl evm decl in let entry = Declare.definition_entry ~types:termtype ~poly ~univs:uctx term in @@ -129,13 +129,13 @@ let declare_instance_constant k info global imps ?hook id pl poly evm term termt instance_hook k info global imps ?hook (ConstRef kn); id -let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) poly ctx (instid, bk, cl) props - ?(generalize=true) - ?(tac:unit Proofview.tactic option) ?hook pri = +let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) + 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 - let uctx = Evd.make_evar_universe_context env pl in - let evars = ref (Evd.from_ctx uctx) in + let evd, decl = Univdecls.interp_univ_decl_opt env pl in + let evars = ref evd in let tclass, ids = match bk with | Decl_kinds.Implicit -> @@ -202,7 +202,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) p nf t in Pretyping.check_evars env Evd.empty !evars (EConstr.of_constr termtype); - let pl, ctx = Evd.universe_context ?names:pl !evars in + let pl, ctx = Evd.check_univ_decl !evars decl in let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest id (ParameterEntry (None,poly,(termtype,ctx),None), Decl_kinds.IsAssumption Decl_kinds.Logical) @@ -302,7 +302,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) p in let term = Option.map nf term in if not (Evd.has_undefined evm) && not (Option.is_empty term) then - declare_instance_constant k pri global imps ?hook id pl + declare_instance_constant k pri global imps ?hook id decl poly evm (Option.get term) termtype else if Flags.is_program_mode () || refine || Option.is_empty term then begin let kind = Decl_kinds.Global, poly, Decl_kinds.DefinitionBody Decl_kinds.Instance in @@ -323,7 +323,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) p let hook = Lemmas.mk_hook hook in let ctx = Evd.evar_universe_context evm in ignore (Obligations.add_definition id ?term:constr - ?pl typ ctx ~kind:(Global,poly,Instance) ~hook obls); + ~univdecl:decl typ ctx ~kind:(Global,poly,Instance) ~hook obls); id else (Flags.silently @@ -334,7 +334,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) p the refinement manually.*) let gls = List.rev (Evd.future_goals evm) in let evm = Evd.reset_future_goals evm in - Lemmas.start_proof id ?pl kind evm (EConstr.of_constr termtype) + Lemmas.start_proof id ~pl:decl kind evm (EConstr.of_constr termtype) (Lemmas.mk_hook (fun _ -> instance_hook k pri global imps ?hook)); (* spiwack: I don't know what to do with the status here. *) diff --git a/vernac/classes.mli b/vernac/classes.mli index fc2fdbbf34..fcdb5c3bc5 100644 --- a/vernac/classes.mli +++ b/vernac/classes.mli @@ -30,7 +30,7 @@ val declare_instance_constant : Impargs.manual_explicitation list -> (** implicits *) ?hook:(Globnames.global_reference -> unit) -> Id.t -> (** name *) - Id.t Loc.located list option -> + Univdecls.universe_decl -> bool -> (* polymorphic *) Evd.evar_map -> (* Universes *) Constr.t -> (** body *) @@ -43,7 +43,7 @@ val new_instance : ?refine:bool -> (** Allow refinement *) Decl_kinds.polymorphic -> local_binder_expr list -> - typeclass_constraint -> + Vernacexpr.typeclass_constraint -> (bool * constr_expr) option -> ?generalize:bool -> ?tac:unit Proofview.tactic -> diff --git a/vernac/command.ml b/vernac/command.ml index 32ab5401a0..120f9590f2 100644 --- a/vernac/command.ml +++ b/vernac/command.ml @@ -9,7 +9,6 @@ open Pp open CErrors open Util -open Flags open Term open Vars open Termops @@ -91,8 +90,8 @@ let warn_implicits_in_term = let interp_definition pl bl p red_option c ctypopt = let env = Global.env() in - let ctx = Evd.make_evar_universe_context env pl in - let evdref = ref (Evd.from_ctx ctx) 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 @@ -108,7 +107,7 @@ let interp_definition pl bl p red_option c ctypopt = let body = nf (it_mkLambda_or_LetIn c ctx) in let vars = Univops.universes_of_constr body in let evd = Evd.restrict_universe_context !evdref vars in - let pl, uctx = Evd.universe_context ?names:pl evd in + let pl, uctx = Evd.check_univ_decl evd decl in imps1@(Impargs.lift_implicits nb_args imps2), pl, definition_entry ~univs:uctx ~poly:p body | Some ctyp -> @@ -134,20 +133,20 @@ let interp_definition pl bl p red_option c ctypopt = let vars = Univ.LSet.union (Univops.universes_of_constr body) (Univops.universes_of_constr typ) in let ctx = Evd.restrict_universe_context !evdref vars in - let pl, uctx = Evd.universe_context ?names:pl ctx in + let pl, uctx = Evd.check_univ_decl ctx decl in imps1@(Impargs.lift_implicits nb_args impsty), pl, definition_entry ~types:typ ~poly:p ~univs:uctx body in - red_constant_entry (Context.Rel.length ctx) ce !evdref red_option, !evdref, pl, imps + red_constant_entry (Context.Rel.length ctx) ce !evdref red_option, !evdref, decl, pl, imps -let check_definition (ce, evd, _, imps) = +let check_definition (ce, evd, _, _, imps) = check_evars_are_solved (Global.env ()) evd Evd.empty; ce -let do_definition ident k pl bl red_option c ctypopt hook = - let (ce, evd, pl', imps as def) = - interp_definition pl bl (pi2 k) red_option c ctypopt +let do_definition ident k univdecl bl red_option c ctypopt hook = + let (ce, evd, univdecl, pl', 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 @@ -164,8 +163,8 @@ let do_definition ident k pl bl red_option c ctypopt hook = 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 ?pl ~implicits:imps ~kind:k ~hook obls) + 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 pl' imps (Lemmas.mk_hook @@ -270,15 +269,15 @@ let do_assumptions_unbound_univs (_, poly, _ as kind) nl l = let do_assumptions_bound_univs coe kind nl id pl c = let env = Global.env () in - let ctx = Evd.make_evar_universe_context env pl in - let evdref = ref (Evd.from_ctx ctx) in + let evd, decl = Univdecls.interp_univ_decl_opt env pl in + let evdref = ref evd in let ty, impls = interp_type_evars_impls env evdref c in let nf, subst = Evarutil.e_nf_evars_and_universes evdref in let ty = EConstr.Unsafe.to_constr ty in let ty = nf ty in let vars = Univops.universes_of_constr ty in let evd = Evd.restrict_universe_context !evdref vars in - let pl, uctx = Evd.universe_context ?names:pl evd in + let pl, uctx = Evd.check_univ_decl evd decl in let uctx = Univ.ContextSet.of_context uctx in let (_, _, st) = declare_assumption coe kind (ty, uctx) pl impls false nl id in st @@ -318,7 +317,7 @@ let push_types env idl tl = type structured_one_inductive_expr = { ind_name : Id.t; - ind_univs : lident list option; + ind_univs : Vernacexpr.universe_decl_expr option; ind_arity : constr_expr; ind_lc : (Id.t * constr_expr) list } @@ -526,8 +525,8 @@ let interp_mutual_inductive (paramsl,indl) notations cum poly prv finite = List.iter check_param paramsl; let env0 = Global.env() in let pl = (List.hd indl).ind_univs in - let ctx = Evd.make_evar_universe_context env0 pl in - let evdref = ref Evd.(from_ctx ctx) 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 @@ -576,7 +575,7 @@ let interp_mutual_inductive (paramsl,indl) notations cum poly prv finite = 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 pl, uctx = Evd.universe_context ?names:pl evd in + let pl, uctx = Evd.check_univ_decl 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,_) -> @@ -692,7 +691,7 @@ let declare_mutual_inductive_with_eliminations mie pl impls = constrimpls) impls; let warn_prim = match mie.mind_entry_record with Some (Some _) -> not prim | _ -> false in - if_verbose Feedback.msg_info (minductive_message warn_prim names); + Flags.if_verbose Feedback.msg_info (minductive_message warn_prim names); if mie.mind_entry_private == None then declare_default_schemes mind; mind @@ -797,7 +796,7 @@ let check_mutuality env evd isfix fixl = type structured_fixpoint_expr = { fix_name : Id.t; - fix_univs : lident list option; + fix_univs : universe_decl_expr option; fix_annot : Id.t Loc.located option; fix_binders : local_binder_expr list; fix_body : constr_expr option; @@ -917,8 +916,8 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = 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 ctx = Evd.make_evar_universe_context env pl in - let evdref = ref (Evd.from_ctx ctx) 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 @@ -1019,14 +1018,16 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = 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 = + let pl, plext = Option.cata + (fun d -> d.univdecl_instance, d.univdecl_extensible_instance) ([],true) pl 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 pl, univs = Evd.universe_context ?names:pl !evdref in + let pl, univs = Evd.universe_context ~names:pl ~extensible:plext !evdref in (*FIXME poly? *) let ce = definition_entry ~poly ~types:ty ~univs (EConstr.to_constr !evdref body) in (** FIXME: include locality *) @@ -1052,7 +1053,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = 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 ?pl + ignore(Obligations.add_definition recname ~term:evars_def ~univdecl:decl evars_typ ctx evars ~hook) let interp_recursive isfix fixl notations = @@ -1068,11 +1069,12 @@ let interp_recursive isfix fixl notations = | None , acc -> acc | x , None -> x | Some ls , Some us -> - if not (CList.for_all2eq (fun x y -> Id.equal (snd x) (snd y)) ls us) then + 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 ctx = Evd.make_evar_universe_context env all_universes in - let evdref = ref (Evd.from_ctx ctx) 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 @@ -1122,7 +1124,7 @@ let interp_recursive isfix fixl notations = let fixctxs = List.map (fun (_,ctx) -> ctx) fixctxs in (* Build the fix declaration block *) - (env,rec_sign,all_universes,evd), (fixnames,fixdefs,fixtypes), List.combine3 fixctxs fiximps fixannots + (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; @@ -1145,14 +1147,14 @@ let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) ind if List.exists Option.is_empty fixdefs then (* Some bodies to define by proof *) let thms = - List.map3 (fun id t (ctx,imps,_) -> ((id,pl),(t,(List.map RelDecl.get_name ctx,imps)))) + 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 (Some(false,indexes,init_tac)) thms None (Lemmas.mk_hook (fun _ _ -> ())) + 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 @@ -1165,8 +1167,8 @@ let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) ind 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 pl, ctx = Evd.check_univ_decl evd pl in let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in - let pl, ctx = Evd.universe_context ?names:pl evd in ignore (List.map4 (DeclareDef.declare_fix (local, poly, Fixpoint) pl ctx) fixnames fixdecls fixtypes fiximps); (* Declare the recursive definitions *) @@ -1179,14 +1181,14 @@ let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) n if List.exists Option.is_empty fixdefs then (* Some bodies to define by proof *) let thms = - List.map3 (fun id t (ctx,imps,_) -> ((id,pl),(t,(List.map RelDecl.get_name ctx,imps)))) + 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 (Some(true,[],init_tac)) thms None (Lemmas.mk_hook (fun _ _ -> ())) + 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 @@ -1197,8 +1199,8 @@ let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) n 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 pl, ctx = Evd.universe_context ?names:pl evd in - ignore (List.map4 (DeclareDef.declare_fix (local, poly, CoFixpoint) pl ctx) + let pl, ctx = Evd.check_univ_decl evd pl in + ignore (List.map4 (DeclareDef.declare_fix (local, poly, CoFixpoint) pl ctx) fixnames fixdecls fixtypes fiximps); (* Declare the recursive definitions *) cofixpoint_message fixnames @@ -1281,7 +1283,7 @@ let do_program_recursive local p fixkind fixl ntns = | Obligations.IsFixpoint _ -> (local, p, Fixpoint) | Obligations.IsCoFixpoint -> (local, p, CoFixpoint) in - Obligations.add_mutual_definitions defs ~kind ?pl ctx ntns fixkind + 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 diff --git a/vernac/command.mli b/vernac/command.mli index 8d17f27c30..afa97aa24f 100644 --- a/vernac/command.mli +++ b/vernac/command.mli @@ -26,11 +26,11 @@ val do_constraint : polymorphic -> (** {6 Definitions/Let} *) val interp_definition : - lident list option -> local_binder_expr list -> polymorphic -> red_expr option -> constr_expr -> + 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 * - Universes.universe_binders * Impargs.manual_implicits + Univdecls.universe_decl * Universes.universe_binders * Impargs.manual_implicits -val do_definition : Id.t -> definition_kind -> lident list option -> +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 @@ -49,7 +49,7 @@ val declare_assumption : coercion_flag -> assumption_kind -> global_reference * Univ.Instance.t * bool val do_assumptions : locality * polymorphic * assumption_object_kind -> - Vernacexpr.inline -> (plident list * constr_expr) with_coercion list -> bool + 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 -> *) @@ -62,7 +62,7 @@ val do_assumptions : locality * polymorphic * assumption_object_kind -> type structured_one_inductive_expr = { ind_name : Id.t; - ind_univs : lident list option; + ind_univs : Vernacexpr.universe_decl_expr option; ind_arity : constr_expr; ind_lc : (Id.t * constr_expr) list } @@ -102,7 +102,7 @@ val do_mutual_inductive : type structured_fixpoint_expr = { fix_name : Id.t; - fix_univs : lident list 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; @@ -127,24 +127,24 @@ type recursive_preentry = val interp_fixpoint : structured_fixpoint_expr list -> decl_notation list -> - recursive_preentry * lident list option * Evd.evar_universe_context * + recursive_preentry * Univdecls.universe_decl * Evd.evar_universe_context * (EConstr.rel_context * Impargs.manual_implicits * int option) list val interp_cofixpoint : structured_fixpoint_expr list -> decl_notation list -> - recursive_preentry * lident list option * Evd.evar_universe_context * + recursive_preentry * Univdecls.universe_decl * Evd.evar_universe_context * (EConstr.rel_context * Impargs.manual_implicits * int option) list (** Registering fixpoints and cofixpoints in the environment *) val declare_fixpoint : locality -> polymorphic -> - recursive_preentry * lident list option * Evd.evar_universe_context * + recursive_preentry * Univdecls.universe_decl * Evd.evar_universe_context * (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 * lident list option * Evd.evar_universe_context * + recursive_preentry * Univdecls.universe_decl * Evd.evar_universe_context * (Context.Rel.t * Impargs.manual_implicits * int option) list -> decl_notation list -> unit diff --git a/vernac/discharge.ml b/vernac/discharge.ml index 474c0b4dd2..0e4bbd2993 100644 --- a/vernac/discharge.ml +++ b/vernac/discharge.ml @@ -36,32 +36,32 @@ let detype_param = I1..Ip:(B1 y1..yq)..(Bp y1..yq) |- ci : (y1..yq:C1..Cq)Ti[Ij:=(Ij y1..yq)] *) -let abstract_inductive hyps nparams inds = +let abstract_inductive decls nparamdecls inds = let ntyp = List.length inds in - let nhyp = Context.Named.length hyps in - let args = Context.Named.to_instance mkVar (List.rev hyps) in + let ndecls = Context.Named.length decls in + let args = Context.Named.to_instance mkVar (List.rev decls) in let args = Array.of_list args in - let subs = List.init ntyp (fun k -> lift nhyp (mkApp(mkRel (k+1),args))) in + let subs = List.init ntyp (fun k -> lift ndecls (mkApp(mkRel (k+1),args))) in let inds' = List.map (function (tname,arity,template,cnames,lc) -> let lc' = List.map (substl subs) lc in - let lc'' = List.map (fun b -> Termops.it_mkNamedProd_wo_LetIn b hyps) lc' in - let arity' = Termops.it_mkNamedProd_wo_LetIn arity hyps in + let lc'' = List.map (fun b -> Termops.it_mkNamedProd_wo_LetIn b decls) lc' in + let arity' = Termops.it_mkNamedProd_wo_LetIn arity decls in (tname,arity',template,cnames,lc'')) inds in - let nparams' = nparams + Array.length args in + let nparamdecls' = nparamdecls + Array.length args in (* To be sure to be the same as before, should probably be moved to process_inductive *) let params' = let (_,arity,_,_,_) = List.hd inds' in - let (params,_) = decompose_prod_n_assum nparams' arity in + let (params,_) = decompose_prod_n_assum nparamdecls' arity in List.map detype_param params in let ind'' = List.map (fun (a,arity,template,c,lc) -> - let _, short_arity = decompose_prod_n_assum nparams' arity in + let _, short_arity = decompose_prod_n_assum nparamdecls' arity in let shortlc = - List.map (fun c -> snd (decompose_prod_n_assum nparams' c)) lc in + List.map (fun c -> snd (decompose_prod_n_assum nparamdecls' c)) lc in { mind_entry_typename = a; mind_entry_arity = short_arity; mind_entry_template = template; @@ -77,9 +77,9 @@ let refresh_polymorphic_type_of_inductive (_,mip) = let ctx = List.rev mip.mind_arity_ctxt in mkArity (List.rev ctx, Type ar.template_level), true -let process_inductive (sechyps,_,_ as info) modlist mib = - let sechyps = Lib.named_of_variable_context sechyps in - let nparams = mib.mind_nparams in +let process_inductive (section_decls,_,_ as info) modlist mib = + let section_decls = Lib.named_of_variable_context section_decls in + let nparamdecls = Context.Rel.length mib.mind_params_ctxt in let subst, ind_univs = match mib.mind_universes with | Monomorphic_ind ctx -> Univ.empty_level_subst, Monomorphic_ind_entry ctx @@ -105,8 +105,8 @@ let process_inductive (sechyps,_,_ as info) modlist mib = Array.to_list mip.mind_consnames, Array.to_list lc)) mib.mind_packets in - let sechyps' = Context.Named.map discharge sechyps in - let (params',inds') = abstract_inductive sechyps' nparams inds in + let section_decls' = Context.Named.map discharge section_decls in + let (params',inds') = abstract_inductive section_decls' nparamdecls inds in let record = match mib.mind_record with | Some (Some (id, _, _)) -> Some (Some id) | Some None -> Some None diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 2be10a0397..12b68fe38e 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -418,7 +418,7 @@ let explain_not_product env sigma c = let pr = pr_lconstr_env env sigma c in str "The type of this term is a product" ++ spc () ++ str "while it is expected to be" ++ - (if is_Type c then str " a sort" else (brk(1,1) ++ pr)) ++ str "." + (if Term.is_Type c then str " a sort" else (brk(1,1) ++ pr)) ++ str "." (* TODO: use the names *) (* (co)fixpoints *) @@ -1176,7 +1176,7 @@ let error_not_allowed_case_analysis isrec kind i = pr_inductive (Global.env()) (fst i) ++ str "." let error_not_allowed_dependent_analysis isrec i = - str "Dependent " ++ str (if isrec then "Induction" else "Case analysis") ++ + str "Dependent " ++ str (if isrec then "induction" else "case analysis") ++ strbrk " is not allowed for inductive definition " ++ pr_inductive (Global.env()) i ++ str "." diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index 6ea8bc7f2c..90168843a6 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -30,7 +30,6 @@ open Globnames open Goptions open Nameops open Termops -open Pretyping open Nametab open Smartlocate open Vernacexpr @@ -109,7 +108,7 @@ let _ = let define id internal ctx c t = let f = declare_constant ~internal in - let _, univs = Evd.universe_context ctx in + let _, univs = Evd.universe_context ~names:[] ~extensible:true ctx in let univs = if Flags.is_universe_polymorphism () then Polymorphic_const_entry univs else Monomorphic_const_entry univs @@ -345,24 +344,23 @@ requested let names inds recs isdep y z = let ind = smart_global_inductive y in let sort_of_ind = inductive_sort_family (snd (lookup_mind_specif env ind)) in - let z' = interp_elimination_sort z in let suffix = ( match sort_of_ind with | InProp -> - if isdep then (match z' with + if isdep then (match z with | InProp -> inds ^ "_dep" | InSet -> recs ^ "_dep" | InType -> recs ^ "t_dep") - else ( match z' with + else ( match z with | InProp -> inds | InSet -> recs | InType -> recs ^ "t" ) | _ -> - if isdep then (match z' with + if isdep then (match z with | InProp -> inds | InSet -> recs | InType -> recs ^ "t" ) - else (match z' with + else (match z with | InProp -> inds ^ "_nodep" | InSet -> recs ^ "_nodep" | InType -> recs ^ "t_nodep") @@ -392,7 +390,7 @@ let do_mutual_induction_scheme lnamedepindsort = evd, (ind,u), Some u | Some ui -> evd, (ind, ui), inst in - (evd, (indu,dep,interp_elimination_sort sort) :: l, inst)) + (evd, (indu,dep,sort) :: l, inst)) lnamedepindsort (Evd.from_env env0,[],None) in let sigma, listdecl = Indrec.build_mutual_induction_scheme env0 sigma lrecspec in diff --git a/vernac/indschemes.mli b/vernac/indschemes.mli index 076e4938fd..91c4c58255 100644 --- a/vernac/indschemes.mli +++ b/vernac/indschemes.mli @@ -11,7 +11,6 @@ open Names open Term open Environ open Vernacexpr -open Misctypes (** See also Auto_ind_decl, Indrec, Eqscheme, Ind_tables, ... *) @@ -32,7 +31,7 @@ val declare_rewriting_schemes : inductive -> unit (** Mutual Minimality/Induction scheme *) val do_mutual_induction_scheme : - (Id.t located * bool * inductive * glob_sort) list -> unit + (Id.t located * bool * inductive * Sorts.family) list -> unit (** Main calls to interpret the Scheme command *) diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 645320c603..192dd027cc 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -11,7 +11,6 @@ open CErrors open Util -open Flags open Pp open Names open Term @@ -49,7 +48,7 @@ let retrieve_first_recthm uctx = function (NamedDecl.get_value (Global.lookup_named id),variable_opacity id) | ConstRef cst -> let cb = Global.lookup_constant cst in - let (_, uctx) = UState.universe_context uctx in + let (_, uctx) = UState.universe_context ~names:[] ~extensible:true uctx in let inst = Univ.UContext.instance uctx in let map (c, ctx) = Vars.subst_instance_constr inst c in (Option.map map (Global.body_of_constant_body cb), is_opaque cb) @@ -137,7 +136,7 @@ let find_mutually_recursive_statements thms = assert (List.is_empty rest); (* One occ. of common coind ccls and no common inductive hyps *) if not (List.is_empty common_same_indhyp) then - if_verbose Feedback.msg_info (str "Assuming mutual coinductive statements."); + Flags.if_verbose Feedback.msg_info (str "Assuming mutual coinductive statements."); flush_all (); indccl, true, [] | [], _::_ -> @@ -145,7 +144,7 @@ let find_mutually_recursive_statements thms = | ind :: _ -> if List.distinct_f ind_ord (List.map pi1 ind) then - if_verbose Feedback.msg_info + Flags.if_verbose Feedback.msg_info (strbrk ("Coinductive statements do not follow the order of "^ "definition, assuming the proof to be by induction.")); @@ -210,11 +209,11 @@ let compute_proof_name locality = function locality == Global && Nametab.exists_cci (Lib.make_path_except_section id) then user_err ?loc (pr_id id ++ str " already exists."); - id, pl + id | None -> - next_global_ident_away default_thm_id (Proof_global.get_all_proof_names ()), None + next_global_ident_away default_thm_id (Proof_global.get_all_proof_names ()) -let save_remaining_recthms (locality,p,kind) norm ctx body opaq i ((id,pl),(t_i,(_,imps))) = +let save_remaining_recthms (locality,p,kind) norm ctx binders body opaq i (id,(t_i,(_,imps))) = let t_i = norm t_i in match body with | None -> @@ -222,7 +221,7 @@ let save_remaining_recthms (locality,p,kind) norm ctx body opaq i ((id,pl),(t_i, | Discharge -> let impl = false in (* copy values from Vernacentries *) let k = IsAssumption Conjectural in - let c = SectionLocalAssum ((t_i,ctx),p,impl) in + let c = SectionLocalAssum ((t_i,Univ.ContextSet.of_context ctx),p,impl) in let _ = declare_variable id (Lib.cwd(),c,k) in (Discharge, VarRef id,imps) | Local | Global -> @@ -232,7 +231,6 @@ let save_remaining_recthms (locality,p,kind) norm ctx body opaq i ((id,pl),(t_i, | Global -> false | Discharge -> assert false in - let ctx = Univ.ContextSet.to_context ctx in let decl = (ParameterEntry (None,p,(t_i,ctx),None), k) in let kn = declare_constant id ~local decl in (locality,ConstRef kn,imps)) @@ -250,12 +248,11 @@ let save_remaining_recthms (locality,p,kind) norm ctx body opaq i ((id,pl),(t_i, match locality with | Discharge -> let const = definition_entry ~types:t_i ~opaque:opaq ~poly:p - ~univs:(Univ.ContextSet.to_context ctx) body_i in + ~univs:ctx body_i in let c = SectionLocalDef const in let _ = declare_variable id (Lib.cwd(), c, k) in (Discharge,VarRef id,imps) | Local | Global -> - let ctx = Univ.ContextSet.to_context ctx in let local = match locality with | Local -> true | Global -> false @@ -312,12 +309,6 @@ let get_proof proof do_guard hook opacity = in id,{const with const_entry_opaque = opacity},univs,do_guard,persistence,hook -let check_exist = - List.iter (fun (loc,id) -> - if not (Nametab.exists_cci (Lib.make_path id)) then - user_err ?loc (pr_id id ++ str " does not exist.") - ) - let universe_proof_terminator compute_guard hook = let open Proof_global in make_terminator begin function @@ -325,17 +316,16 @@ let universe_proof_terminator compute_guard hook = admit (id,k,pe) pl (hook (Some ctx)) (); Feedback.feedback Feedback.AddedAxiom | Proved (opaque,idopt,proof) -> - let is_opaque, export_seff, exports = match opaque with - | Vernacexpr.Transparent -> false, true, [] - | Vernacexpr.Opaque None -> true, false, [] - | Vernacexpr.Opaque (Some l) -> true, true, l in + let is_opaque, export_seff = match opaque with + | Vernacexpr.Transparent -> false, true + | Vernacexpr.Opaque -> true, false + in let proof = get_proof proof compute_guard (hook (Some (fst proof.Proof_global.universes))) is_opaque in begin match idopt with | None -> save_named ~export_seff proof | Some (_,id) -> save_anonymous ~export_seff proof id - end; - check_exist exports + end end let standard_proof_terminator compute_guard hook = @@ -369,7 +359,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,EConstr.of_constr t)) thms with | (id,_)::l -> Tactics.mutual_cofix id l 0 | _ -> assert false else @@ -377,11 +367,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, EConstr.of_constr t)) thms nl with | (id,n,_)::l -> Tactics.mutual_fix id n l 0 | _ -> assert false -let start_proof_with_initialization kind ctx recguard thms snl hook = +let start_proof_with_initialization kind ctx decl recguard thms snl hook = let intro_tac (_, (_, (ids, _))) = Tacticals.New.tclMAP (function | Name id -> Tactics.intro_mustbe_force id @@ -406,7 +396,7 @@ let start_proof_with_initialization kind ctx recguard thms snl hook = (if Flags.is_auto_intros () then Some (intro_tac (List.hd thms)) else None), [] in match thms with | [] -> anomaly (Pp.str "No proof to start.") - | ((id,pl),(t,(_,imps)))::other_thms -> + | (id,(t,(_,imps)))::other_thms -> let hook ctx strength ref = let ctx = match ctx with | None -> Evd.empty_evar_universe_context @@ -418,22 +408,24 @@ let start_proof_with_initialization kind ctx recguard thms snl hook = 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 ctx = UState.context_set (*FIXME*) ctx in + let binders, ctx = Evd.check_univ_decl (Evd.from_ctx ctx) decl in let body = Option.map norm body in - List.map_i (save_remaining_recthms kind norm ctx body opaq) 1 other_thms in + List.map_i (save_remaining_recthms kind norm ctx binders 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 kind ctx (EConstr.of_constr t) ?init_tac (fun ctx -> mk_hook (hook ctx)) ~compute_guard:guard + start_proof_univs id ~pl:decl kind ctx (EConstr.of_constr 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 - let levels = Option.map snd (fst (List.hd thms)) in - let evdref = ref (match levels with - | None -> Evd.from_env env0 - | Some l -> Evd.from_ctx (Evd.make_evar_universe_context env0 l)) - in + let decl = fst (List.hd thms) in + let evd, decl = + 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 @@ -449,16 +441,16 @@ let start_proof_com ?inference_hook kind thms hook = let evd, nf = Evarutil.nf_evars_and_universes !evdref in let thms = List.map (fun (n, (t, info)) -> (n, (nf t, info))) thms in let () = - match levels with - | None -> () - | Some l -> ignore (Evd.universe_context evd ?names:l) + if not decl.Misctypes.univdecl_extensible_instance then + ignore (Evd.universe_context evd ~names:decl.Misctypes.univdecl_instance ~extensible:false) + else () in let evd = if pi2 kind then evd else (* We fix the variables to ensure they won't be lowered to Set *) Evd.fix_undefined_variables evd in - start_proof_with_initialization kind evd recguard thms snl hook + start_proof_with_initialization kind evd decl recguard thms snl hook (* Saving a proof *) @@ -507,11 +499,13 @@ let save_proof ?proof = function let ids_def = Environ.global_vars_set env pproof in Some (Environ.keep_hyps env (Idset.union ids_typ ids_def)) | _ -> None in - let names = Proof_global.get_universe_binders () in + let decl = Proof_global.get_universe_decl () in let evd = Evd.from_ctx universes in - let binders, ctx = Evd.universe_context ?names evd in - Admitted(id,k,(sec_vars, pi2 k, (typ, ctx), None), - (universes, Some binders)) + let binders, ctx = Evd.check_univ_decl evd decl in + let poly = pi2 k in + let binders = if poly then Some binders else None in + Admitted(id,k,(sec_vars, poly, (typ, ctx), None), + (universes, binders)) in Proof_global.apply_terminator (Proof_global.get_terminator ()) pe | Vernacexpr.Proved (is_opaque,idopt) -> diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli index a8c09c0fed..1e23c7314b 100644 --- a/vernac/lemmas.mli +++ b/vernac/lemmas.mli @@ -20,13 +20,13 @@ val call_hook : (** A hook start_proof calls on the type of the definition being started *) val set_start_hook : (EConstr.types -> unit) -> unit -val start_proof : Id.t -> ?pl:Proof_global.universe_binders -> goal_kind -> Evd.evar_map -> +val start_proof : Id.t -> ?pl:Univdecls.universe_decl -> goal_kind -> Evd.evar_map -> ?terminator:(Proof_global.lemma_possible_guards -> unit declaration_hook -> Proof_global.proof_terminator) -> ?sign:Environ.named_context_val -> EConstr.types -> ?init_tac:unit Proofview.tactic -> ?compute_guard:Proof_global.lemma_possible_guards -> unit declaration_hook -> unit -val start_proof_univs : Id.t -> ?pl:Proof_global.universe_binders -> goal_kind -> Evd.evar_map -> +val start_proof_univs : Id.t -> ?pl:Univdecls.universe_decl -> goal_kind -> Evd.evar_map -> ?terminator:(Proof_global.lemma_possible_guards -> (Evd.evar_universe_context option -> unit declaration_hook) -> Proof_global.proof_terminator) -> ?sign:Environ.named_context_val -> EConstr.types -> ?init_tac:unit Proofview.tactic -> ?compute_guard:Proof_global.lemma_possible_guards -> @@ -38,9 +38,9 @@ val start_proof_com : unit declaration_hook -> unit val start_proof_with_initialization : - goal_kind -> Evd.evar_map -> + 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 *) * Proof_global.universe_binders option) * + (Id.t (* name of thm *) * (types (* type of thm *) * (Name.t list (* names to pre-introduce *) * Impargs.manual_explicitation list))) list -> int list option -> unit declaration_hook -> unit diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 8b042a3ca3..5298ef2e44 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -7,7 +7,6 @@ (************************************************************************) open Pp -open Flags open CErrors open Util open Names @@ -98,102 +97,104 @@ let pr_grammar = function quote (except a single quote alone) must be quoted) *) let parse_format ((loc, str) : lstring) = - let str = " "^str in - let l = String.length str in - let push_token a = function - | cur::l -> (a::cur)::l - | [] -> [[a]] in - let push_white n l = - if Int.equal n 0 then l else push_token (UnpTerminal (String.make n ' ')) l in - let close_box i b = function - | a::(_::_ as l) -> push_token (UnpBox (b,a)) l - | _ -> user_err Pp.(str "Non terminated box in format.") in - let close_quotation i = - if i < String.length str && str.[i] == '\'' && (Int.equal (i+1) l || str.[i+1] == ' ') - then i+1 - else user_err Pp.(str "Incorrectly terminated quoted expression.") in + let len = String.length str in + (* TODO: update the line of the location when the string contains newlines *) + let make_loc i j = Option.map (Loc.shift_loc (i+1) (j-len)) loc in + let push_token loc a = function + | (i,cur)::l -> (i,(loc,a)::cur)::l + | [] -> assert false in + let push_white i n l = + if Int.equal n 0 then l else push_token (make_loc i (i+n)) (UnpTerminal (String.make n ' ')) l in + let close_box start stop b = function + | (_,a)::(_::_ as l) -> push_token (make_loc start stop) (UnpBox (b,a)) l + | [a] -> user_err ?loc:(make_loc start stop) Pp.(str "Non terminated box in format.") + | [] -> assert false in + let close_quotation start i = + if i < len && str.[i] == '\'' then + if (Int.equal (i+1) len || str.[i+1] == ' ') + then i+1 + else user_err ?loc:(make_loc (i+1) (i+1)) Pp.(str "Space expected after quoted expression.") + else + user_err ?loc:(make_loc start (i-1)) Pp.(str "Beginning of quoted expression expected to be ended by a quote.") in let rec spaces n i = - if i < String.length str && str.[i] == ' ' then spaces (n+1) (i+1) + if i < len && str.[i] == ' ' then spaces (n+1) (i+1) else n in let rec nonspaces quoted n i = - if i < String.length str && str.[i] != ' ' then + if i < len && str.[i] != ' ' then if str.[i] == '\'' && quoted && - (i+1 >= String.length str || str.[i+1] == ' ') - then if Int.equal n 0 then user_err Pp.(str "Empty quoted token.") else n + (i+1 >= len || str.[i+1] == ' ') + then if Int.equal n 0 then user_err ?loc:(make_loc (i-1) i) Pp.(str "Empty quoted token.") else n else nonspaces quoted (n+1) (i+1) else - if quoted then user_err Pp.(str "Spaces are not allowed in (quoted) symbols.") + if quoted then user_err ?loc:(make_loc i i) Pp.(str "Spaces are not allowed in (quoted) symbols.") else n in let rec parse_non_format i = let n = nonspaces false 0 i in - push_token (UnpTerminal (String.sub str i n)) (parse_token (i+n)) + push_token (make_loc i (i+n-1)) (UnpTerminal (String.sub str i n)) (parse_token 1 (i+n)) and parse_quoted n i = - if i < String.length str then match str.[i] with + if i < len then match str.[i] with (* Parse " // " *) - | '/' when i <= String.length str && str.[i+1] == '/' -> - (* We forget the useless n spaces... *) - push_token (UnpCut PpFnl) - (parse_token (close_quotation (i+2))) + | '/' when i+1 < len && str.[i+1] == '/' -> + (* We discard the useless n spaces... *) + push_token (make_loc (i-n) (i+1)) (UnpCut PpFnl) + (parse_token 1 (close_quotation i (i+2))) (* Parse " .. / .. " *) - | '/' when i <= String.length str -> + | '/' when i+1 < len -> let p = spaces 0 (i+1) in - push_token (UnpCut (PpBrk (n,p))) - (parse_token (close_quotation (i+p+1))) + push_token (make_loc (i-n) (i+p)) (UnpCut (PpBrk (n,p))) + (parse_token 1 (close_quotation i (i+p+1))) | c -> (* The spaces are real spaces *) - push_white n (match c with + push_white i n (match c with | '[' -> - if i <= String.length str then match str.[i+1] with + if i+1 < len then match str.[i+1] with (* Parse " [h .. ", *) - | 'h' when i+1 <= String.length str && str.[i+2] == 'v' -> - (parse_box (fun n -> PpHVB n) (i+3)) + | 'h' when i+1 <= len && str.[i+2] == 'v' -> + (parse_box i (fun n -> PpHVB n) (i+3)) (* Parse " [v .. ", *) | 'v' -> - parse_box (fun n -> PpVB n) (i+2) + parse_box i (fun n -> PpVB n) (i+2) (* Parse " [ .. ", *) | ' ' | '\'' -> - parse_box (fun n -> PpHOVB n) (i+1) - | _ -> user_err Pp.(str "\"v\", \"hv\", \" \" expected after \"[\" in format.") - else user_err Pp.(str "\"v\", \"hv\" or \" \" expected after \"[\" in format.") + parse_box i (fun n -> PpHOVB n) (i+1) + | _ -> user_err ?loc:(make_loc i i) Pp.(str "\"v\", \"hv\", \" \" expected after \"[\" in format.") + else user_err ?loc:(make_loc i i) Pp.(str "\"v\", \"hv\" or \" \" expected after \"[\" in format.") (* Parse "]" *) | ']' -> - ([] :: parse_token (close_quotation (i+1))) + ((i,[]) :: parse_token 1 (close_quotation i (i+1))) (* Parse a non formatting token *) | c -> let n = nonspaces true 0 i in - push_token (UnpTerminal (String.sub str (i-1) (n+2))) - (parse_token (close_quotation (i+n)))) + push_token (make_loc i (i+n-1)) (UnpTerminal (String.sub str (i-1) (n+2))) + (parse_token 1 (close_quotation i (i+n)))) else if Int.equal n 0 then [] - else user_err Pp.(str "Ending spaces non part of a format annotation.") - and parse_box box i = + else user_err ?loc:(make_loc (len-n) len) Pp.(str "Ending spaces non part of a format annotation.") + and parse_box start box i = let n = spaces 0 i in - close_box i (box n) (parse_token (close_quotation (i+n))) - and parse_token i = + close_box start (i+n-1) (box n) (parse_token 1 (close_quotation i (i+n))) + and parse_token k i = let n = spaces 0 i in let i = i+n in - if i < l then match str.[i] with + if i < len then match str.[i] with (* Parse a ' *) - | '\'' when i+1 >= String.length str || str.[i+1] == ' ' -> - push_white (n-1) (push_token (UnpTerminal "'") (parse_token (i+1))) + | '\'' when i+1 >= len || str.[i+1] == ' ' -> + push_white (i-n) (n-k) (push_token (make_loc i (i+1)) (UnpTerminal "'") (parse_token 1 (i+1))) (* Parse the beginning of a quoted expression *) | '\'' -> - parse_quoted (n-1) (i+1) + parse_quoted (n-k) (i+1) (* Otherwise *) | _ -> - push_white (n-1) (parse_non_format i) - else push_white n [[]] + push_white (i-n) (n-k) (parse_non_format i) + else push_white (i-n) n [(len,[])] in - try - if not (String.is_empty str) then match parse_token 0 with - | [l] -> l - | _ -> user_err Pp.(str "Box closed without being opened in format.") - else - user_err Pp.(str "Empty format.") - with reraise -> - let (e, info) = CErrors.push reraise in - let info = Option.cata (Loc.add_loc info) info loc in - iraise (e, info) + if not (String.is_empty str) then + match parse_token 0 0 with + | [_,l] -> l + | (i,_)::_ -> user_err ?loc:(make_loc i i) Pp.(str "Box closed without being opened.") + | [] -> assert false + else + [] (***********************) (* Analyzing notations *) @@ -384,11 +385,11 @@ let is_next_terminal = function Terminal _ :: _ -> true | _ -> false let is_next_break = function Break _ :: _ -> true | _ -> false -let add_break n l = UnpCut (PpBrk(n,0)) :: l +let add_break n l = (None,UnpCut (PpBrk(n,0))) :: l let add_break_if_none n = function - | ((UnpCut (PpBrk _) :: _) | []) as l -> l - | l -> UnpCut (PpBrk(n,0)) :: l + | (((_,UnpCut (PpBrk _)) :: _) | []) as l -> l + | l -> (None,UnpCut (PpBrk(n,0))) :: l let check_open_binder isopen sl m = let pr_token = function @@ -414,30 +415,30 @@ let make_hunks etyps symbols from = let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in let u = UnpMetaVar (i,prec) in if is_next_non_terminal prods then - u :: add_break_if_none 1 (make prods) + (None,u) :: add_break_if_none 1 (make prods) else - u :: make_with_space prods + (None,u) :: make_with_space prods | Terminal s :: prods when List.exists is_non_terminal prods -> if (is_comma s || is_operator s) then (* Always a breakable space after comma or separator *) - UnpTerminal s :: add_break_if_none 1 (make prods) + (None,UnpTerminal s) :: add_break_if_none 1 (make prods) else if is_right_bracket s && is_next_terminal prods then (* Always no space after right bracked, but possibly a break *) - UnpTerminal s :: add_break_if_none 0 (make prods) + (None,UnpTerminal s) :: add_break_if_none 0 (make prods) else if is_left_bracket s && is_next_non_terminal prods then - UnpTerminal s :: make prods + (None,UnpTerminal s) :: make prods else if not (is_next_break prods) then (* Add rigid space, no break, unless user asked for something *) - UnpTerminal (s^" ") :: make prods + (None,UnpTerminal (s^" ")) :: make prods else (* Rely on user spaces *) - UnpTerminal s :: make prods + (None,UnpTerminal s) :: make prods | Terminal s :: prods -> (* Separate but do not cut a trailing sequence of terminal *) (match prods with - | Terminal _ :: _ -> UnpTerminal (s^" ") :: make prods - | _ -> UnpTerminal s :: make prods) + | Terminal _ :: _ -> (None,UnpTerminal (s^" ")) :: make prods + | _ -> (None,UnpTerminal s) :: make prods) | Break n :: prods -> add_break n (make prods) @@ -452,12 +453,12 @@ let make_hunks etyps symbols from = (* We add NonTerminal for simulation but remove it afterwards *) else snd (List.sep_last (make (sl@[NonTerminal m]))) in let hunk = match typ with - | ETConstr _ -> UnpListMetaVar (i,prec,sl') + | ETConstr _ -> UnpListMetaVar (i,prec,List.map snd sl') | ETBinder isopen -> check_open_binder isopen sl m; - UnpBinderListMetaVar (i,isopen,sl') + UnpBinderListMetaVar (i,isopen,List.map snd sl') | _ -> assert false in - hunk :: make_with_space prods + (None,hunk) :: make_with_space prods | [] -> [] @@ -466,7 +467,7 @@ let make_hunks etyps symbols from = | Terminal s' :: prods'-> if is_operator s' then (* A rigid space before operator and a breakable after *) - UnpTerminal (" "^s') :: add_break_if_none 1 (make prods') + (None,UnpTerminal (" "^s')) :: add_break_if_none 1 (make prods') else if is_comma s' then (* No space whatsoever before comma *) make prods @@ -487,58 +488,63 @@ let make_hunks etyps symbols from = (* Build default printing rules from explicit format *) -let error_format () = user_err Pp.(str "The format does not match the notation.") +let error_format ?loc () = user_err ?loc Pp.(str "The format does not match the notation.") let rec split_format_at_ldots hd = function - | UnpTerminal s :: fmt when String.equal s (Id.to_string ldots_var) -> List.rev hd, fmt + | (loc,UnpTerminal s) :: fmt when String.equal s (Id.to_string ldots_var) -> loc, List.rev hd, fmt | u :: fmt -> check_no_ldots_in_box u; split_format_at_ldots (u::hd) fmt | [] -> raise Exit and check_no_ldots_in_box = function - | UnpBox (_,fmt) -> + | (_,UnpBox (_,fmt)) -> (try - let _ = split_format_at_ldots [] fmt in - user_err Pp.(str ("The special symbol \"..\" must occur at the same formatting depth than the variables of which it is the ellipse.")) + let loc,_,_ = split_format_at_ldots [] fmt in + user_err ?loc Pp.(str ("The special symbol \"..\" must occur at the same formatting depth than the variables of which it is the ellipse.")) with Exit -> ()) | _ -> () +let error_not_same ?loc () = + user_err ?loc Pp.(str "The format is not the same on the right- and left-hand sides of the special token \"..\".") + let skip_var_in_recursive_format = function - | UnpTerminal _ :: sl (* skip first var *) -> + | (_,UnpTerminal s) :: sl (* skip first var *) when not (List.for_all (fun c -> c = " ") (String.explode s)) -> (* To do, though not so important: check that the names match the names in the notation *) sl - | _ -> error_format () + | (loc,_) :: _ -> error_not_same ?loc () + | [] -> assert false let read_recursive_format sl fmt = let get_head fmt = let sl = skip_var_in_recursive_format fmt in - try split_format_at_ldots [] sl with Exit -> error_format () in + try split_format_at_ldots [] sl with Exit -> error_not_same ?loc:(fst (List.last (if sl = [] then fmt else sl))) () in let rec get_tail = function - | a :: sepfmt, b :: fmt when Pervasives.(=) a b -> get_tail (sepfmt, fmt) (* FIXME *) + | (loc,a) :: sepfmt, (_,b) :: fmt when Pervasives.(=) a b -> get_tail (sepfmt, fmt) (* FIXME *) | [], tail -> skip_var_in_recursive_format tail - | _ -> user_err Pp.(str "The format is not the same on the right and left hand side of the special token \"..\".") in - let slfmt, fmt = get_head fmt in + | (loc,_) :: _, ([] | (_,UnpTerminal _) :: _)-> error_not_same ?loc () + | _, (loc,_)::_ -> error_not_same ?loc () in + let loc, slfmt, fmt = get_head fmt in slfmt, get_tail (slfmt, fmt) let hunks_of_format (from,(vars,typs)) symfmt = let rec aux = function - | symbs, (UnpTerminal s' as u) :: fmt + | symbs, (_,(UnpTerminal s' as u)) :: fmt when String.equal s' (String.make (String.length s') ' ') -> let symbs, l = aux (symbs,fmt) in symbs, u :: l - | Terminal s :: symbs, (UnpTerminal s') :: fmt + | Terminal s :: symbs, (_,UnpTerminal s') :: fmt when String.equal s (String.drop_simple_quotes s') -> let symbs, l = aux (symbs,fmt) in symbs, UnpTerminal s :: l - | NonTerminal s :: symbs, UnpTerminal s' :: fmt when Id.equal s (Id.of_string s') -> + | NonTerminal s :: symbs, (_,UnpTerminal s') :: fmt when Id.equal s (Id.of_string s') -> let i = index_id s vars in let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in let symbs, l = aux (symbs,fmt) in symbs, UnpMetaVar (i,prec) :: l - | symbs, UnpBox (a,b) :: fmt -> + | symbs, (_,UnpBox (a,b)) :: fmt -> let symbs', b' = aux (symbs,b) in let symbs', l = aux (symbs',fmt) in - symbs', UnpBox (a,b') :: l - | symbs, (UnpCut _ as u) :: fmt -> + symbs', UnpBox (a,List.map (fun x -> (None,x)) b') :: l + | symbs, (_,(UnpCut _ as u)) :: fmt -> let symbs, l = aux (symbs,fmt) in symbs, u :: l | SProdList (m,sl) :: symbs, fmt -> let i = index_id m vars in @@ -546,7 +552,7 @@ let hunks_of_format (from,(vars,typs)) symfmt = let _,prec = precedence_of_entry_type from typ in let slfmt,fmt = read_recursive_format sl fmt in let sl, slfmt = aux (sl,slfmt) in - if not (List.is_empty sl) then error_format (); + if not (List.is_empty sl) then error_format ?loc:(fst (List.last fmt)) (); let symbs, l = aux (symbs,fmt) in let hunk = match typ with | ETConstr _ -> UnpListMetaVar (i,prec,slfmt) @@ -556,7 +562,7 @@ let hunks_of_format (from,(vars,typs)) symfmt = | _ -> assert false in symbs, hunk :: l | symbs, [] -> symbs, [] - | _, _ -> error_format () + | _, fmt -> error_format ?loc:(fst (List.hd fmt)) () in match aux symfmt with | [], l -> l @@ -795,7 +801,7 @@ type notation_modifier = { (* common to syn_data below *) only_parsing : bool; only_printing : bool; - compat : compat_version option; + compat : Flags.compat_version option; format : string Loc.located option; extra : (string * string) list; } @@ -1074,7 +1080,7 @@ module SynData = struct (* Fields coming from the vernac-level modifiers *) only_parsing : bool; only_printing : bool; - compat : compat_version option; + compat : Flags.compat_version option; format : string Loc.located option; extra : (string * string) list; @@ -1390,7 +1396,7 @@ let add_notation_interpretation ((loc,df),c,sc) = let set_notation_for_interpretation impls ((_,df),c,sc) = (try ignore - (silently (fun () -> add_notation_interpretation_core false df ~impls c sc false false None) ()); + (Flags.silently (fun () -> add_notation_interpretation_core false df ~impls c sc false false None) ()); with NoSyntaxRule -> user_err Pp.(str "Parsing rule for this notation has to be previously declared.")); Option.iter (fun sc -> Notation.open_close_scope (false,true,sc)) sc diff --git a/vernac/mltop.ml b/vernac/mltop.ml index e8a0ba3dda..1edbd1a850 100644 --- a/vernac/mltop.ml +++ b/vernac/mltop.ml @@ -9,7 +9,6 @@ open CErrors open Util open Pp -open Flags open Libobject open System @@ -365,7 +364,7 @@ let trigger_ml_object verb cache reinit ?path name = else begin let file = file_of_name (Option.default name path) in let path = - if_verbose_load (verb && not !quiet) load_ml_object name ?path file in + if_verbose_load (verb && not !Flags.quiet) load_ml_object name ?path file in add_loaded_module name (Some path); if cache then perform_cache_obj name end diff --git a/vernac/obligations.ml b/vernac/obligations.ml index a4fe49020a..81218308f9 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -304,7 +304,7 @@ type program_info_aux = { prg_body: constr; prg_type: constr; prg_ctx: Evd.evar_universe_context; - prg_pl: Id.t Loc.located list option; + prg_univdecl: Univdecls.universe_decl; prg_obligations: obligations; prg_deps : Id.t list; prg_fixkind : fixpoint_kind option ; @@ -474,8 +474,7 @@ let declare_definition prg = (Evd.evar_universe_context_subst prg.prg_ctx) in let opaque = prg.prg_opaque in let fix_exn = Hook.get get_fix_exn () in - let pl, ctx = - Evd.universe_context ?names:prg.prg_pl (Evd.from_ctx prg.prg_ctx) in + let pl, ctx = Evd.check_univ_decl (Evd.from_ctx prg.prg_ctx) prg.prg_univdecl in let ce = definition_entry ~fix_exn ~opaque ~types:(nf typ) ~poly:(pi2 prg.prg_kind) @@ -658,7 +657,7 @@ let declare_obligation prg obl body ty uctx = else Some (TermObl (it_mkLambda_or_LetIn_or_clean (mkApp (mkConst constant, args)) ctx)) } -let init_prog_info ?(opaque = false) sign n pl b t ctx deps fixkind +let init_prog_info ?(opaque = false) sign n udecl b t ctx deps fixkind notations obls impls kind reduce hook = let obls', b = match b with @@ -679,7 +678,7 @@ let init_prog_info ?(opaque = false) sign n pl b t ctx deps fixkind obls, b in { prg_name = n ; prg_body = b; prg_type = reduce t; - prg_ctx = ctx; prg_pl = pl; + prg_ctx = ctx; prg_univdecl = udecl; prg_obligations = (obls', Array.length obls'); prg_deps = deps; prg_fixkind = fixkind ; prg_notations = notations ; prg_implicits = impls; prg_kind = kind; prg_reduce = reduce; @@ -847,9 +846,9 @@ let obligation_terminator name num guard hook auto pf = let obl = obls.(num) in let status = match obl.obl_status, opq with - | (_, Evar_kinds.Expand), Vernacexpr.Opaque _ -> err_not_transp () - | (true, _), Vernacexpr.Opaque _ -> err_not_transp () - | (false, _), Vernacexpr.Opaque _ -> Evar_kinds.Define true + | (_, Evar_kinds.Expand), Vernacexpr.Opaque -> err_not_transp () + | (true, _), Vernacexpr.Opaque -> err_not_transp () + | (false, _), Vernacexpr.Opaque -> Evar_kinds.Define true | (_, Evar_kinds.Define true), Vernacexpr.Transparent -> Evar_kinds.Define false | (_, status), Vernacexpr.Transparent -> status in @@ -889,7 +888,7 @@ in let ctx' = Evd.merge_universe_subst evd (Evd.universe_subst (Evd.from_ctx ctx')) in Univ.Instance.empty, Evd.evar_universe_context ctx' else - let (_, uctx) = UState.universe_context ctx' in + let (_, uctx) = UState.universe_context ~names:[] ~extensible:true ctx' in Univ.UContext.instance uctx, ctx' in let obl = { obl with obl_body = Some (DefinedObl (cst, inst)) } in @@ -1068,11 +1067,12 @@ let show_term n = Printer.pr_constr_env (Global.env ()) Evd.empty prg.prg_type ++ spc () ++ str ":=" ++ fnl () ++ Printer.pr_constr_env (Global.env ()) Evd.empty prg.prg_body) -let add_definition n ?term t ctx ?pl ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic +let add_definition n ?term t ctx ?(univdecl=Univdecls.default_univ_decl) + ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic ?(reduce=reduce) ?(hook=Lemmas.mk_hook (fun _ _ _ -> ())) ?(opaque = false) obls = let sign = Decls.initialize_named_context_for_proof () in let info = Id.print n ++ str " has type-checked" in - let prg = init_prog_info sign ~opaque n pl term t ctx [] None [] obls implicits kind reduce hook in + let prg = init_prog_info sign ~opaque n univdecl term t ctx [] None [] obls implicits kind reduce hook in let obls,_ = prg.prg_obligations in if Int.equal (Array.length obls) 0 then ( Flags.if_verbose Feedback.msg_info (info ++ str "."); @@ -1087,13 +1087,14 @@ let add_definition n ?term t ctx ?pl ?(implicits=[]) ?(kind=Global,false,Definit | Remain rem -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some n)) (); res | _ -> res) -let add_mutual_definitions l ctx ?pl ?tactic ?(kind=Global,false,Definition) ?(reduce=reduce) +let add_mutual_definitions l ctx ?(univdecl=Univdecls.default_univ_decl) ?tactic + ?(kind=Global,false,Definition) ?(reduce=reduce) ?(hook=Lemmas.mk_hook (fun _ _ _ -> ())) ?(opaque = false) notations fixkind = let sign = Decls.initialize_named_context_for_proof () in let deps = List.map (fun (n, b, t, imps, obls) -> n) l in List.iter (fun (n, b, t, imps, obls) -> - let prg = init_prog_info sign ~opaque n pl (Some b) t ctx deps (Some fixkind) + let prg = init_prog_info sign ~opaque n univdecl (Some b) t ctx deps (Some fixkind) notations obls imps kind reduce hook in progmap_add n (CEphemeron.create prg)) l; let _defined = diff --git a/vernac/obligations.mli b/vernac/obligations.mli index 5614403ba5..11c2553ae1 100644 --- a/vernac/obligations.mli +++ b/vernac/obligations.mli @@ -53,7 +53,7 @@ val default_tactic : unit Proofview.tactic ref val add_definition : Names.Id.t -> ?term:Term.constr -> Term.types -> Evd.evar_universe_context -> - ?pl:(Id.t Loc.located list) -> (* Universe binders *) + ?univdecl:Univdecls.universe_decl -> (* Universe binders and constraints *) ?implicits:(Constrexpr.explicitation * (bool * bool * bool)) list -> ?kind:Decl_kinds.definition_kind -> ?tactic:unit Proofview.tactic -> @@ -71,7 +71,7 @@ val add_mutual_definitions : (Names.Id.t * Term.constr * Term.types * (Constrexpr.explicitation * (bool * bool * bool)) list * obligation_info) list -> Evd.evar_universe_context -> - ?pl:(Id.t Loc.located list) -> (* Universe binders *) + ?univdecl:Univdecls.universe_decl -> (* Universe binders and constraints *) ?tactic:unit Proofview.tactic -> ?kind:Decl_kinds.definition_kind -> ?reduce:(Term.constr -> Term.constr) -> diff --git a/vernac/record.ml b/vernac/record.ml index a2e443e5f7..4fb607deca 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -95,8 +95,8 @@ let binders_of_decls = List.map binder_of_decl let typecheck_params_and_fields finite def id pl t ps nots fs = let env0 = Global.env () in - let ctx = Evd.make_evar_universe_context env0 pl in - let evars = ref (Evd.from_ctx ctx) in + let evd, decl = Univdecls.interp_univ_decl_opt env0 pl in + let evars = ref evd in let _ = let error bk (loc, name) = match bk, name with @@ -165,9 +165,10 @@ let typecheck_params_and_fields finite def id pl t ps nots fs = 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 evars decl in List.iter (iter_constr ce) (List.rev newps); List.iter (iter_constr ce) (List.rev newfs); - Evd.universe_context ?names:pl evars, typ, template, imps, newps, impls, newfs + univs, typ, template, imps, newps, impls, newfs let degenerate_decl decl = let id = match RelDecl.get_name decl with diff --git a/vernac/record.mli b/vernac/record.mli index 9a0c9ef9d1..aea474581e 100644 --- a/vernac/record.mli +++ b/vernac/record.mli @@ -39,7 +39,7 @@ val declare_structure : val definition_structure : inductive_kind * Decl_kinds.cumulative_inductive_flag * Decl_kinds.polymorphic * - Decl_kinds.recursivity_kind * plident with_coercion * local_binder_expr list * + Decl_kinds.recursivity_kind * ident_decl with_coercion * local_binder_expr list * (local_decl_expr with_instance with_priority with_notation) list * Id.t * constr_expr option -> global_reference diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml index e7b14309d1..6a10eb43a2 100644 --- a/vernac/topfmt.ml +++ b/vernac/topfmt.ml @@ -292,10 +292,11 @@ let emacs_logger = gen_logger Emacs.quote_info Emacs.quote_warning (* This is specific to the toplevel *) let pr_loc loc = let fname = loc.Loc.fname in - if CString.equal fname "" then + match fname with + | Loc.ToplevelInput -> Loc.(str"Toplevel input, characters " ++ int loc.bp ++ str"-" ++ int loc.ep ++ str":") - else + | Loc.InFile fname -> Loc.(str"File " ++ str "\"" ++ str fname ++ str "\"" ++ str", line " ++ int loc.line_nb ++ str", characters " ++ int (loc.bp-loc.bol_pos) ++ str"-" ++ int (loc.ep-loc.bol_pos) ++ diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index d2ba9eb1cc..ccae4359e3 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -11,7 +11,6 @@ open Pp open CErrors open Util -open Flags open Names open Nameops open Term @@ -409,9 +408,10 @@ let dump_global r = (**********) (* Syntax *) -let vernac_syntax_extension locality local = +let vernac_syntax_extension locality local infix l = let local = enforce_module_locality locality local in - Metasyntax.add_syntax_extension local + if infix then Metasyntax.check_infix_modifiers (snd l); + Metasyntax.add_syntax_extension local l let vernac_delimiters sc = function | Some lr -> Metasyntax.add_delimiters sc lr @@ -507,7 +507,7 @@ let vernac_exact_proof c = (* spiwack: for simplicity I do not enforce that "Proof proof_term" is called only at the begining of a proof. *) let status = Pfedit.by (Tactics.exact_proof c) in - save_proof (Vernacexpr.(Proved(Opaque None,None))); + save_proof (Vernacexpr.(Proved(Opaque,None))); if not status then Feedback.feedback Feedback.AddedAxiom let vernac_assumption locality poly (local, kind) l nl = @@ -656,7 +656,7 @@ let vernac_declare_module export (loc, id) binders_ast mty_ast = id binders_ast (Enforce mty_ast) [] in Dumpglob.dump_moddef ?loc mp "mod"; - if_verbose Feedback.msg_info (str "Module " ++ pr_id id ++ str " is declared"); + Flags.if_verbose Feedback.msg_info (str "Module " ++ pr_id id ++ str " is declared"); Option.iter (fun export -> vernac_import export [Ident (Loc.tag id)]) export let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l = @@ -677,7 +677,7 @@ let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l = export id binders_ast mty_ast_o in Dumpglob.dump_moddef ?loc mp "mod"; - if_verbose Feedback.msg_info + Flags.if_verbose Feedback.msg_info (str "Interactive Module " ++ pr_id id ++ str " started"); List.iter (fun (export,id) -> @@ -695,7 +695,7 @@ let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l = id binders_ast mty_ast_o mexpr_ast_l in Dumpglob.dump_moddef ?loc mp "mod"; - if_verbose Feedback.msg_info + Flags.if_verbose Feedback.msg_info (str "Module " ++ pr_id id ++ str " is defined"); Option.iter (fun export -> vernac_import export [Ident (Loc.tag id)]) export @@ -703,7 +703,7 @@ let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l = let vernac_end_module export (loc,id as lid) = let mp = Declaremods.end_module () in Dumpglob.dump_modref ?loc mp "mod"; - if_verbose Feedback.msg_info (str "Module " ++ pr_id id ++ str " is defined"); + Flags.if_verbose Feedback.msg_info (str "Module " ++ pr_id id ++ str " is defined"); Option.iter (fun export -> vernac_import export [Ident lid]) export let vernac_declare_module_type (loc,id) binders_ast mty_sign mty_ast_l = @@ -724,7 +724,7 @@ let vernac_declare_module_type (loc,id) binders_ast mty_sign mty_ast_l = id binders_ast mty_sign in Dumpglob.dump_moddef ?loc mp "modtype"; - if_verbose Feedback.msg_info + Flags.if_verbose Feedback.msg_info (str "Interactive Module Type " ++ pr_id id ++ str " started"); List.iter (fun (export,id) -> @@ -743,13 +743,13 @@ let vernac_declare_module_type (loc,id) binders_ast mty_sign mty_ast_l = id binders_ast mty_sign mty_ast_l in Dumpglob.dump_moddef ?loc mp "modtype"; - if_verbose Feedback.msg_info + Flags.if_verbose Feedback.msg_info (str "Module Type " ++ pr_id id ++ str " is defined") let vernac_end_modtype (loc,id) = let mp = Declaremods.end_modtype () in Dumpglob.dump_modref ?loc mp "modtype"; - if_verbose Feedback.msg_info (str "Module Type " ++ pr_id id ++ str " is defined") + Flags.if_verbose Feedback.msg_info (str "Module Type " ++ pr_id id ++ str " is defined") let vernac_include l = Declaremods.declare_include Modintern.interp_module_ast l @@ -817,7 +817,7 @@ let vernac_coercion locality poly local ref qids qidt = let source = cl_of_qualid qids in let ref' = smart_global ref in Class.try_add_new_coercion_with_target ref' ~local poly ~source ~target; - if_verbose Feedback.msg_info (pr_global ref' ++ str " is now a coercion") + Flags.if_verbose Feedback.msg_info (pr_global ref' ++ str " is now a coercion") let vernac_identity_coercion locality poly local id qids qidt = let local = enforce_locality locality local in @@ -919,7 +919,7 @@ let vernac_chdir = function so we make it an error. *) user_err Pp.(str ("Cd failed: " ^ err)) end; - if_verbose Feedback.msg_info (str (Sys.getcwd())) + Flags.if_verbose Feedback.msg_info (str (Sys.getcwd())) (********************) @@ -1301,7 +1301,7 @@ let _ = optname = "automatic introduction of variables"; optkey = ["Automatic";"Introduction"]; optread = Flags.is_auto_intros; - optwrite = make_auto_intros } + optwrite = Flags.make_auto_intros } let _ = declare_bool_option @@ -1555,7 +1555,7 @@ let vernac_check_may_eval ?loc redexp glopt rc = let sigma' = Evarconv.solve_unif_constraints_with_heuristics env sigma' in Evarconv.check_problems_are_solved env sigma'; let sigma',nf = Evarutil.nf_evars_and_universes sigma' in - let pl, uctx = Evd.universe_context sigma' in + let pl, uctx = Evd.universe_context ~names:[] ~extensible:true sigma' in let env = Environ.push_context uctx (Evarutil.nf_env_evar sigma' env) in let c = nf c in let j = @@ -1902,7 +1902,7 @@ let vernac_load interp fname = let input = let longfname = Loadpath.locate_file fname in let in_chan = open_utf8_file_in longfname in - Pcoq.Gram.parsable ~file:longfname (Stream.of_channel in_chan) in + Pcoq.Gram.parsable ~file:(Loc.InFile longfname) (Stream.of_channel in_chan) in try while true do interp (snd (parse_sentence input)) done with End_of_input -> () @@ -1923,7 +1923,6 @@ let interp ?proof ?loc locality poly c = | VernacTime _ -> assert false | VernacRedirect _ -> assert false | VernacTimeout _ -> assert false - | VernacStm _ -> assert false (* The STM should handle that, but LOAD bypasses the STM... *) | VernacAbortAll -> CErrors.user_err (str "AbortAll cannot be used through the Load command") @@ -1950,8 +1949,8 @@ let interp ?proof ?loc locality poly c = | VernacLocal _ -> assert false (* Syntax *) - | VernacSyntaxExtension (local,sl) -> - vernac_syntax_extension locality local sl + | VernacSyntaxExtension (infix, local,sl) -> + vernac_syntax_extension locality local infix sl | VernacDelimiters (sc,lr) -> vernac_delimiters sc lr | VernacBindScope (sc,rl) -> vernac_bind_scope sc rl | VernacOpenCloseScope (local, s) -> vernac_open_close_scope locality local s @@ -2049,7 +2048,7 @@ let interp ?proof ?loc locality poly c = | VernacSearch (s,g,r) -> vernac_search ?loc s g r | VernacLocate l -> vernac_locate l | VernacRegister (id, r) -> vernac_register id r - | VernacComments l -> if_verbose Feedback.msg_info (str "Comments ok\n") + | VernacComments l -> Flags.if_verbose Feedback.msg_info (str "Comments ok\n") (* Proof management *) | VernacGoal t -> vernac_start_proof locality poly Theorem [None,([],t)] @@ -2175,7 +2174,7 @@ let with_fail b f = | HasNotFailed -> user_err ~hdr:"Fail" (str "The command has not failed!") | HasFailed msg -> - if not !Flags.quiet || !test_mode || !ide_slave then Feedback.msg_info + if not !Flags.quiet || !Flags.test_mode || !Flags.ide_slave then Feedback.msg_info (str "The command has indeed failed with message:" ++ fnl () ++ msg) | _ -> assert false end @@ -2184,10 +2183,6 @@ let interp ?(verbosely=true) ?proof (loc,c) = let orig_program_mode = Flags.is_program_mode () in let rec aux ?locality ?polymorphism isprogcmd = function - (* This assert case will be removed when fake_ide can understand - completion feedback *) - | VernacStm _ -> assert false (* Done by Stm *) - | VernacProgram c when not isprogcmd -> aux ?locality ?polymorphism true c | VernacProgram _ -> user_err Pp.(str "Program mode specified twice") | VernacLocal (b, c) when Option.is_empty locality -> diff --git a/vernac/vernacprop.ml b/vernac/vernacprop.ml index fc11bcf4a0..3cff1f14c0 100644 --- a/vernac/vernacprop.ml +++ b/vernac/vernacprop.ml @@ -17,8 +17,7 @@ let rec is_navigation_vernac = function | VernacResetName _ | VernacBacktrack _ | VernacBackTo _ - | VernacBack _ - | VernacStm _ -> true + | VernacBack _ -> true | VernacRedirect (_, (_,c)) | VernacTime (_,c) -> is_navigation_vernac c (* Time Back* is harmless *) |