diff options
393 files changed, 13117 insertions, 4408 deletions
diff --git a/.gitattributes b/.gitattributes index f2c096f2d6..51fa208a73 100644 --- a/.gitattributes +++ b/.gitattributes @@ -2,6 +2,8 @@ .gitignore export-ignore .mailmap export-ignore +*.out -whitespace + *.asciidoc whitespace=trailing-space,tab-in-indent *.bat whitespace=cr-at-eol,trailing-space,tab-in-indent *.bib whitespace=trailing-space,tab-in-indent diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index fcf6413be3..e56693eac2 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -71,12 +71,14 @@ before_script: - echo 'end:coq.config' - echo 'start:coq.build' + - make -j ${NJOBS} byte - make -j ${NJOBS} - make test-suite/misc/universes/all_stdlib.v - echo 'end:coq:build' - echo 'start:coq.install' - make install + - make install-byte - cp bin/fake_ide _install_ci/bin/ - echo 'end:coq.install' @@ -103,7 +105,7 @@ before_script: - set +e variables: &warnings-variables - EXTRA_CONF: "-native-compiler yes -coqide opt" + EXTRA_CONF: "-native-compiler yes -coqide byte -byte-only" EXTRA_PACKAGES: "$COQIDE_PACKAGES" EXTRA_OPAM: "$COQIDE_OPAM" @@ -266,7 +268,7 @@ ci-color: <<: *ci-template variables: <<: *ci-template-vars - EXTRA_PACKAGES: "$TIMING_PACKAGES subversion" + EXTRA_PACKAGES: "$TIMING_PACKAGES" ci-compcert: <<: *ci-template @@ -284,6 +286,9 @@ ci-coquelicot: <<: *ci-template-vars EXTRA_PACKAGES: "$TIMING_PACKAGES autoconf" +ci-equations: + <<: *ci-template + ci-geocoq: <<: *ci-template allow_failure: true diff --git a/.travis.yml b/.travis.yml index 3ebfbefd20..83a4e7fdda 100644 --- a/.travis.yml +++ b/.travis.yml @@ -39,6 +39,7 @@ env: - LABLGTK_BE="lablgtk.2.18.6 lablgtk-extras.1.6" - NATIVE_COMP="yes" - COQ_DEST="-local" + - MAIN_TARGET="world" # Main test suites matrix: - TEST_TARGET="test-suite" COMPILER="4.02.3+32bit" @@ -50,6 +51,7 @@ env: - TEST_TARGET="ci-compcert TIMED=1" - TEST_TARGET="ci-coq-dpdgraph" EXTRA_OPAM="ocamlgraph" - TEST_TARGET="ci-coquelicot TIMED=1" + - TEST_TARGET="ci-equations TIMED=1" - TEST_TARGET="ci-geocoq TIMED=1" - TEST_TARGET="ci-fiat-crypto TIMED=1" - TEST_TARGET="ci-fiat-parsers TIMED=1" @@ -138,8 +140,8 @@ matrix: # Ocaml warnings with two compilers - env: - - TEST_TARGET="coqocaml" - - EXTRA_CONF="-coqide opt -warn-error" + - MAIN_TARGET="coqocaml" + - EXTRA_CONF="-byte-only -coqide byte -warn-error" - EXTRA_OPAM="hevea ${LABLGTK}" # dummy target - BUILD_TARGET="clean" @@ -154,11 +156,11 @@ matrix: - libgtksourceview2.0-dev - env: - - TEST_TARGET="coqocaml" + - MAIN_TARGET="coqocaml" - COMPILER="${COMPILER_BE}" - FINDLIB_VER="${FINDLIB_VER_BE}" - CAMLP5_VER="${CAMLP5_VER_BE}" - - EXTRA_CONF="-coqide opt -warn-error" + - EXTRA_CONF="-byte-only -coqide byte -warn-error" - EXTRA_OPAM="num hevea ${LABLGTK_BE}" # dummy target - BUILD_TARGET="clean" @@ -223,11 +225,11 @@ script: - echo -en 'travis_fold:end:coq.config\\r' - echo 'Building Coq...' && echo -en 'travis_fold:start:coq.build\\r' -- make -j ${NJOBS} +- make -j ${NJOBS} ${MAIN_TARGET} - echo -en 'travis_fold:end:coq.build\\r' - echo 'Running tests...' && echo -en 'travis_fold:start:coq.test\\r' -- ${TW} make -j ${NJOBS} ${TEST_TARGET} +- if [ -n "${TEST_TARGET}" ]; then ${TW} make -j ${NJOBS} ${TEST_TARGET}; fi - echo -en 'travis_fold:end:coq.test\\r' - set +e diff --git a/API/API.ml b/API/API.ml index f588fe193a..378c03ee4f 100644 --- a/API/API.ml +++ b/API/API.ml @@ -20,10 +20,6 @@ (******************************************************************************) module Coq_config = Coq_config -(* Reexporting deprecated symbols throu module aliases triggers a - warning in 4.06.0 *) -[@@@ocaml.warning "-3"] - (******************************************************************************) (* Kernel *) (******************************************************************************) @@ -275,6 +271,7 @@ module Command = Command module Classes = Classes (* module Record *) (* module Assumptions *) +module Vernacstate = Vernacstate module Vernacinterp = Vernacinterp module Mltop = Mltop module Topfmt = Topfmt diff --git a/API/API.mli b/API/API.mli index 704f1a3569..3ed008ff5f 100644 --- a/API/API.mli +++ b/API/API.mli @@ -20,10 +20,6 @@ See below in the file for their concrete position. *) -(* Reexporting deprecated symbols throu module aliases triggers a - warning in 4.06.0 *) -[@@@ocaml.warning "-3"] - (************************************************************************) (* Modules from config/ *) (************************************************************************) @@ -87,6 +83,7 @@ sig val repr : t -> Id.t list val equal : t -> t -> bool val to_string : t -> string + val print : t -> Pp.t end module MBId : sig @@ -327,7 +324,7 @@ sig type identifier = Id.t [@@ocaml.deprecated "Alias of Names"] - module Idset : Set.S with type elt = identifier and type t = Id.Set.t + module Idset : Set.S with type elt = Id.t and type t = Id.Set.t [@@ocaml.deprecated "Alias of Id.Set.t"] end @@ -347,7 +344,7 @@ sig module LSet : sig - include CSig.SetS with type elt = universe_level + include CSig.SetS with type elt = Level.t val pr : (Level.t -> Pp.t) -> t -> Pp.t end @@ -375,7 +372,7 @@ sig type constraint_type = Lt | Le | Eq - type univ_constraint = universe_level * constraint_type * universe_level + type univ_constraint = Level.t * constraint_type * Level.t module Constraint : sig include Set.S with type elt = univ_constraint @@ -437,7 +434,7 @@ sig module LMap : sig - include CMap.ExtS with type key = universe_level and module Set := LSet + include CMap.ExtS with type key = Level.t and module Set := LSet val union : 'a t -> 'a t -> 'a t val diff : 'a t -> 'a t -> 'a t @@ -446,8 +443,8 @@ sig end type 'a universe_map = 'a LMap.t - type universe_subst = universe universe_map - type universe_level_subst = universe_level universe_map + type universe_subst = Universe.t universe_map + type universe_level_subst = Level.t universe_map val enforce_leq : Universe.t constraint_function val pr_uni : Universe.t -> Pp.t @@ -481,6 +478,7 @@ sig type family = InProp | InSet | InType val family : t -> family + val univ_of_sort : t -> Univ.Universe.t end module Evar : @@ -493,6 +491,8 @@ sig val equal : t -> t -> bool + val print : t -> Pp.t + (** a set of unique identifiers of some {i evars} *) module Set : Set.S with type elt = t module Map : CMap.ExtS with type key = t and module Set := Set @@ -501,6 +501,7 @@ end module Constr : sig + open Names type t @@ -517,12 +518,16 @@ sig type metavariable = int type existential_key = Evar.t - type 'constr pexistential = existential_key * 'constr array + [@@ocaml.deprecated "use Evar.t"] + + type 'constr pexistential = Evar.t * 'constr array type 'a puniverses = 'a Univ.puniverses - type pconstant = Constant.t puniverses - type pinductive = inductive puniverses - type pconstructor = constructor puniverses + [@@ocaml.deprecated "use Univ.puniverses"] + + type pconstant = Constant.t Univ.puniverses + type pinductive = inductive Univ.puniverses + type pconstructor = constructor Univ.puniverses type ('constr, 'types) prec_declaration = Name.t array * 'types array * 'constr array @@ -578,13 +583,13 @@ sig val kind : constr -> (constr, types, Sorts.t, Univ.Instance.t) kind_of_term val of_kind : (constr, types, Sorts.t, Univ.Instance.t) kind_of_term -> constr -val map_with_binders : - ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr -val map : (constr -> constr) -> constr -> constr + val map_with_binders : + ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr + val map : (constr -> constr) -> constr -> constr -val fold : ('a -> constr -> 'a) -> 'a -> constr -> 'a -val iter : (constr -> unit) -> constr -> unit -val compare_head : (constr -> constr -> bool) -> constr -> constr -> bool + val fold : ('a -> constr -> 'a) -> 'a -> constr -> 'a + val iter : (constr -> unit) -> constr -> unit + val compare_head : (constr -> constr -> bool) -> constr -> constr -> bool val equal : t -> t -> bool val eq_constr_nounivs : t -> t -> bool @@ -595,7 +600,7 @@ val compare_head : (constr -> constr -> bool) -> constr -> constr -> bool val mkRel : int -> t val mkVar : Id.t -> t val mkMeta : metavariable -> t - type existential = existential_key * constr array + type existential = Evar.t * constr array val mkEvar : existential -> t val mkSort : Sorts.t -> t val mkProp : t @@ -606,7 +611,7 @@ val compare_head : (constr -> constr -> bool) -> constr -> constr -> bool val mkLambda : Name.t * types * t -> t val mkLetIn : Name.t * t * types * t -> t val mkApp : t * t array -> t - val map_puniverses : ('a -> 'b) -> 'a puniverses -> 'b puniverses + val map_puniverses : ('a -> 'b) -> 'a Univ.puniverses -> 'b Univ.puniverses type rec_declaration = Name.t array * types array * constr array type fixpoint = (int array * int) * rec_declaration @@ -626,6 +631,109 @@ val compare_head : (constr -> constr -> bool) -> constr -> constr -> bool val mkCase : case_info * t * t * t array -> t + (** {6 Simple case analysis} *) + val isRel : constr -> bool + val isRelN : int -> constr -> bool + val isVar : constr -> bool + val isVarId : Id.t -> constr -> bool + val isInd : constr -> bool + val isEvar : constr -> bool + val isMeta : constr -> bool + val isEvar_or_Meta : constr -> bool + val isSort : constr -> bool + val isCast : constr -> bool + val isApp : constr -> bool + val isLambda : constr -> bool + val isLetIn : constr -> bool + val isProd : constr -> bool + val isConst : constr -> bool + val isConstruct : constr -> bool + val isFix : constr -> bool + val isCoFix : constr -> bool + val isCase : constr -> bool + val isProj : constr -> bool + + val is_Prop : constr -> bool + val is_Set : constr -> bool + val isprop : constr -> bool + val is_Type : constr -> bool + val iskind : constr -> bool + val is_small : Sorts.t -> bool + + (** {6 Term destructors } *) + (** Destructor operations are partial functions and + @raise DestKO if the term has not the expected form. *) + + exception DestKO + + (** Destructs a de Bruijn index *) + val destRel : constr -> int + + (** Destructs an existential variable *) + val destMeta : constr -> metavariable + + (** Destructs a variable *) + val destVar : constr -> Id.t + + (** Destructs a sort. [is_Prop] recognizes the sort {% \textsf{%}Prop{% }%}, whether + [isprop] recognizes both {% \textsf{%}Prop{% }%} and {% \textsf{%}Set{% }%}. *) + val destSort : constr -> Sorts.t + + (** Destructs a casted term *) + val destCast : constr -> constr * cast_kind * constr + + (** Destructs the product {% $ %}(x:t_1)t_2{% $ %} *) + val destProd : types -> Name.t * types * types + + (** Destructs the abstraction {% $ %}[x:t_1]t_2{% $ %} *) + val destLambda : constr -> Name.t * types * constr + + (** Destructs the let {% $ %}[x:=b:t_1]t_2{% $ %} *) + val destLetIn : constr -> Name.t * constr * types * constr + + (** Destructs an application *) + val destApp : constr -> constr * constr array + + (** Decompose any term as an applicative term; the list of args can be empty *) + val decompose_app : constr -> constr * constr list + + (** Same as [decompose_app], but returns an array. *) + val decompose_appvect : constr -> constr * constr array + + (** Destructs a constant *) + val destConst : constr -> Constant.t Univ.puniverses + + (** Destructs an existential variable *) + val destEvar : constr -> existential + + (** Destructs a (co)inductive type *) + val destInd : constr -> inductive Univ.puniverses + + (** Destructs a constructor *) + val destConstruct : constr -> constructor Univ.puniverses + + (** Destructs a [match c as x in I args return P with ... | + Ci(...yij...) => ti | ... end] (or [let (..y1i..) := c as x in I args + return P in t1], or [if c then t1 else t2]) + @return [(info,c,fun args x => P,[|...|fun yij => ti| ...|])] + where [info] is pretty-printing information *) + val destCase : constr -> case_info * constr * constr * constr array + + (** Destructs a projection *) + val destProj : constr -> Projection.t * constr + + (** Destructs the {% $ %}i{% $ %}th function of the block + [Fixpoint f{_ 1} ctx{_ 1} = b{_ 1} + with f{_ 2} ctx{_ 2} = b{_ 2} + ... + with f{_ n} ctx{_ n} = b{_ n}], + where the length of the {% $ %}j{% $ %}th context is {% $ %}ij{% $ %}. + *) + val destFix : constr -> fixpoint + + type cofixpoint = int * rec_declaration + val destCoFix : constr -> cofixpoint + end module Context : @@ -856,6 +964,7 @@ end module Term : sig + open Constr type sorts_family = Sorts.family = InProp | InSet | InType [@@ocaml.deprecated "Alias of Sorts.family"] @@ -863,15 +972,10 @@ sig [@@ocaml.deprecated "Alias of Sorts.contents"] type sorts = Sorts.t = - | Prop of contents + | Prop of Sorts.contents | Type of Univ.Universe.t [@@ocaml.deprecated "alias of API.Sorts.t"] - type constr = Constr.t - [@@ocaml.deprecated "Alias of Constr.t"] - type types = Constr.t - [@@ocaml.deprecated "Alias of Constr.types"] - type metavariable = int [@@ocaml.deprecated "Alias of Constr.metavariable"] @@ -890,11 +994,11 @@ sig type 'a puniverses = 'a Univ.puniverses [@@ocaml.deprecated "Alias of Constr.puniverses"] - type pconstant = Names.Constant.t puniverses + type pconstant = Names.Constant.t Univ.puniverses [@@ocaml.deprecated "Alias of Constr.pconstant"] - type pinductive = Names.inductive puniverses + type pinductive = Names.inductive Univ.puniverses [@@ocaml.deprecated "Alias of Constr.pinductive"] - type pconstructor = Names.constructor puniverses + type pconstructor = Names.constructor Univ.puniverses [@@ocaml.deprecated "Alias of Constr.pconstructor"] type case_style = Constr.case_style = | LetStyle @@ -907,7 +1011,7 @@ sig type case_printing = Constr.case_printing = { ind_tags : bool list; cstr_tags : bool list array; - style : case_style + style : Constr.case_style } [@@ocaml.deprecated "Alias of Constr.case_printing"] @@ -916,25 +1020,25 @@ sig ci_npar : int; ci_cstr_ndecls: int array; ci_cstr_nargs : int array; - ci_pp_info : case_printing + ci_pp_info : Constr.case_printing } [@@ocaml.deprecated "Alias of Constr.case_info"] type ('constr, 'types) pfixpoint = - (int array * int) * ('constr, 'types) prec_declaration + (int array * int) * ('constr, 'types) Constr.prec_declaration [@@ocaml.deprecated "Alias of Constr.pfixpoint"] type ('constr, 'types) pcofixpoint = - int * ('constr, 'types) prec_declaration + int * ('constr, 'types) Constr.prec_declaration [@@ocaml.deprecated "Alias of Constr.pcofixpoint"] type ('constr, 'types, 'sort, 'univs) kind_of_term = ('constr, 'types, 'sort, 'univs) Constr.kind_of_term = | Rel of int | Var of Names.Id.t | Meta of Constr.metavariable - | Evar of 'constr pexistential + | Evar of 'constr Constr.pexistential | Sort of 'sort - | Cast of 'constr * cast_kind * 'types + | Cast of 'constr * Constr.cast_kind * 'types | Prod of Names.Name.t * 'types * 'types | Lambda of Names.Name.t * 'types * 'constr | LetIn of Names.Name.t * 'constr * 'types * 'constr @@ -942,22 +1046,18 @@ sig | Const of (Names.Constant.t * 'univs) | Ind of (Names.inductive * 'univs) | Construct of (Names.constructor * 'univs) - | Case of case_info * 'constr * 'constr * 'constr array - | Fix of ('constr, 'types) pfixpoint - | CoFix of ('constr, 'types) pcofixpoint + | Case of Constr.case_info * 'constr * 'constr * 'constr array + | Fix of ('constr, 'types) Constr.pfixpoint + | CoFix of ('constr, 'types) Constr.pcofixpoint | Proj of Names.Projection.t * 'constr [@@ocaml.deprecated "Alias of Constr.kind_of_term"] - type existential = Constr.existential_key * constr array + type existential = Evar.t * Constr.constr array [@@ocaml.deprecated "Alias of Constr.existential"] - type rec_declaration = Names.Name.t array * constr array * constr array + type rec_declaration = Names.Name.t array * Constr.constr array * Constr.constr array [@@ocaml.deprecated "Alias of Constr.rec_declaration"] - type fixpoint = (int array * int) * rec_declaration - [@@ocaml.deprecated "Alias of Constr.fixpoint"] - type cofixpoint = int * rec_declaration - [@@ocaml.deprecated "Alias of Constr.cofixpoint"] - val kind_of_term : constr -> (constr, types, Sorts.t, Univ.Instance.t) kind_of_term + val kind_of_term : Constr.constr -> (Constr.constr, Constr.types, Sorts.t, Univ.Instance.t) Constr.kind_of_term [@@ocaml.deprecated "Alias of Constr.kind"] - val applistc : constr -> constr list -> constr + val applistc : Constr.constr -> Constr.constr list -> Constr.constr val applist : constr * constr list -> constr [@@ocaml.deprecated "(sort of an) alias of API.Term.applistc"] @@ -971,7 +1071,7 @@ sig val mkMeta : Constr.metavariable -> constr [@@ocaml.deprecated "Alias of similarly named Constr function"] - val mkEvar : existential -> constr + val mkEvar : Constr.existential -> constr [@@ocaml.deprecated "Alias of similarly named Constr function"] val mkSort : Sorts.t -> types [@@ocaml.deprecated "Alias of similarly named Constr function"] @@ -981,7 +1081,7 @@ sig [@@ocaml.deprecated "Alias of similarly named Constr function"] val mkType : Univ.Universe.t -> types [@@ocaml.deprecated "Alias of similarly named Constr function"] - val mkCast : constr * cast_kind * constr -> constr + val mkCast : constr * Constr.cast_kind * constr -> constr [@@ocaml.deprecated "Alias of similarly named Constr function"] val mkProd : Names.Name.t * types * types -> types [@@ocaml.deprecated "Alias of similarly named Constr function"] @@ -999,11 +1099,11 @@ sig [@@ocaml.deprecated "Alias of similarly named Constr function"] val mkConstruct : Names.constructor -> constr [@@ocaml.deprecated "Alias of similarly named Constr function"] - val mkConstructU : Names.constructor puniverses -> constr + val mkConstructU : Names.constructor Univ.puniverses -> constr [@@ocaml.deprecated "Alias of similarly named Constr function"] - val mkConstructUi : (pinductive * int) -> constr + val mkConstructUi : (Constr.pinductive * int) -> constr [@@ocaml.deprecated "Alias of similarly named Constr function"] - val mkCase : case_info * constr * constr * constr array -> constr + val mkCase : Constr.case_info * constr * constr * constr array -> constr [@@ocaml.deprecated "Alias of similarly named Constr function"] val mkFix : fixpoint -> constr [@@ocaml.deprecated "Alias of similarly named Constr function"] @@ -1015,6 +1115,8 @@ sig val mkNamedProd : Names.Id.t -> types -> types -> types val decompose_app : constr -> constr * constr list + [@@ocaml.deprecated "Alias for the function in [Constr]"] + val decompose_prod : constr -> (Names.Name.t*constr) list * constr val decompose_prod_n : int -> constr -> (Names.Name.t * constr) list * constr val decompose_prod_assum : types -> Context.Rel.t * types @@ -1026,26 +1128,46 @@ sig val compose_lam : (Names.Name.t * constr) list -> constr -> constr val destSort : constr -> Sorts.t + [@@ocaml.deprecated "Alias for the function in [Constr]"] val destVar : constr -> Names.Id.t + [@@ocaml.deprecated "Alias for the function in [Constr]"] val destApp : constr -> constr * constr array + [@@ocaml.deprecated "Alias for the function in [Constr]"] val destProd : types -> Names.Name.t * types * types + [@@ocaml.deprecated "Alias for the function in [Constr]"] val destLetIn : constr -> Names.Name.t * constr * types * constr - val destEvar : constr -> existential + [@@ocaml.deprecated "Alias for the function in [Constr]"] + val destEvar : constr -> Constr.existential + [@@ocaml.deprecated "Alias for the function in [Constr]"] val destRel : constr -> int - val destConst : constr -> Names.Constant.t puniverses - val destCast : constr -> constr * cast_kind * constr + [@@ocaml.deprecated "Alias for the function in [Constr]"] + val destConst : constr -> Names.Constant.t Univ.puniverses + [@@ocaml.deprecated "Alias for the function in [Constr]"] + val destCast : constr -> constr * Constr.cast_kind * constr + [@@ocaml.deprecated "Alias for the function in [Constr]"] val destLambda : constr -> Names.Name.t * types * constr + [@@ocaml.deprecated "Alias for the function in [Constr]"] val isRel : constr -> bool + [@@ocaml.deprecated "Alias for the function in [Constr]"] val isVar : constr -> bool + [@@ocaml.deprecated "Alias for the function in [Constr]"] val isEvar : constr -> bool + [@@ocaml.deprecated "Alias for the function in [Constr]"] val isLetIn : constr -> bool + [@@ocaml.deprecated "Alias for the function in [Constr]"] val isLambda : constr -> bool + [@@ocaml.deprecated "Alias for the function in [Constr]"] val isConst : constr -> bool + [@@ocaml.deprecated "Alias for the function in [Constr]"] val isEvar_or_Meta : constr -> bool + [@@ocaml.deprecated "Alias for the function in [Constr]"] val isCast : constr -> bool + [@@ocaml.deprecated "Alias for the function in [Constr]"] val isMeta : constr -> bool + [@@ocaml.deprecated "Alias for the function in [Constr]"] val isApp : constr -> bool + [@@ocaml.deprecated "Alias for the function in [Constr]"] val fold_constr : ('a -> constr -> 'a) -> 'a -> constr -> 'a [@@ocaml.deprecated "Alias of Constr.fold"] @@ -1059,13 +1181,13 @@ sig val it_mkLambda_or_LetIn : constr -> Context.Rel.t -> constr val it_mkProd_or_LetIn : types -> Context.Rel.t -> types val prod_applist : constr -> constr list -> constr - exception DestKO + val map_constr : (constr -> constr) -> constr -> constr [@@ocaml.deprecated "Alias of Constr.map"] - val mkIndU : pinductive -> constr + val mkIndU : Constr.pinductive -> constr [@@ocaml.deprecated "Alias of Constr.mkIndU"] - val mkConstU : pconstant -> constr + val mkConstU : Constr.pconstant -> constr [@@ocaml.deprecated "Alias of Constr.mkConstU"] val map_constr_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr @@ -1092,7 +1214,7 @@ sig val is_prop_sort : Sorts.t -> bool [@@ocaml.deprecated "alias of API.Sorts.is_prop"] - type existential_key = Constr.existential_key + type existential_key = Evar.t [@@ocaml.deprecated "Alias of Constr.existential_key"] val family_of_sort : Sorts.t -> Sorts.family @@ -1104,18 +1226,31 @@ sig val constr_ord : constr -> constr -> int [@@ocaml.deprecated "alias of Term.compare"] - val destInd : constr -> Names.inductive puniverses + val destInd : constr -> Names.inductive Univ.puniverses + [@@ocaml.deprecated "Alias for the function in [Constr]"] val univ_of_sort : Sorts.t -> Univ.Universe.t + [@@ocaml.deprecated "Alias for the function in [Constr]"] val strip_lam : constr -> constr val strip_prod_assum : types -> types val decompose_lam_assum : constr -> Context.Rel.t * constr val destFix : constr -> fixpoint + [@@ocaml.deprecated "Alias for the function in [Constr]"] val compare_constr : (constr -> constr -> bool) -> constr -> constr -> bool [@@ocaml.deprecated "Alias of Constr.compare_head."] + type constr = Constr.t + [@@ocaml.deprecated "Alias of Constr.t"] + type types = Constr.t + [@@ocaml.deprecated "Alias of Constr.types"] + + type fixpoint = (int array * int) * Constr.rec_declaration + [@@ocaml.deprecated "Alias of Constr.Constr.fixpoint"] + type cofixpoint = int * Constr.rec_declaration + [@@ocaml.deprecated "Alias of Constr.cofixpoint"] + end module Mod_subst : @@ -1158,60 +1293,6 @@ sig type to_patch_substituted end -module Decl_kinds : -sig - type polymorphic = bool - type cumulative_inductive_flag = bool - type recursivity_kind = - | Finite - | CoFinite - | BiFinite - - type locality = - | Discharge - | Local - | Global - - type definition_object_kind = - | Definition - | Coercion - | SubClass - | CanonicalStructure - | Example - | Fixpoint - | CoFixpoint - | Scheme - | StructureComponent - | IdentityCoercion - | Instance - | Method - type theorem_kind = - | Theorem - | Lemma - | Fact - | Remark - | Property - | Proposition - | Corollary - type goal_object_kind = - | DefinitionBody of definition_object_kind - | Proof of theorem_kind - type goal_kind = locality * polymorphic * goal_object_kind - type assumption_object_kind = - | Definitional - | Logical - | Conjectural - type logical_kind = - | IsAssumption of assumption_object_kind - | IsDefinition of definition_object_kind - | IsProof of theorem_kind - type binding_kind = - | Explicit - | Implicit - type private_flag = bool - type definition_kind = locality * polymorphic * definition_object_kind -end - module Retroknowledge : sig type action @@ -1288,8 +1369,8 @@ sig | TemplateArity of 'b type constant_universes = - | Monomorphic_const of Univ.universe_context - | Polymorphic_const of Univ.abstract_universe_context + | Monomorphic_const of Univ.ContextSet.t + | Polymorphic_const of Univ.AUContext.t type projection_body = { proj_ind : Names.MutInd.t; @@ -1308,7 +1389,7 @@ sig type constant_body = { const_hyps : Context.Named.t; const_body : constant_def; - const_type : Term.types; + const_type : Constr.types; const_body_code : Cemitcodes.to_patch_substituted option; const_universes : constant_universes; const_proj : projection_body option; @@ -1355,16 +1436,21 @@ sig | MEwith of module_alg_expr * with_declaration type abstract_inductive_universes = - | Monomorphic_ind of Univ.universe_context - | Polymorphic_ind of Univ.abstract_universe_context - | Cumulative_ind of Univ.abstract_cumulativity_info + | Monomorphic_ind of Univ.ContextSet.t + | Polymorphic_ind of Univ.AUContext.t + | Cumulative_ind of Univ.ACumulativityInfo.t type record_body = (Id.t * Constant.t array * projection_body array) option - + + type recursivity_kind = + | Finite + | CoFinite + | BiFinite + type mutual_inductive_body = { mind_packets : one_inductive_body array; mind_record : record_body option; - mind_finite : Decl_kinds.recursivity_kind; + mind_finite : recursivity_kind; mind_ntypes : int; mind_hyps : Context.Named.t; mind_nparams : int; @@ -1422,9 +1508,9 @@ sig | LocalAssumEntry of constr type inductive_universes = - | Monomorphic_ind_entry of Univ.universe_context - | Polymorphic_ind_entry of Univ.universe_context - | Cumulative_ind_entry of Univ.cumulativity_info + | Monomorphic_ind_entry of Univ.ContextSet.t + | Polymorphic_ind_entry of Univ.UContext.t + | Cumulative_ind_entry of Univ.CumulativityInfo.t type one_inductive_entry = { mind_entry_typename : Id.t; @@ -1438,7 +1524,7 @@ sig (** Some (Some id): primitive record with id the binder name of the record in projections. Some None: non-primitive record *) - mind_entry_finite : Decl_kinds.recursivity_kind; + mind_entry_finite : Declarations.recursivity_kind; mind_entry_params : (Id.t * local_entry) list; mind_entry_inds : one_inductive_entry list; mind_entry_universes : inductive_universes; @@ -1451,8 +1537,9 @@ sig type 'a proof_output = Constr.t Univ.in_universe_context_set * 'a type 'a const_entry_body = 'a proof_output Future.computation type constant_universes_entry = - | Monomorphic_const_entry of Univ.universe_context - | Polymorphic_const_entry of Univ.universe_context + | Monomorphic_const_entry of Univ.ContextSet.t + | Polymorphic_const_entry of Univ.UContext.t + type 'a in_constant_universes_entry = 'a * constant_universes_entry type 'a definition_entry = { const_entry_body : 'a const_entry_body; (* List of section variables *) @@ -1463,7 +1550,7 @@ sig const_entry_universes : constant_universes_entry; const_entry_opaque : bool; const_entry_inline_code : bool } - type parameter_entry = Context.Named.t option * bool * Constr.types Univ.in_universe_context * inline + type parameter_entry = Context.Named.t option * Constr.types in_constant_universes_entry * inline type projection_entry = { proj_entry_ind : MutInd.t; @@ -1493,12 +1580,12 @@ sig utj_val : 'types; utj_type : Sorts.t } - type unsafe_type_judgment = Term.types punsafe_type_judgment + type unsafe_type_judgment = Constr.types punsafe_type_judgment val empty_env : env val lookup_mind : Names.MutInd.t -> env -> Declarations.mutual_inductive_body val push_rel : Context.Rel.Declaration.t -> env -> env val push_rel_context : Context.Rel.t -> env -> env - val push_rec_types : Term.rec_declaration -> env -> env + val push_rec_types : Constr.rec_declaration -> env -> env val lookup_rel : int -> env -> Context.Rel.Declaration.t val lookup_named : Names.Id.t -> env -> Context.Named.Declaration.t val lookup_named_val : Names.Id.t -> named_context_val -> Context.Named.Declaration.t @@ -1538,13 +1625,13 @@ sig | FConstruct of Names.constructor Univ.puniverses | FApp of fconstr * fconstr array | FProj of Names.Projection.t * fconstr - | FFix of Term.fixpoint * fconstr Esubst.subs - | FCoFix of Term.cofixpoint * fconstr Esubst.subs - | FCaseT of Term.case_info * Constr.t * fconstr * Constr.t array * fconstr Esubst.subs (* predicate and branches are closures *) + | FFix of Constr.fixpoint * fconstr Esubst.subs + | FCoFix of Constr.cofixpoint * fconstr Esubst.subs + | FCaseT of Constr.case_info * Constr.t * fconstr * Constr.t array * fconstr Esubst.subs (* predicate and branches are closures *) | FLambda of int * (Names.Name.t * Constr.t) list * Constr.t * fconstr Esubst.subs | FProd of Names.Name.t * fconstr * fconstr | FLetIn of Names.Name.t * fconstr * fconstr * Constr.t * fconstr Esubst.subs - | FEvar of Term.existential * fconstr Esubst.subs + | FEvar of Constr.existential * fconstr Esubst.subs | FLIFT of int * fconstr | FCLOS of Constr.t * fconstr Esubst.subs | FLOCKED @@ -1580,7 +1667,7 @@ sig val betaiota : RedFlags.reds val betaiotazeta : RedFlags.reds - val create_clos_infos : ?evars:(Term.existential -> Constr.t option) -> RedFlags.reds -> Environ.env -> clos_infos + val create_clos_infos : ?evars:(Constr.existential -> Constr.t option) -> RedFlags.reds -> Environ.env -> clos_infos val whd_val : clos_infos -> fconstr -> Constr.t @@ -1601,13 +1688,13 @@ sig val whd_betaiotazeta : Environ.env -> Constr.t -> Constr.t - val is_arity : Environ.env -> Term.types -> bool + val is_arity : Environ.env -> Constr.types -> bool - val dest_prod : Environ.env -> Term.types -> Context.Rel.t * Term.types + val dest_prod : Environ.env -> Constr.types -> Context.Rel.t * Constr.types type 'a extended_conversion_function = ?l2r:bool -> ?reds:Names.transparent_state -> Environ.env -> - ?evars:((Term.existential->Constr.t option) * UGraph.t) -> + ?evars:((Constr.existential->Constr.t option) * UGraph.t) -> 'a -> 'a -> unit val conv : Constr.t extended_conversion_function end @@ -1616,7 +1703,7 @@ module Type_errors : sig open Names - open Term + open Constr open Environ type 'constr pguard_error = @@ -1648,9 +1735,9 @@ sig | UnboundVar of variable | NotAType of ('constr, 'types) punsafe_judgment | BadAssumption of ('constr, 'types) punsafe_judgment - | ReferenceVariables of identifier * 'constr - | ElimArity of pinductive * sorts_family list * 'constr * ('constr, 'types) punsafe_judgment - * (sorts_family * sorts_family * arity_error) option + | ReferenceVariables of Id.t * 'constr + | ElimArity of pinductive * Sorts.family list * 'constr * ('constr, 'types) punsafe_judgment + * (Sorts.family * Sorts.family * arity_error) option | CaseNotInductive of ('constr, 'types) punsafe_judgment | WrongCaseInfo of pinductive * case_info | NumberBranches of ('constr, 'types) punsafe_judgment * int @@ -1682,16 +1769,16 @@ end module Inductive : sig type mind_specif = Declarations.mutual_inductive_body * Declarations.one_inductive_body - val type_of_inductive : Environ.env -> mind_specif Univ.puniverses -> Term.types + val type_of_inductive : Environ.env -> mind_specif Univ.puniverses -> Constr.types exception SingletonInductiveBecomesProp of Names.Id.t val lookup_mind_specif : Environ.env -> Names.inductive -> mind_specif - val find_inductive : Environ.env -> Term.types -> Term.pinductive * Constr.t list + val find_inductive : Environ.env -> Constr.types -> Constr.pinductive * Constr.t list end module Typeops : sig - val infer_type : Environ.env -> Term.types -> Environ.unsafe_type_judgment - val type_of_constant_in : Environ.env -> Term.pconstant -> Term.types + val infer_type : Environ.env -> Constr.types -> Environ.unsafe_type_judgment + val type_of_constant_in : Environ.env -> Constr.pconstant -> Constr.types end module Mod_typing : @@ -1720,6 +1807,60 @@ end (* Modules from intf/ *) (************************************************************************) +module Libnames : +sig + + open Util + open Names + + type full_path + val pr_path : full_path -> Pp.t + val make_path : Names.DirPath.t -> Names.Id.t -> full_path + val eq_full_path : full_path -> full_path -> bool + val repr_path : full_path -> Names.DirPath.t * Names.Id.t + val dirpath : full_path -> Names.DirPath.t + val path_of_string : string -> full_path + + type qualid + val make_qualid : Names.DirPath.t -> Names.Id.t -> qualid + val qualid_eq : qualid -> qualid -> bool + val repr_qualid : qualid -> Names.DirPath.t * Names.Id.t + val pr_qualid : qualid -> Pp.t + val string_of_qualid : qualid -> string + val qualid_of_string : string -> qualid + val qualid_of_path : full_path -> qualid + val qualid_of_dirpath : Names.DirPath.t -> qualid + val qualid_of_ident : Names.Id.t -> qualid + + type reference = + | Qualid of qualid Loc.located + | Ident of Names.Id.t Loc.located + val loc_of_reference : reference -> Loc.t option + val qualid_of_reference : reference -> qualid Loc.located + val pr_reference : reference -> Pp.t + + val is_dirpath_prefix_of : Names.DirPath.t -> Names.DirPath.t -> bool + val split_dirpath : Names.DirPath.t -> Names.DirPath.t * Names.Id.t + val dirpath_of_string : string -> Names.DirPath.t + val pr_dirpath : Names.DirPath.t -> Pp.t + [@@ocaml.deprecated "Alias for DirPath.print"] + + val string_of_path : full_path -> string + + val basename : full_path -> Names.Id.t + + type object_name = full_path * Names.KerName.t + type object_prefix = { + obj_dir : DirPath.t; + obj_mp : ModPath.t; + obj_sec : DirPath.t; + } + + module Dirset : Set.S with type elt = DirPath.t + module Dirmap : Map.ExtS with type key = DirPath.t and module Set := Dirset + module Spmap : CSig.MapS with type key = full_path +end + module Misctypes : sig type evars_flag = bool @@ -1742,10 +1883,15 @@ sig | GSet (** representation of [Set] literal *) | GType of 'a (** representation of [Type] literal *) - type level_info = Names.Name.t Loc.located option + type 'a universe_kind = + | UAnonymous + | UUnknown + | UNamed of 'a + + type level_info = Libnames.reference universe_kind type glob_level = level_info glob_sort_gen - type sort_info = Names.Name.t Loc.located list + type sort_info = (Libnames.reference * int) option list type glob_sort = sort_info glob_sort_gen type ('a, 'b) gen_universe_decl = { @@ -1756,7 +1902,7 @@ sig type glob_constraint = glob_level * Univ.constraint_type * glob_level - type case_style = Term.case_style = + type case_style = Constr.case_style = | LetStyle | IfStyle | LetPatternStyle @@ -1857,8 +2003,8 @@ end module Univops : sig - val universes_of_constr : Term.constr -> Univ.universe_set - val restrict_universe_context : Univ.universe_context_set -> Univ.universe_set -> Univ.universe_context_set + val universes_of_constr : Environ.env -> Constr.constr -> Univ.LSet.t + val restrict_universe_context : Univ.ContextSet.t -> Univ.LSet.t -> Univ.ContextSet.t end module Nameops : @@ -1898,54 +2044,6 @@ sig [@@ocaml.deprecated "alias of API.Names"] end -module Libnames : -sig - - open Util - open Names - - type full_path - val pr_path : full_path -> Pp.t - val make_path : Names.DirPath.t -> Names.Id.t -> full_path - val eq_full_path : full_path -> full_path -> bool - val repr_path : full_path -> Names.DirPath.t * Names.Id.t - val dirpath : full_path -> Names.DirPath.t - val path_of_string : string -> full_path - - type qualid - val make_qualid : Names.DirPath.t -> Names.Id.t -> qualid - val qualid_eq : qualid -> qualid -> bool - val repr_qualid : qualid -> Names.DirPath.t * Names.Id.t - val pr_qualid : qualid -> Pp.t - val string_of_qualid : qualid -> string - val qualid_of_string : string -> qualid - val qualid_of_path : full_path -> qualid - val qualid_of_dirpath : Names.DirPath.t -> qualid - val qualid_of_ident : Names.Id.t -> qualid - - type reference = - | Qualid of qualid Loc.located - | Ident of Names.Id.t Loc.located - val loc_of_reference : reference -> Loc.t option - val qualid_of_reference : reference -> qualid Loc.located - val pr_reference : reference -> Pp.t - - val is_dirpath_prefix_of : Names.DirPath.t -> Names.DirPath.t -> bool - val split_dirpath : Names.DirPath.t -> Names.DirPath.t * Names.Id.t - val dirpath_of_string : string -> Names.DirPath.t - val pr_dirpath : Names.DirPath.t -> Pp.t - - val string_of_path : full_path -> string - val basename : full_path -> Names.Id.t - - type object_name = full_path * Names.KerName.t - type object_prefix = Names.DirPath.t * (Names.ModPath.t * Names.DirPath.t) - - module Dirset : Set.S with type elt = DirPath.t - module Dirmap : Map.ExtS with type key = DirPath.t and module Set := Dirset - module Spmap : CSig.MapS with type key = full_path -end - module Globnames : sig @@ -2006,7 +2104,7 @@ module Pattern : sig type case_info_pattern = - { cip_style : Misctypes.case_style; + { cip_style : Constr.case_style; cip_ind : Names.inductive option; cip_ind_tags : bool list option; (** indicates LetIn/Lambda in arity *) cip_extensible : bool (** does this match end with _ => _ ? *) } @@ -2027,8 +2125,8 @@ sig | PIf of constr_pattern * constr_pattern * constr_pattern | PCase of case_info_pattern * constr_pattern * constr_pattern * (int * bool list * constr_pattern) list (** index of constructor, nb of args *) - | PFix of Term.fixpoint - | PCoFix of Term.cofixpoint + | PFix of Constr.fixpoint + | PCoFix of Constr.cofixpoint end @@ -2055,7 +2153,67 @@ sig | ImpossibleCase | MatchingVar of matching_var_kind | VarInstance of Names.Id.t - | SubEvar of Constr.existential_key + | SubEvar of Evar.t +end + +module Decl_kinds : +sig + type polymorphic = bool + type cumulative_inductive_flag = bool + type recursivity_kind = Declarations.recursivity_kind = + | Finite + | CoFinite + | BiFinite + [@@ocaml.deprecated "Please use [Declarations.recursivity_kind"] + + type discharge = + | DoDischarge + | NoDischarge + + type locality = + | Discharge + | Local + | Global + + type definition_object_kind = + | Definition + | Coercion + | SubClass + | CanonicalStructure + | Example + | Fixpoint + | CoFixpoint + | Scheme + | StructureComponent + | IdentityCoercion + | Instance + | Method + | Let + type theorem_kind = + | Theorem + | Lemma + | Fact + | Remark + | Property + | Proposition + | Corollary + type goal_object_kind = + | DefinitionBody of definition_object_kind + | Proof of theorem_kind + type goal_kind = locality * polymorphic * goal_object_kind + type assumption_object_kind = + | Definitional + | Logical + | Conjectural + type logical_kind = + | IsAssumption of assumption_object_kind + | IsDefinition of definition_object_kind + | IsProof of theorem_kind + type binding_kind = + | Explicit + | Implicit + type private_flag = bool + type definition_kind = locality * polymorphic * definition_object_kind end module Glob_term : @@ -2079,7 +2237,7 @@ sig | GLambda of Names.Name.t * Decl_kinds.binding_kind * 'a glob_constr_g * 'a glob_constr_g | GProd of Names.Name.t * Decl_kinds.binding_kind * 'a glob_constr_g * 'a glob_constr_g | GLetIn of Names.Name.t * 'a glob_constr_g * 'a glob_constr_g option * 'a glob_constr_g - | GCases of Term.case_style * 'a glob_constr_g option * 'a tomatch_tuples_g * 'a cases_clauses_g + | GCases of Constr.case_style * 'a glob_constr_g option * 'a tomatch_tuples_g * 'a cases_clauses_g | GLetTuple of Names.Name.t list * (Names.Name.t * 'a glob_constr_g option) * 'a glob_constr_g * 'a glob_constr_g | GIf of 'a glob_constr_g * (Names.Name.t * 'a glob_constr_g option) * 'a glob_constr_g * 'a glob_constr_g | GRec of 'a fix_kind_g * Names.Id.t array * 'a glob_decl_g list array * @@ -2142,7 +2300,7 @@ sig | NProd of Names.Name.t * notation_constr * notation_constr | NBinderList of Names.Id.t * Names.Id.t * notation_constr * notation_constr | NLetIn of Names.Name.t * notation_constr * notation_constr option * notation_constr - | NCases of Term.case_style * notation_constr option * + | NCases of Constr.case_style * notation_constr option * (notation_constr * (Names.Name.t * (Names.inductive * Names.Name.t list) option)) list * (Glob_term.cases_pattern list * notation_constr) list | NLetTuple of Names.Name.t list * (Names.Name.t * notation_constr option) * @@ -2214,7 +2372,7 @@ sig | CApp of (proj_flag * constr_expr) * (constr_expr * explicitation Loc.located option) list | CRecord of (Libnames.reference * constr_expr) list - | CCases of Term.case_style + | CCases of Constr.case_style * constr_expr option * case_expr list * branch_expr list @@ -2606,11 +2764,11 @@ module Universes : sig type universe_binders type universe_opt_subst - val fresh_inductive_instance : Environ.env -> Names.inductive -> Term.pinductive Univ.in_universe_context_set - val new_Type : Names.DirPath.t -> Term.types - val type_of_global : Globnames.global_reference -> Term.types Univ.in_universe_context_set + val fresh_inductive_instance : Environ.env -> Names.inductive -> Constr.pinductive Univ.in_universe_context_set + val new_Type : unit -> Constr.types + val type_of_global : Globnames.global_reference -> Constr.types Univ.in_universe_context_set val constr_of_global : Globnames.global_reference -> Constr.t - val new_univ_level : Names.DirPath.t -> Univ.Level.t + val new_univ_level : unit -> Univ.Level.t val new_sort_in_family : Sorts.family -> Sorts.t val pr_with_global_universes : Univ.Level.t -> Pp.t val pr_universe_opt_subst : universe_opt_subst -> Pp.t @@ -2623,6 +2781,8 @@ sig end type universe_constraints = Constraints.t + [@@ocaml.deprecated "Use Constraints.t"] + end module UState : @@ -2632,6 +2792,9 @@ sig val context_set : t -> Univ.ContextSet.t val of_context_set : Univ.ContextSet.t -> t + val const_univ_entry : poly:bool -> t -> Entries.constant_universes_entry + val ind_univ_entry : poly:bool -> t -> Entries.inductive_universes + type rigid = | UnivRigid | UnivFlexible of bool @@ -2641,9 +2804,12 @@ end module Evd : sig - type evar = Constr.existential_key + type evar = Evar.t + [@@ocaml.deprecated "use Evar.t"] val string_of_existential : Evar.t -> string + [@@ocaml.deprecated "use Evar.print"] + type evar_constraint = Reduction.conv_pb * Environ.env * Constr.t * Constr.t (* --------------------------------- *) @@ -2720,7 +2886,7 @@ sig val empty : evar_map val from_env : Environ.env -> evar_map val find : evar_map -> Evar.t -> evar_info - val find_undefined : evar_map -> evar -> evar_info + val find_undefined : evar_map -> Evar.t -> evar_info val is_defined : evar_map -> Evar.t -> bool val mem : evar_map -> Evar.t -> bool val add : evar_map -> Evar.t -> evar_info -> evar_map @@ -2733,28 +2899,31 @@ sig val create_evar_defs : evar_map -> evar_map - val meta_declare : Constr.metavariable -> Term.types -> ?name:Names.Name.t -> evar_map -> evar_map + val meta_declare : Constr.metavariable -> Constr.types -> ?name:Names.Name.t -> evar_map -> evar_map val clear_metas : evar_map -> evar_map (** Allocates a new evar that represents a {i sort}. *) - val new_sort_variable : ?loc:Loc.t -> ?name:string -> rigid -> evar_map -> evar_map * Sorts.t + val new_sort_variable : ?loc:Loc.t -> ?name:Names.Id.t -> rigid -> evar_map -> evar_map * Sorts.t val remove : evar_map -> Evar.t -> evar_map val fresh_global : ?loc:Loc.t -> ?rigid:rigid -> ?names:Univ.Instance.t -> Environ.env -> evar_map -> Globnames.global_reference -> evar_map * Constr.t val evar_filtered_context : evar_info -> Context.Named.t - val fresh_inductive_instance : ?loc:Loc.t -> Environ.env -> evar_map -> Names.inductive -> evar_map * Term.pinductive + val fresh_inductive_instance : ?loc:Loc.t -> Environ.env -> evar_map -> Names.inductive -> evar_map * Constr.pinductive val fold_undefined : (Evar.t -> evar_info -> 'a -> 'a) -> evar_map -> 'a -> 'a val universe_context_set : evar_map -> Univ.ContextSet.t - val evar_ident : evar -> evar_map -> Names.Id.t option + val evar_ident : Evar.t -> 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 -> extensible:bool -> evar_map -> - (Names.Id.t * Univ.Level.t) list * Univ.UContext.t + val universe_binders : evar_map -> Universes.universe_binders val nf_constraints : evar_map -> evar_map val from_ctx : UState.t -> evar_map + val to_universe_context : evar_map -> Univ.UContext.t + val const_univ_entry : poly:bool -> evar_map -> Entries.constant_universes_entry + val ind_univ_entry : poly:bool -> evar_map -> Entries.inductive_universes + val meta_list : evar_map -> (Constr.metavariable * clbinding) list val meta_defined : evar_map -> Constr.metavariable -> bool @@ -2801,8 +2970,8 @@ sig type evar_universe_context = UState.t [@@ocaml.deprecated "alias of API.UState.t"] - val existential_opt_value : evar_map -> Term.existential -> Constr.t option - val existential_value : evar_map -> Term.existential -> Constr.t + val existential_opt_value : evar_map -> Constr.existential -> Constr.t option + val existential_value : evar_map -> Constr.existential -> Constr.t exception NotInstantiatedEvar @@ -2950,7 +3119,7 @@ sig val fold : Evd.evar_map -> ('a -> constr -> 'a) -> 'a -> constr -> 'a val existential_type : Evd.evar_map -> existential -> types val iter : Evd.evar_map -> (constr -> unit) -> constr -> unit - val eq_constr_universes : Evd.evar_map -> constr -> constr -> Universes.universe_constraints option + val eq_constr_universes : Evd.evar_map -> constr -> constr -> Universes.Constraints.t option val eq_constr_nounivs : Evd.evar_map -> constr -> constr -> bool val compare_constr : Evd.evar_map -> (constr -> constr -> bool) -> constr -> constr -> bool val isApp : Evd.evar_map -> constr -> bool @@ -3033,7 +3202,7 @@ sig val map_constr_with_binders_left_to_right : Evd.evar_map -> (EConstr.rel_declaration -> 'a -> 'a) -> ('a -> EConstr.constr -> EConstr.constr) -> 'a -> EConstr.constr -> EConstr.constr - (** Remove the outer-most {!Term.kind_of_term.Cast} from a given term. *) + (** Remove the outer-most {!Constr.kind_of_term.Cast} from a given term. *) val strip_outer_cast : Evd.evar_map -> EConstr.constr -> EConstr.constr (** [nb_lam] ⟦[fun (x1:t1)...(xn:tn) => c]⟧ where [c] is not an abstraction gives [n]. @@ -3044,7 +3213,7 @@ sig val push_rel_assum : Names.Name.t * EConstr.types -> Environ.env -> Environ.env (** [push_rels_assum env_assumptions env] adds given {i env assumptions} to the {i env context} of a given {i environment}. *) - val push_rels_assum : (Names.Name.t * Term.types) list -> Environ.env -> Environ.env + val push_rels_assum : (Names.Name.t * Constr.types) list -> Environ.env -> Environ.env type meta_value_map = (Constr.metavariable * Constr.t) list @@ -3136,6 +3305,7 @@ sig exception ClearDependencyError of Names.Id.t * clear_dependency_error val undefined_evars_of_term : Evd.evar_map -> EConstr.constr -> Evar.Set.t + val has_undefined_evars : Evd.evar_map -> EConstr.constr -> bool val e_new_evar : Environ.env -> Evd.evar_map ref -> ?src:Evar_kinds.t Loc.located -> ?filter:Evd.Filter.t -> ?candidates:EConstr.constr list -> ?store:Evd.Store.t -> @@ -3146,7 +3316,7 @@ sig ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> Evd.rigid -> Evd.evar_map * (EConstr.constr * Sorts.t) val nf_evars_universes : Evd.evar_map -> Constr.t -> Constr.t - val safe_evar_value : Evd.evar_map -> Term.existential -> Constr.t option + val safe_evar_value : Evd.evar_map -> Constr.existential -> Constr.t option val evd_comb1 : (Evd.evar_map -> 'b -> Evd.evar_map * 'a) -> Evd.evar_map ref -> 'b -> 'a end @@ -3180,7 +3350,7 @@ sig val catch : 'a t -> (Exninfo.iexn -> 'a t) -> 'a t val read_line : string t end - val proofview : proofview -> Evd.evar list * Evd.evar_map + val proofview : proofview -> Evar.t list * Evd.evar_map val cycle : int -> unit tactic val swap : int -> int -> unit tactic val revgoals : unit tactic @@ -3207,20 +3377,20 @@ sig val shelve_unifiable : unit tactic val apply : Environ.env -> 'a tactic -> proofview -> 'a * proofview - * (bool * Evd.evar list * Evd.evar list) + * (bool * Evar.t list * Evar.t list) * Proofview_monad.Info.tree val numgoals : int tactic - val with_shelf : 'a tactic -> (Evd.evar list * 'a) tactic + val with_shelf : 'a tactic -> (Evar.t list * 'a) tactic module Unsafe : sig val tclEVARS : Evd.evar_map -> unit tactic - val tclGETGOALS : Evd.evar list tactic + val tclGETGOALS : Evar.t list tactic - val tclSETGOALS : Evd.evar list -> unit tactic + val tclSETGOALS : Evar.t list -> unit tactic - val tclNEWGOALS : Evd.evar list -> unit tactic + val tclNEWGOALS : Evar.t list -> unit tactic end module Goal : @@ -3514,14 +3684,14 @@ sig | IndType of inductive_family * EConstr.constr list type constructor_summary = { - cs_cstr : Term.pconstructor; + cs_cstr : Constr.pconstructor; cs_params : Constr.t list; cs_nargs : int; cs_args : Context.Rel.t; cs_concl_realargs : Constr.t array; } - val arities_of_constructors : Environ.env -> Term.pinductive -> Term.types array + val arities_of_constructors : Environ.env -> Constr.pinductive -> Constr.types array val constructors_nrealargs_env : Environ.env -> Names.inductive -> int array val constructor_nallargs_env : Environ.env -> Names.constructor -> int @@ -3529,16 +3699,16 @@ sig val inductive_nparamdecls : Names.inductive -> int - val type_of_constructors : Environ.env -> Term.pinductive -> Term.types array + val type_of_constructors : Environ.env -> Constr.pinductive -> Constr.types array val find_mrectype : Environ.env -> Evd.evar_map -> EConstr.types -> (Names.inductive * EConstr.EInstance.t) * EConstr.constr list val mis_is_recursive : Names.inductive * Declarations.mutual_inductive_body * Declarations.one_inductive_body -> bool val nconstructors : Names.inductive -> int val find_rectype : Environ.env -> Evd.evar_map -> EConstr.types -> inductive_type val get_constructors : Environ.env -> inductive_family -> constructor_summary array - val dest_ind_family : inductive_family -> Names.inductive Term.puniverses * Constr.t list + val dest_ind_family : inductive_family -> Names.inductive Univ.puniverses * Constr.t list val find_inductive : Environ.env -> Evd.evar_map -> EConstr.types -> (Names.inductive * EConstr.EInstance.t) * Constr.t list - val type_of_inductive : Environ.env -> Term.pinductive -> Term.types + val type_of_inductive : Environ.env -> Constr.pinductive -> Constr.types end module Impargs : @@ -3564,7 +3734,7 @@ end module Retyping : (* reconstruct the type of a term knowing that it was already typechecked *) sig val get_type_of : ?polyprop:bool -> ?lax:bool -> Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.types - val get_sort_family_of : ?polyprop:bool -> Environ.env -> Evd.evar_map -> EConstr.types -> Sorts.family + val get_sort_family_of : ?truncation_style:bool -> ?polyprop:bool -> Environ.env -> Evd.evar_map -> EConstr.types -> Sorts.family val expand_projection : Environ.env -> Evd.evar_map -> Names.Projection.t -> EConstr.constr -> EConstr.constr list -> EConstr.constr val get_sort_of : ?polyprop:bool -> Environ.env -> Evd.evar_map -> EConstr.types -> Sorts.t @@ -3837,7 +4007,7 @@ sig type instance_flag = bool option type coercion_flag = bool - type inductive_flag = Decl_kinds.recursivity_kind + type inductive_flag = Declarations.recursivity_kind type lname = Names.Name.t Loc.located type lident = Names.Id.t Loc.located type opacity_flag = @@ -3880,8 +4050,6 @@ sig type verbose_flag = bool - 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 @@ -3996,29 +4164,27 @@ sig | VernacRedirect of string * vernac_expr Loc.located | VernacTimeout of int * vernac_expr | VernacFail of vernac_expr - | VernacSyntaxExtension of - bool * obsolete_locality * (lstring * syntax_modifier list) - | VernacOpenCloseScope of obsolete_locality * (bool * scope_name) + | VernacSyntaxExtension of bool * (lstring * syntax_modifier list) + | VernacOpenCloseScope of bool * scope_name | VernacDelimiters of scope_name * string option | VernacBindScope of scope_name * class_rawexpr list - | VernacInfix of obsolete_locality * (lstring * syntax_modifier list) * + | VernacInfix of (lstring * syntax_modifier list) * Constrexpr.constr_expr * scope_name option | VernacNotation of - obsolete_locality * Constrexpr.constr_expr * (lstring * syntax_modifier list) * + Constrexpr.constr_expr * (lstring * syntax_modifier list) * scope_name option | VernacNotationAddFormat of string * string * string - | VernacDefinition of - (Decl_kinds.locality option * Decl_kinds.definition_object_kind) * ident_decl * definition_expr + | VernacDefinition of (Decl_kinds.discharge * 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) * + | VernacAssumption of (Decl_kinds.discharge * Decl_kinds.assumption_object_kind) * 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 + Decl_kinds.discharge * (fixpoint_expr * decl_notation list) list | VernacCoFixpoint of - Decl_kinds.locality option * (cofixpoint_expr * decl_notation list) list + Decl_kinds.discharge * (cofixpoint_expr * decl_notation list) list | VernacScheme of (lident option * scheme) list | VernacCombinedScheme of lident * lident list | VernacUniverse of lident list @@ -4029,9 +4195,9 @@ sig Libnames.reference option * bool option * Libnames.reference list | VernacImport of bool * Libnames.reference list | VernacCanonical of Libnames.reference Misctypes.or_by_notation - | VernacCoercion of obsolete_locality * Libnames.reference Misctypes.or_by_notation * + | VernacCoercion of Libnames.reference Misctypes.or_by_notation * class_rawexpr * class_rawexpr - | VernacIdentityCoercion of obsolete_locality * lident * + | VernacIdentityCoercion of lident * class_rawexpr * class_rawexpr | VernacNameSectionHypSet of lident * section_subset_expr | VernacInstance of @@ -4065,9 +4231,9 @@ sig | VernacBackTo of int | VernacCreateHintDb of string * bool | VernacRemoveHints of string list * Libnames.reference list - | VernacHints of obsolete_locality * string list * hints_expr + | VernacHints of string list * hints_expr | VernacSyntacticDefinition of Names.Id.t Loc.located * (Names.Id.t list * Constrexpr.constr_expr) * - obsolete_locality * onlyparsing_flag + onlyparsing_flag | VernacDeclareImplicits of Libnames.reference Misctypes.or_by_notation * (Constrexpr.explicitation * bool * bool) list list | VernacArguments of Libnames.reference Misctypes.or_by_notation * @@ -4190,12 +4356,12 @@ module Indrec : sig type dep_flag = bool val lookup_eliminator : Names.inductive -> Sorts.family -> Globnames.global_reference - val build_case_analysis_scheme : Environ.env -> Evd.evar_map -> Term.pinductive -> + val build_case_analysis_scheme : Environ.env -> Evd.evar_map -> Constr.pinductive -> dep_flag -> Sorts.family -> Evd.evar_map * Constr.t val make_elimination_ident : Names.Id.t -> Sorts.family -> Names.Id.t val build_mutual_induction_scheme : - Environ.env -> Evd.evar_map -> (Term.pinductive * dep_flag * Sorts.family) list -> Evd.evar_map * Constr.t list - val build_case_analysis_scheme_default : Environ.env -> Evd.evar_map -> Term.pinductive -> + Environ.env -> Evd.evar_map -> (Constr.pinductive * dep_flag * Sorts.family) list -> Evd.evar_map * Constr.t list + val build_case_analysis_scheme_default : Environ.env -> Evd.evar_map -> Constr.pinductive -> Sorts.family -> Evd.evar_map * Constr.t end @@ -4389,6 +4555,8 @@ sig val default_binder_kind : Constrexpr.binder_kind val mkLetInC : Names.Name.t Loc.located * Constrexpr.constr_expr * Constrexpr.constr_expr option * Constrexpr.constr_expr -> Constrexpr.constr_expr val mkCProdN : ?loc:Loc.t -> Constrexpr.local_binder_expr list -> Constrexpr.constr_expr -> Constrexpr.constr_expr + val replace_vars_constr_expr : + Names.Id.t Names.Id.Map.t -> Constrexpr.constr_expr -> Constrexpr.constr_expr end module Notation_ops : @@ -4443,8 +4611,11 @@ end module Topconstr : sig + val replace_vars_constr_expr : - Names.Id.t Names.Id.Map.t -> Constrexpr.constr_expr -> Constrexpr.constr_expr + Names.Id.t Names.Id.Map.t -> Constrexpr.constr_expr -> Constrexpr.constr_expr + [@@ocaml.deprecated "use Constrexpr_ops.free_vars_of_constr_expr"] + end module Constrintern : @@ -4485,13 +4656,13 @@ sig val interp_open_constr : Environ.env -> Evd.evar_map -> Constrexpr.constr_expr -> Evd.evar_map * EConstr.constr val locate_reference : Libnames.qualid -> Globnames.global_reference val interp_type : Environ.env -> Evd.evar_map -> ?impls:internalization_env -> - Constrexpr.constr_expr -> Term.types Evd.in_evar_universe_context + Constrexpr.constr_expr -> Constr.types Evd.in_evar_universe_context val interp_context_evars : ?global_level:bool -> ?impl_env:internalization_env -> ?shift:int -> Environ.env -> Evd.evar_map ref -> Constrexpr.local_binder_expr list -> internalization_env * ((Environ.env * EConstr.rel_context) * Impargs.manual_implicits) val compute_internalization_data : Environ.env -> var_internalization_type -> - Term.types -> Impargs.manual_explicitation list -> var_internalization_data + Constr.types -> Impargs.manual_explicitation list -> var_internalization_data val empty_internalization_env : internalization_env val global_reference : Names.Id.t -> Globnames.global_reference end @@ -4520,7 +4691,7 @@ sig type section_variable_entry = | SectionLocalDef of Safe_typing.private_constants Entries.definition_entry - | SectionLocalAssum of Term.types Univ.in_universe_context_set * Decl_kinds.polymorphic * bool + | SectionLocalAssum of Constr.types Univ.in_universe_context_set * Decl_kinds.polymorphic * bool type variable_declaration = Names.DirPath.t * section_variable_entry * Decl_kinds.logical_kind @@ -4531,11 +4702,11 @@ sig val declare_definition : ?internal:internal_flag -> ?opaque:bool -> ?kind:Decl_kinds.definition_object_kind -> - ?local:bool -> ?poly:Decl_kinds.polymorphic -> Names.Id.t -> ?types:Constr.t -> - Constr.t Univ.in_universe_context_set -> Names.Constant.t + ?local:bool -> Names.Id.t -> ?types:Constr.t -> + Constr.t Entries.in_constant_universes_entry -> Names.Constant.t val definition_entry : ?fix_exn:Future.fix_exn -> - ?opaque:bool -> ?inline:bool -> ?types:Term.types -> - ?poly:Decl_kinds.polymorphic -> ?univs:Univ.UContext.t -> + ?opaque:bool -> ?inline:bool -> ?types:Constr.types -> + ?univs:Entries.constant_universes_entry -> ?eff:Safe_typing.private_constants -> Constr.t -> Safe_typing.private_constants Entries.definition_entry val definition_message : Names.Id.t -> unit val declare_variable : Names.Id.t -> variable_declaration -> Libnames.object_name @@ -4642,19 +4813,28 @@ end module Proof : sig - type proof + type t + type proof = t + [@@ocaml.deprecated "please use [Proof.t]"] + type 'a focus_kind + val proof : t -> + Goal.goal list * (Goal.goal list * Goal.goal list) list * + Goal.goal list * Goal.goal list * Evd.evar_map val run_tactic : Environ.env -> - unit Proofview.tactic -> proof -> proof * (bool * Proofview_monad.Info.tree) - val unshelve : proof -> proof - val maximal_unfocus : 'a focus_kind -> proof -> proof - val pr_proof : proof -> Pp.t + unit Proofview.tactic -> t -> t * (bool * Proofview_monad.Info.tree) + val unshelve : t -> t + val maximal_unfocus : 'a focus_kind -> t -> t + val pr_proof : t -> Pp.t + module V82 : sig - val grab_evars : proof -> proof + val grab_evars : t -> t + + val subgoals : t -> Goal.goal list Evd.sigma + [@@ocaml.deprecated "Use the first and fifth argument of [Proof.proof]"] - val subgoals : proof -> Goal.goal list Evd.sigma end end @@ -4666,24 +4846,25 @@ end module Proof_global : sig - type state + type t + type state = t + [@@ocaml.deprecated "please use [Proof_global.t]"] type proof_mode = { name : string; set : unit -> unit ; reset : unit -> unit } - type proof_universes = UState.t * Universes.universe_binders option type proof_object = { id : Names.Id.t; entries : Safe_typing.private_constants Entries.definition_entry list; persistence : Decl_kinds.goal_kind; - universes: proof_universes; + universes: UState.t; } type proof_ending = | Admitted of Names.Id.t * Decl_kinds.goal_kind * Entries.parameter_entry * - proof_universes + UState.t | Proved of Vernacexpr.opacity_flag * Vernacexpr.lident option * proof_object @@ -4697,14 +4878,14 @@ sig 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 + (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> 'a val simple_with_current_proof : - (unit Proofview.tactic -> Proof.proof -> Proof.proof) -> unit + (unit Proofview.tactic -> Proof.t -> Proof.t) -> unit val compact_the_proof : unit -> unit val register_proof_mode : proof_mode -> unit exception NoCurrentProof - val give_me_the_proof : unit -> Proof.proof + val give_me_the_proof : unit -> Proof.t (** @raise NoCurrentProof when outside proof mode. *) val discard_all : unit -> unit @@ -4791,8 +4972,6 @@ sig val pf_conv_x : Goal.goal Evd.sigma -> EConstr.constr -> EConstr.constr -> bool - val pf_is_matching : Goal.goal Evd.sigma -> Pattern.constr_pattern -> EConstr.constr -> bool - val pf_hyps_types : Goal.goal Evd.sigma -> (Names.Id.t * EConstr.types) list val pr_gls : Goal.goal Evd.sigma -> Pp.t @@ -4835,9 +5014,9 @@ sig val by : unit Proofview.tactic -> bool val solve : ?with_end_tac:unit Proofview.tactic -> Vernacexpr.goal_selector -> int option -> unit Proofview.tactic -> - Proof.proof -> Proof.proof * bool + Proof.t -> Proof.t * bool val cook_proof : - unit -> (Names.Id.t * (Safe_typing.private_constants Entries.definition_entry * Proof_global.proof_universes * Decl_kinds.goal_kind)) + unit -> (Names.Id.t * (Safe_typing.private_constants Entries.definition_entry * UState.t * Decl_kinds.goal_kind)) val get_current_context : unit -> Evd.evar_map * Environ.env val current_proof_statement : unit -> Names.Id.t * Decl_kinds.goal_kind * EConstr.types @@ -4941,7 +5120,6 @@ sig val ident : Id.t Gram.entry 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 pattern_ident : Id.t Gram.entry val pattern_identref : Id.t located Gram.entry val base_ident : Id.t Gram.entry @@ -5075,16 +5253,20 @@ end module Genprint : sig - type printer_with_level = + type 'a with_level = { default_already_surrounded : Notation_term.tolerability; default_ensure_surrounded : Notation_term.tolerability; - printer : Environ.env -> Evd.evar_map -> Notation_term.tolerability -> Pp.t } + printer : 'a } type printer_result = - | PrinterBasic of (unit -> Pp.t) - | PrinterNeedsContext of (Environ.env -> Evd.evar_map -> Pp.t) - | PrinterNeedsContextAndLevel of printer_with_level - type 'a printer = 'a -> Pp.t - type 'a top_printer = 'a -> printer_result +| PrinterBasic of (unit -> Pp.t) +| PrinterNeedsLevel of (Notation_term.tolerability -> Pp.t) with_level + type printer_fun_with_level = Environ.env -> Evd.evar_map -> Notation_term.tolerability -> Pp.t + type top_printer_result = + | TopPrinterBasic of (unit -> Pp.t) + | TopPrinterNeedsContext of (Environ.env -> Evd.evar_map -> Pp.t) + | TopPrinterNeedsContextAndLevel of printer_fun_with_level with_level + type 'a printer = 'a -> printer_result + type 'a top_printer = 'a -> top_printer_result val register_print0 : ('raw, 'glb, 'top) Genarg.genarg_type -> 'raw printer -> 'glb printer -> 'top top_printer -> unit val register_vernac_print0 : ('raw, 'glb, 'top) Genarg.genarg_type -> @@ -5138,12 +5320,20 @@ sig val pr_lconstr_env : Environ.env -> Evd.evar_map -> Constr.t -> Pp.t val pr_constr : Constr.t -> Pp.t + [@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_lconstr : Constr.t -> Pp.t + [@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_econstr : EConstr.constr -> Pp.t + [@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] + val pr_glob_constr : Glob_term.glob_constr -> Pp.t + [@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] + val pr_constr_pattern : Pattern.constr_pattern -> Pp.t + [@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] + val pr_glob_constr_env : Environ.env -> Glob_term.glob_constr -> Pp.t val pr_lglob_constr_env : Environ.env -> Glob_term.glob_constr -> Pp.t val pr_econstr_n_env : Environ.env -> Evd.evar_map -> Notation_term.tolerability -> EConstr.constr -> Pp.t @@ -5151,11 +5341,17 @@ sig val pr_constr_pattern_env : Environ.env -> Evd.evar_map -> Pattern.constr_pattern -> Pp.t val pr_lconstr_pattern_env : Environ.env -> Evd.evar_map -> Pattern.constr_pattern -> Pp.t val pr_closed_glob : Ltac_pretype.closed_glob_constr -> Pp.t + [@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_lglob_constr : Glob_term.glob_constr -> Pp.t + [@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_leconstr_env : Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t val pr_leconstr : EConstr.constr -> Pp.t + [@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] + val pr_global : Globnames.global_reference -> Pp.t val pr_lconstr_under_binders : Ltac_pretype.constr_under_binders -> Pp.t + [@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] + val pr_lconstr_under_binders_env : Environ.env -> Evd.evar_map -> Ltac_pretype.constr_under_binders -> Pp.t val pr_constr_under_binders_env : Environ.env -> Evd.evar_map -> Ltac_pretype.constr_under_binders -> Pp.t @@ -5163,8 +5359,11 @@ sig val pr_closed_glob_env : Environ.env -> Evd.evar_map -> Ltac_pretype.closed_glob_constr -> Pp.t val pr_rel_context_of : Environ.env -> Evd.evar_map -> Pp.t val pr_named_context_of : Environ.env -> Evd.evar_map -> Pp.t - val pr_ltype : Term.types -> Pp.t + val pr_ltype : Constr.types -> Pp.t + [@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_ljudge : EConstr.unsafe_judgment -> Pp.t * Pp.t + [@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] + val pr_idpred : Names.Id.Pred.t -> Pp.t val pr_cpred : Names.Cpred.t -> Pp.t val pr_transparent_state : Names.transparent_state -> Pp.t @@ -5593,7 +5792,7 @@ end module Hints : sig - type raw_hint = EConstr.t * EConstr.types * Univ.universe_context_set + type raw_hint = EConstr.t * EConstr.types * Univ.ContextSet.t type 'a hint_ast = | Res_pf of 'a (* Hint Apply *) @@ -5677,7 +5876,9 @@ sig val create_hint_db : bool -> hint_db_name -> Names.transparent_state -> bool -> unit val empty_hint_info : 'a Vernacexpr.hint_info_gen val repr_hint : hint -> (raw_hint * Clenv.clausenv) hint_ast + val pr_hint_db_env : Environ.env -> Evd.evar_map -> Hint_db.t -> Pp.t val pr_hint_db : Hint_db.t -> Pp.t + [@@ocaml.deprecated "please used pr_hint_db_env"] end module Auto : @@ -5741,7 +5942,7 @@ end module Autorewrite : sig type rew_rule = { rew_lemma: Constr.t; - rew_type: Term.types; + rew_type: Constr.types; rew_pat: Constr.t; rew_ctx: Univ.ContextSet.t; rew_l2r: bool; @@ -5754,7 +5955,7 @@ sig val add_rew_rules : string -> raw_rew_rule list -> unit val find_rewrites : string -> rew_rule list val find_matches : string -> Constr.t -> rew_rule list - val print_rewrite_hintdb : string -> Pp.t + val print_rewrite_hintdb : Environ.env -> Evd.evar_map -> string -> Pp.t end (************************************************************************) @@ -5787,11 +5988,12 @@ sig Future.fix_exn -> 'a declaration_hook -> Decl_kinds.locality -> Globnames.global_reference -> 'a val save_proof : ?proof:Proof_global.closed_proof -> Vernacexpr.proof_end -> unit val get_current_context : unit -> Evd.evar_map * Environ.env + [@@ocaml.deprecated "please use [Pfedit.get_current_context]"] end module Himsg : sig - val explain_refiner_error : Logic.refiner_error -> Pp.t + val explain_refiner_error : Environ.env -> Evd.evar_map -> Logic.refiner_error -> Pp.t val explain_pretype_error : Environ.env -> Evd.evar_map -> Pretype_errors.pretype_error -> Pp.t end @@ -5804,9 +6006,6 @@ end module Locality : sig val make_section_locality : bool option -> bool - module LocalityFixme : sig - val consume : unit -> bool option - end val make_module_locality : bool option -> bool end @@ -5877,7 +6076,7 @@ sig val do_mutual_inductive : (Vernacexpr.one_inductive_expr * Vernacexpr.decl_notation list) list -> Decl_kinds.cumulative_inductive_flag -> Decl_kinds.polymorphic -> - Decl_kinds.private_flag -> Decl_kinds.recursivity_kind -> unit + Decl_kinds.private_flag -> Declarations.recursivity_kind -> unit val do_definition : Names.Id.t -> Decl_kinds.definition_kind -> Vernacexpr.universe_decl_expr option -> Constrexpr.local_binder_expr list -> Redexpr.red_expr option -> Constrexpr.constr_expr -> @@ -5903,7 +6102,7 @@ sig structured_inductive_expr -> Vernacexpr.decl_notation list -> Decl_kinds.cumulative_inductive_flag -> Decl_kinds.polymorphic -> - Decl_kinds.private_flag -> Decl_kinds.recursivity_kind -> + Decl_kinds.private_flag -> Declarations.recursivity_kind -> Entries.mutual_inductive_entry * Universes.universe_binders * one_inductive_impls list val declare_mutual_inductive_with_eliminations : @@ -5929,14 +6128,37 @@ sig Names.Id.t end +module Vernacstate : +sig + + type t = { + system : States.state; (* summary + libstack *) + proof : Proof_global.t; (* proof state *) + shallow : bool (* is the state trimmed down (libstack) *) + } + + (* XXX: This should not be exported *) + val freeze_interp_state : Summary.marshallable -> t + val unfreeze_interp_state : t -> unit + +end + module Vernacinterp : sig + type deprecation = bool - type vernac_command = Genarg.raw_generic_argument list -> Loc.t option -> unit + type atts = { + loc : Loc.t option; + locality : bool option; + polymorphic : bool; + } + + type 'a vernac_command = 'a -> atts:atts -> st:Vernacstate.t -> Vernacstate.t + + type plugin_args = Genarg.raw_generic_argument list - val vinterp_add : deprecation -> Vernacexpr.extend_name -> - vernac_command -> unit + val vinterp_add : deprecation -> Vernacexpr.extend_name -> plugin_args vernac_command -> unit end @@ -5958,15 +6180,6 @@ end module Vernacentries : sig - type interp_state = { (* TODO: inline records in OCaml 4.03 *) - system : States.state; (* summary + libstack *) - proof : Proof_global.state; (* proof state *) - shallow : bool (* is the state trimmed down (libstack) *) - } - - val freeze_interp_state : Summary.marshallable -> interp_state - val unfreeze_interp_state : interp_state -> unit - val dump_global : Libnames.reference Misctypes.or_by_notation -> unit val interp_redexp_hook : (Environ.env -> Evd.evar_map -> Genredexpr.raw_red_expr -> Evd.evar_map * Redexpr.red_expr) Hook.t @@ -5998,7 +6211,7 @@ sig val get_doc : Feedback.doc_id -> doc val state_of_id : doc:doc -> - Stateid.t -> [ `Valid of Vernacentries.interp_state option | `Expired | `Error of exn ] + Stateid.t -> [ `Valid of Vernacstate.t option | `Expired | `Error of exn ] end (************************************************************************) @@ -7,6 +7,10 @@ Notations right (e.g. "( x ; .. ; y ; z )") now supported. - Notations with a specific level for the leftmost nonterminal, when printing-only, are supported. +- When several notations are available for the same expression, + priority is given to latest notations defined in the scopes being + opened rather than to the latest notations defined independently of + whether they are in an opened scope or not. Tactics @@ -21,6 +25,23 @@ Tactics - Tactic "decide equality" now able to manage constructors which contain proofs. +Vernacular Commands + +- The deprecated Coercion Local, Open Local Scope, Notation Local syntax + was removed. Use Local as a prefix instead. + +Universes + +- Qualified naming of global universes now works like other namespaced + objects (e.g. constants), with a separate namespace, inside and across + module and library boundaries. Global universe names introduced in an + inductive / constant / Let declaration get qualified with the name of + the declaration. + +Checker + +- The checker now accepts filenames in addition to logical paths. + Changes from 8.7+beta2 to 8.7.0 =============================== diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index db02f78344..b4e6a14182 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -36,6 +36,10 @@ Here are a few tags Coq developers may add to your PR and what they mean. In gen - [needs: fixing](https://github.com/coq/coq/pulls?q=is%3Aopen+is%3Apr+label%3A%22needs%3A+fixing%22) indicates the PR needs a fix, as discussed in the comments. - [needs: testing](https://github.com/coq/coq/pulls?q=is%3Aopen+is%3Apr+label%3A%22needs%3A+testing%22) indicates the PR needs testing. This is often used when testing beyond what the test suite can handle is required. For example, performance benchmarking is currently performed with a different infrastructure. Unless some followup is specifically requested you aren't expected to do this additional testing. +The release manager uses the following filter to know which PRs seem ready for merge. If you are waiting for a PR to be merged, make sure it appears in this list: + +- [Pull requests ready for merge](https://github.com/coq/coq/pulls?utf8=%E2%9C%93&q=is%3Apr%20is%3Aopen%20-label%3A%22needs%3A%20discussion%22%20-label%3A%22needs%3A%20testing%22%20-label%3A%22needs%3A%20fixing%22%20-label%3A%22needs%3A%20progress%22%20-label%3A%22needs%3A%20rebase%22%20-label%3A%22needs%3A%20review%22%20-label%3A%22needs%3A%20help%22%20-label%3A%22needs%3A%20independent%20fix%22%20-label%3A%22needs%3A%20feedback%22%20-label%3A%22help%20wanted%22%20-review%3Achanges_requested%20-status%3Apending%20base%3Amaster%20sort%3Aupdated-asc%20-label%3A%22needs%3A%20squashing%22%20) + ## Documentation Currently the process for contributing to the documentation is the same as for changing anything else in Coq, so please submit a pull request as described above. @@ -43,7 +43,7 @@ WHAT DO YOU NEED ? - a C compiler - for Coqide, the Lablgtk development files, and the GTK libraries - incuding gtksourceview, see INSTALL.ide for more details + including gtksourceview, see INSTALL.ide for more details Opam (https://opam.ocaml.org/) is recommended to install ocaml and the corresponding packages. @@ -30,7 +30,7 @@ package "lib" ( directory = "lib" - requires = "coq.config" + requires = "str, unix, threads, coq.config" archive(byte) = "clib.cma" archive(byte) += "lib.cma" @@ -65,7 +65,7 @@ package "kernel" ( directory = "kernel" - requires = "coq.lib, coq.vm" + requires = "dynlink, coq.lib, coq.vm" archive(byte) = "kernel.cma" archive(native) = "kernel.cmxa" @@ -168,7 +168,7 @@ package "parsing" ( description = "Coq Parsing Engine" version = "8.7" - requires = "coq.proofs" + requires = "camlp5.gramlib, coq.proofs" directory = "parsing" archive(byte) = "parsing.cma" @@ -15,7 +15,7 @@ # You won't find Makefiles in sub-directories and this is done on purpose. # If you are not yet convinced of the advantages of a single Makefile, please # read -# http://miller.emu.id.au/pmiller/books/rmch/ +# http://aegis.sourceforge.net/auug97.pdf # before complaining. # # When you are working in a subdir, you can compile without moving to the @@ -139,19 +139,10 @@ endif # This should help preventing weird compilation failures caused by leftover # compiled files after deleting or moving some source files. -ifeq (,$(findstring clean,$(MAKECMDGOALS))) # Skip this for 'make clean' and alii -ifndef ACCEPT_ALIEN_VO EXISTINGVO:=$(call find, '*.vo') KNOWNVO:=$(patsubst %.v,%.vo,$(call find, '*.v')) ALIENVO:=$(filter-out $(KNOWNVO),$(EXISTINGVO)) -ifdef ALIENVO -$(error Leftover compiled Coq files without known sources: $(ALIENVO); \ -remove them first, for instance via 'make voclean' \ -(or skip this check via 'make ACCEPT_ALIEN_VO=1')) -endif -endif -ifndef ACCEPT_ALIEN_OBJ EXISTINGOBJS:=$(call find, '*.cm[oxia]' -o -name '*.cmxa') KNOWNML:=$(EXISTINGML) $(GENMLFILES) $(GENML4FILES) $(MLPACKFILES:.mlpack=.ml) \ $(patsubst %.mlp,%.ml,$(wildcard grammar/*.mlp)) @@ -159,9 +150,20 @@ KNOWNOBJS:=$(KNOWNML:.ml=.cmo) $(KNOWNML:.ml=.cmx) $(KNOWNML:.ml=.cmi) \ $(MLIFILES:.mli=.cmi) \ $(MLLIBFILES:.mllib=.cma) $(MLLIBFILES:.mllib=.cmxa) grammar/grammar.cma ALIENOBJS:=$(filter-out $(KNOWNOBJS),$(EXISTINGOBJS)) + +ifeq (,$(findstring clean,$(MAKECMDGOALS))) # Skip this for 'make clean' and alii +ifndef ACCEPT_ALIEN_VO +ifdef ALIENVO +$(error Leftover compiled Coq files without known sources: $(ALIENVO); \ +remove them first, for instance via 'make voclean' or 'make alienclean' \ +(or skip this check via 'make ACCEPT_ALIEN_VO=1')) +endif +endif + +ifndef ACCEPT_ALIEN_OBJ ifdef ALIENOBJS $(error Leftover compiled OCaml files without known sources: $(ALIENOBJS); \ -remove them first, for instance via 'make clean' \ +remove them first, for instance via 'make clean' or 'make alienclean' \ (or skip this check via 'make ACCEPT_ALIEN_OBJ=1')) endif endif @@ -196,7 +198,7 @@ Makefile $(wildcard Makefile.*) config/Makefile : ; # Cleaning ########################################################################### -.PHONY: clean cleankeepvo objclean cruftclean indepclean docclean archclean optclean clean-ide ml4clean depclean cleanconfig distclean voclean timingclean devdocclean +.PHONY: clean cleankeepvo objclean cruftclean indepclean docclean archclean optclean clean-ide ml4clean depclean cleanconfig distclean voclean timingclean devdocclean alienclean clean: objclean cruftclean depclean docclean devdocclean @@ -282,6 +284,9 @@ devdocclean: rm -f $(OCAMLDOCDIR)/ocamldoc.sty $(OCAMLDOCDIR)/coq.tex rm -f $(OCAMLDOCDIR)/html/*.html +alienclean: + rm -f $(ALIENOBJS) $(ALIENVO) + ########################################################################### # Continuous Intregration Tests ########################################################################### diff --git a/Makefile.build b/Makefile.build index 991942bf0a..39b793d2bb 100644 --- a/Makefile.build +++ b/Makefile.build @@ -734,8 +734,8 @@ $(MICROMEGAV:.v=.vo) $(MICROMEGAV:.v=.glob) : $(MICROMEGAV) theories/Init/Prelud $(SHOW)'COQC $<' $(HIDE)rm -f $*.glob $(HIDE)$(BOOTCOQC) $< | sed -e '$$d' > $(MICROMEGAGEN) - $(HIDE)cmp -s $(MICROMEGAML) $(MICROMEGAGEN) || \ - echo "Warning: $(MICROMEGAML) and the code generated by $(MICROMEGAV) differ !" + $(HIDE)diff -u --strip-trailing-cr $(MICROMEGAML) $(MICROMEGAGEN) || \ + (2>&1 echo "Error: $(MICROMEGAML) and the code generated by $(MICROMEGAV) differ !" && false) # The general rule for building .vo files : diff --git a/Makefile.ci b/Makefile.ci index 0b2cbb6637..a17d4ddf75 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -5,6 +5,7 @@ CI_TARGETS=ci-all \ ci-coq-dpdgraph \ ci-coquelicot \ ci-cpdt \ + ci-equations \ ci-fiat-crypto \ ci-fiat-parsers \ ci-flocq \ diff --git a/Makefile.dev b/Makefile.dev index dc4ded3977..d2a1e9235e 100644 --- a/Makefile.dev +++ b/Makefile.dev @@ -98,7 +98,7 @@ pluginsopt: $(PLUGINSOPT) pluginsbyte: $(PLUGINS) # This should build all the ocaml code but not (most of) the .v files -coqocaml: tools coqbinaries pluginsopt coqide printers bin/votour +coqocaml: tools coqbinaries $(PLUGINSCMO:.cmo=$(DYNOBJ)) coqide printers bin/votour .PHONY: coqlight states miniopt minibyte pluginsopt pluginsbyte coqocaml diff --git a/Makefile.install b/Makefile.install index 55229deb96..27694106fd 100644 --- a/Makefile.install +++ b/Makefile.install @@ -101,12 +101,16 @@ INSTALLCMI = $(sort \ $(foreach lib,$(CORECMA), $(addsuffix .cmi,$($(lib:.cma=_MLLIB_DEPENDENCIES))))) \ $(PLUGINS:.cmo=.cmi) +INSTALLCMX = $(sort $(filter-out checker/% ide/% tools/% dev/% configure.cmx, $(MLFILES:.ml=.cmx))) + install-devfiles: $(MKDIR) $(FULLBINDIR) $(INSTALLBIN) $(COQMKTOP) $(FULLBINDIR) $(MKDIR) $(FULLCOQLIB) $(INSTALLSH) $(FULLCOQLIB) $(GRAMMARCMA) $(INSTALLSH) $(FULLCOQLIB) $(INSTALLCMI) + $(INSTALLSH) $(FULLCOQLIB) $(INSTALLCMX) + $(INSTALLSH) $(FULLCOQLIB) $(PLUGINSCMO:.cmo=.o) $(INSTALLSH) $(FULLCOQLIB) $(TOOLS_HELPERS) ifeq ($(BEST),opt) $(INSTALLSH) $(FULLCOQLIB) $(LINKCMX) $(CORECMA:.cma=.a) $(STATICPLUGINS:.cma=.a) @@ -144,7 +148,7 @@ install-coq-manpages: install-emacs: $(MKDIR) $(FULLEMACSLIB) - $(INSTALLLIB) tools/gallina-db.el tools/coq-font-lock.el tools/gallina-syntax.el tools/gallina.el tools/coq-inferior.el $(FULLEMACSLIB) + $(INSTALLLIB) tools/gallina-db.el tools/coq-font-lock.el tools/gallina-syntax.el tools/gallina.el tools/inferior-coq.el $(FULLEMACSLIB) # command to update TeX' kpathsea database #UPDATETEX = $(MKTEXLSR) /usr/share/texmf /var/spool/texmf $(BASETEXDIR) > /dev/null diff --git a/checker/analyze.ml b/checker/analyze.ml index df75d5b93c..7047d8a149 100644 --- a/checker/analyze.ml +++ b/checker/analyze.ml @@ -55,6 +55,55 @@ let magic_number = "\132\149\166\190" (** Memory reification *) +module LargeArray : +sig + type 'a t + val empty : 'a t + val length : 'a t -> int + val make : int -> 'a -> 'a t + val get : 'a t -> int -> 'a + val set : 'a t -> int -> 'a -> unit +end = +struct + + let max_length = Sys.max_array_length + + type 'a t = 'a array array * 'a array + (** Invariants: + - All subarrays of the left array have length [max_length]. + - The right array has length < [max_length]. + *) + + let empty = [||], [||] + + let length (vl, vr) = + (max_length * Array.length vl) + Array.length vr + + let make n x = + let k = n / max_length in + let r = n mod max_length in + let vl = Array.init k (fun _ -> Array.make max_length x) in + let vr = Array.make r x in + (vl, vr) + + let get (vl, vr) n = + let k = n / max_length in + let r = n mod max_length in + let len = Array.length vl in + if k < len then vl.(k).(r) + else if k == len then vr.(r) + else invalid_arg "index out of bounds" + + let set (vl, vr) n x = + let k = n / max_length in + let r = n mod max_length in + let len = Array.length vl in + if k < len then vl.(k).(r) <- x + else if k == len then vr.(r) <- x + else invalid_arg "index out of bounds" + +end + type repr = | RInt of int | RBlock of (int * int) (* tag × len *) @@ -82,7 +131,7 @@ end module type S = sig type input - val parse : input -> (data * obj array) + val parse : input -> (data * obj LargeArray.t) end module Make(M : Input) = @@ -261,7 +310,7 @@ let parse_object chan = let parse chan = let (magic, len, _, _, size) = parse_header chan in let () = assert (magic = magic_number) in - let memory = Array.make size (Struct ((-1), [||])) in + let memory = LargeArray.make size (Struct ((-1), [||])) in let current_object = ref 0 in let fill_obj = function | RPointer n -> @@ -272,7 +321,7 @@ let parse chan = data, None | RString s -> let data = Ptr !current_object in - let () = memory.(!current_object) <- String s in + let () = LargeArray.set memory !current_object (String s) in let () = incr current_object in data, None | RBlock (tag, 0) -> @@ -282,7 +331,7 @@ let parse chan = | RBlock (tag, len) -> let data = Ptr !current_object in let nblock = Array.make len (Atm (-1)) in - let () = memory.(!current_object) <- Struct (tag, nblock) in + let () = LargeArray.set memory !current_object (Struct (tag, nblock)) in let () = incr current_object in data, Some nblock | RCode addr -> @@ -343,3 +392,32 @@ module PString = Make(IString) let parse_channel = PChannel.parse let parse_string s = PString.parse (s, ref 0) + +let instantiate (p, mem) = + let len = LargeArray.length mem in + let ans = LargeArray.make len (Obj.repr 0) in + (** First pass: initialize the subobjects *) + for i = 0 to len - 1 do + let obj = match LargeArray.get mem i with + | Struct (tag, blk) -> Obj.new_block tag (Array.length blk) + | String str -> Obj.repr str + in + LargeArray.set ans i obj + done; + let get_data = function + | Int n -> Obj.repr n + | Ptr p -> LargeArray.get ans p + | Atm tag -> Obj.new_block tag 0 + | Fun _ -> assert false (** We shouldn't serialize closures *) + in + (** Second pass: set the pointers *) + for i = 0 to len - 1 do + match LargeArray.get mem i with + | Struct (_, blk) -> + let obj = LargeArray.get ans i in + for k = 0 to Array.length blk - 1 do + Obj.set_field obj k (get_data blk.(k)) + done + | String _ -> () + done; + get_data p diff --git a/checker/analyze.mli b/checker/analyze.mli index 42efcf01df..9c837643fa 100644 --- a/checker/analyze.mli +++ b/checker/analyze.mli @@ -8,8 +8,20 @@ type obj = | Struct of int * data array (* tag × data *) | String of string -val parse_channel : in_channel -> (data * obj array) -val parse_string : string -> (data * obj array) +module LargeArray : +sig + type 'a t + val empty : 'a t + val length : 'a t -> int + val make : int -> 'a -> 'a t + val get : 'a t -> int -> 'a + val set : 'a t -> int -> 'a -> unit +end +(** A data structure similar to arrays but allowing to overcome the 2^22 length + limitation on 32-bit architecture. *) + +val parse_channel : in_channel -> (data * obj LargeArray.t) +val parse_string : string -> (data * obj LargeArray.t) (** {6 Functorized version} *) @@ -26,10 +38,13 @@ end module type S = sig type input - val parse : input -> (data * obj array) + val parse : input -> (data * obj LargeArray.t) (** Return the entry point and the reification of the memory out of a marshalled structure. *) end module Make (M : Input) : S with type input = M.t (** Functorized version of the previous code. *) + +val instantiate : data * obj LargeArray.t -> Obj.t +(** Create the OCaml object out of the reified representation. *) diff --git a/checker/check.ml b/checker/check.ml index 180ca1ece1..82341ad9b2 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -22,6 +22,11 @@ let extend_dirpath p id = DirPath.make (id :: DirPath.repr p) type section_path = { dirpath : string list ; basename : string } + +type object_file = +| PhysicalFile of CUnix.physical_path +| LogicalFile of section_path + let dir_of_path p = DirPath.make (List.map Id.of_string p.dirpath) let path_of_dirpath dir = @@ -69,11 +74,6 @@ let libraries_table = ref LibraryMap.empty let find_library dir = LibraryMap.find dir !libraries_table -let try_find_library dir = - try find_library dir - with Not_found -> - user_err Pp.(str ("Unknown library " ^ (DirPath.to_string dir))) - let library_full_filename dir = (find_library dir).library_filename (* If a library is loaded several time, then the first occurrence must @@ -129,8 +129,6 @@ type logical_path = DirPath.t let load_paths = ref ([],[] : CUnix.physical_path list * logical_path list) -let get_load_paths () = fst !load_paths - (* Hints to partially detects if two paths refer to the same repertory *) let rec remove_path_dot p = let curdir = Filename.concat Filename.current_dir_name "" in (* Unix: "./" *) @@ -227,13 +225,8 @@ let locate_absolute_library dir = let locate_qualified_library qid = try - let loadpath = - (* Search library in loadpath *) - if qid.dirpath=[] then get_load_paths () - else - (* we assume qid is an absolute dirpath *) - load_paths_of_dir_path (dir_of_path qid) - in + (* we assume qid is an absolute dirpath *) + let loadpath = load_paths_of_dir_path (dir_of_path qid) in if loadpath = [] then raise LibUnmappedDir; let name = qid.basename^".vo" in let path, file = System.where_in_path loadpath name in @@ -263,7 +256,17 @@ let try_locate_absolute_library dir = | LibUnmappedDir -> error_unmapped_dir (path_of_dirpath dir) | LibNotFound -> error_lib_not_found (path_of_dirpath dir) -let try_locate_qualified_library qid = +let try_locate_qualified_library lib = match lib with +| PhysicalFile f -> + let () = + if not (System.file_exists_respecting_case "" f) then + error_lib_not_found { dirpath = []; basename = f; } + in + let dir = Filename.dirname f in + let base = Filename.chop_extension (Filename.basename f) in + let dir = extend_dirpath (find_logical_path dir) (Id.of_string base) in + (dir, f) +| LogicalFile qid -> try locate_qualified_library qid with @@ -298,18 +301,27 @@ let name_clash_message dir mdir f = (* Dependency graph *) let depgraph = ref LibraryMap.empty +let marshal_in_segment f ch = + try + let stop = input_binary_int ch in + let v = Analyze.instantiate (Analyze.parse_channel ch) in + let digest = Digest.input ch in + Obj.obj v, stop, digest + with _ -> + user_err (str "Corrupted file " ++ quote (str f)) + let intern_from_file (dir, f) = Flags.if_verbose chk_pp (str"[intern "++str f++str" ..."); let (sd,md,table,opaque_csts,digest) = try let ch = System.with_magic_number_check raw_intern_library f in - let (sd:Cic.summary_disk), _, digest = System.marshal_in_segment f ch in - let (md:Cic.library_disk), _, digest = System.marshal_in_segment f ch in - let (opaque_csts:'a option), _, udg = System.marshal_in_segment f ch in - let (discharging:'a option), _, _ = System.marshal_in_segment f ch in - let (tasks:'a option), _, _ = System.marshal_in_segment f ch in + let (sd:Cic.summary_disk), _, digest = marshal_in_segment f ch in + let (md:Cic.library_disk), _, digest = marshal_in_segment f ch in + let (opaque_csts:'a option), _, udg = marshal_in_segment f ch in + let (discharging:'a option), _, _ = marshal_in_segment f ch in + let (tasks:'a option), _, _ = marshal_in_segment f ch in let (table:Cic.opaque_table), pos, checksum = - System.marshal_in_segment f ch in + marshal_in_segment f ch in (* Verification of the final checksum *) let () = close_in ch in let ch = open_in_bin f in @@ -412,9 +424,3 @@ let recheck_library ~norec ~admit ~check = (fun (dir,_) -> pr_dirpath dir ++ fnl()) needed)); List.iter (check_one_lib nochk) needed; Flags.if_verbose Feedback.msg_notice (str"Modules were successfully checked") - -open Printf - -let mem s = - let m = try_find_library s in - h 0 (str (sprintf "%dk" (CObj.size_kb m))) diff --git a/checker/check.mli b/checker/check.mli new file mode 100644 index 0000000000..28ae385b5b --- /dev/null +++ b/checker/check.mli @@ -0,0 +1,30 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open CUnix +open Names + +type section_path = { + dirpath : string list; + basename : string; +} + +type object_file = +| PhysicalFile of physical_path +| LogicalFile of section_path + +type logical_path = DirPath.t + +val default_root_prefix : DirPath.t + +val add_load_path : physical_path * logical_path -> unit + +val recheck_library : + norec:object_file list -> + admit:object_file list -> + check:object_file list -> unit diff --git a/checker/check.mllib b/checker/check.mllib index 488507a13f..f79ba66e35 100644 --- a/checker/check.mllib +++ b/checker/check.mllib @@ -1,5 +1,6 @@ Coq_config +Analyze Hook Terminal Canary diff --git a/checker/checker.ml b/checker/checker.ml index e960a55fd2..fee31b6675 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -40,9 +40,10 @@ let dirpath_of_string s = [] -> Check.default_root_prefix | dir -> DirPath.make (List.map Id.of_string dir) let path_of_string s = - match parse_dir s with + if Filename.check_suffix s ".vo" then PhysicalFile s + else match parse_dir s with [] -> invalid_arg "path_of_string" - | l::dir -> {dirpath=dir; basename=l} + | l::dir -> LogicalFile {dirpath=dir; basename=l} let ( / ) = Filename.concat @@ -95,17 +96,13 @@ let add_rec_path ~unix_path ~coq_root = (* By the option -include -I or -R of the command line *) let includes = ref [] -let push_include (s, alias) = includes := (s,alias,false) :: !includes -let push_rec_include (s, alias) = includes := (s,alias,true) :: !includes +let push_include (s, alias) = includes := (s,alias) :: !includes let set_default_include d = push_include (d, Check.default_root_prefix) let set_include d p = let p = dirpath_of_string p in push_include (d,p) -let set_rec_include d p = - let p = dirpath_of_string p in - push_rec_include(d,p) (* Initializes the LoadPath *) let init_load_path () = @@ -131,8 +128,7 @@ let init_load_path () = add_path ~unix_path:"." ~coq_root:Check.default_root_prefix; (* additional loadpath, given with -I -include -R options *) List.iter - (fun (unix_path, coq_root, reci) -> - if reci then add_rec_path ~unix_path ~coq_root else add_path ~unix_path ~coq_root) + (fun (unix_path, coq_root) -> add_rec_path ~unix_path ~coq_root) (List.rev !includes); includes := [] @@ -144,15 +140,15 @@ let set_impredicative_set () = impredicative_set := Cic.ImpredicativeSet let engage () = Safe_typing.set_engagement (!impredicative_set) -let admit_list = ref ([] : section_path list) +let admit_list = ref ([] : object_file list) let add_admit s = admit_list := path_of_string s :: !admit_list -let norec_list = ref ([] : section_path list) +let norec_list = ref ([] : object_file list) let add_norec s = norec_list := path_of_string s :: !norec_list -let compile_list = ref ([] : section_path list) +let compile_list = ref ([] : object_file list) let add_compile s = compile_list := path_of_string s :: !compile_list @@ -178,7 +174,9 @@ let print_usage_channel co command = output_string co command; output_string co "coqchk options are:\n"; output_string co -" -R dir coqdir map physical dir to logical coqdir\ +" -Q dir coqdir map physical dir to logical coqdir\ +\n -R dir coqdir synonymous for -Q\ +\n\ \n\ \n -admit module load module and dependencies without checking\ \n -norec module check module but admit dependencies without checking\ @@ -310,6 +308,9 @@ let explain_exn = function report ()) | e -> CErrors.print e (* for anomalies and other uncaught exceptions *) +let deprecated flag = + Feedback.msg_warning (str "Deprecated flag " ++ quote (str flag)) + let parse_args argv = let rec parse = function | [] -> () @@ -323,12 +324,15 @@ let parse_args argv = Flags.coqlib_spec := true; parse rem - | ("-I"|"-include") :: d :: "-as" :: p :: rem -> set_include d p; parse rem + | ("-I"|"-include") :: d :: "-as" :: p :: rem -> deprecated "-I"; set_include d p; parse rem | ("-I"|"-include") :: d :: "-as" :: [] -> usage () - | ("-I"|"-include") :: d :: rem -> set_default_include d; parse rem + | ("-I"|"-include") :: d :: rem -> deprecated "-I"; set_default_include d; parse rem | ("-I"|"-include") :: [] -> usage () - | "-R" :: d :: p :: rem -> set_rec_include d p;parse rem + | "-Q" :: d :: p :: rem -> set_include d p;parse rem + | "-Q" :: ([] | [_]) -> usage () + + | "-R" :: d :: p :: rem -> set_include d p;parse rem | "-R" :: ([] | [_]) -> usage () | "-debug" :: rem -> set_debug (); parse rem diff --git a/checker/cic.mli b/checker/cic.mli index 3546509641..4a0e706aa1 100644 --- a/checker/cic.mli +++ b/checker/cic.mli @@ -208,7 +208,7 @@ type constant_def = | OpaqueDef of lazy_constr type constant_universes = - | Monomorphic_const of Univ.universe_context + | Monomorphic_const of Univ.ContextSet.t | Polymorphic_const of Univ.abstract_universe_context (** The [typing_flags] are instructions to the type-checker which @@ -303,7 +303,7 @@ type one_inductive_body = { } type abstract_inductive_universes = - | Monomorphic_ind of Univ.universe_context + | Monomorphic_ind of Univ.ContextSet.t | Polymorphic_ind of Univ.abstract_universe_context | Cumulative_ind of Univ.abstract_cumulativity_info diff --git a/checker/closure.ml b/checker/closure.ml index 7982ffa7a5..3a56bba015 100644 --- a/checker/closure.ml +++ b/checker/closure.ml @@ -279,7 +279,6 @@ and fterm = | FProj of projection * fconstr | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs - | FCase of case_info * fconstr * fconstr * fconstr array | FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *) | FLambda of int * (Name.t * constr) list * constr * fconstr subs | FProd of Name.t * fconstr * fconstr @@ -306,7 +305,6 @@ let update v1 (no,t) = type stack_member = | Zapp of fconstr array - | Zcase of case_info * fconstr * fconstr array | ZcaseT of case_info * constr * constr array * fconstr subs | Zproj of int * int * projection | Zfix of fconstr * stack @@ -456,13 +454,10 @@ let rec to_constr constr_fun lfts v = | FFlex (ConstKey op) -> Const op | FInd op -> Ind op | FConstruct op -> Construct op - | FCase (ci,p,c,ve) -> - Case (ci, constr_fun lfts p, - constr_fun lfts c, - Array.map (constr_fun lfts) ve) - | FCaseT (ci,p,c,ve,e) -> (* TODO: enable sharing, cf FCLOS below ? *) - to_constr constr_fun lfts - {norm=Red;term=FCase(ci,mk_clos2 e p,c,mk_clos_vect e ve)} + | FCaseT (ci,p,c,ve,e) -> + let fp = mk_clos2 e p in + let fve = mk_clos_vect e ve in + Case (ci, constr_fun lfts fp, constr_fun lfts c, Array.map (constr_fun lfts) fve) | FFix ((op,(lna,tys,bds)),e) -> let n = Array.length bds in let ftys = Array.map (mk_clos e) tys in @@ -532,9 +527,6 @@ let rec zip m stk = match stk with | [] -> m | Zapp args :: s -> zip {norm=neutr m.norm; term=FApp(m, args)} s - | Zcase(ci,p,br)::s -> - let t = FCase(ci, p, m, br) in - zip {norm=neutr m.norm; term=t} s | ZcaseT(ci,p,br,e)::s -> let t = FCaseT(ci, p, m, br, e) in zip {norm=neutr m.norm; term=t} s @@ -616,7 +608,7 @@ let rec get_args n tys f e stk = (* Eta expansion: add a reference to implicit surrounding lambda at end of stack *) let rec eta_expand_stack = function - | (Zapp _ | Zfix _ | Zcase _ | ZcaseT _ | Zproj _ + | (Zapp _ | Zfix _ | ZcaseT _ | Zproj _ | Zshift _ | Zupdate _ as e) :: s -> e :: eta_expand_stack s | [] -> @@ -720,7 +712,6 @@ let rec knh info m stk = | FCLOS(t,e) -> knht info e t (zupdate m stk) | FLOCKED -> assert false | FApp(a,b) -> knh info a (append_stack b (zupdate m stk)) - | FCase(ci,p,t,br) -> knh info t (Zcase(ci,p,br)::zupdate m stk) | FCaseT(ci,p,t,br,env) -> knh info t (ZcaseT(ci,p,br,env)::zupdate m stk) | FFix(((ri,n),(_,_,_)),_) -> (match get_nth_arg m ri.(n) stk with @@ -778,10 +769,6 @@ let rec knr info m stk = | None -> (set_norm m; (m,stk))) | FConstruct((ind,c),u) when red_set info.i_flags fIOTA -> (match strip_update_shift_app m stk with - (depth, args, Zcase(ci,_,br)::s) -> - assert (ci.ci_npar>=0); - let rargs = drop_parameters depth ci.ci_npar args in - kni info br.(c-1) (rargs@s) | (depth, args, ZcaseT(ci,_,br,env)::s) -> assert (ci.ci_npar>=0); let rargs = drop_parameters depth ci.ci_npar args in @@ -798,7 +785,7 @@ let rec knr info m stk = | (_,args,s) -> (m,args@s)) | FCoFix _ when red_set info.i_flags fIOTA -> (match strip_update_shift_app m stk with - (_, args, (((Zcase _|ZcaseT _)::_) as stk')) -> + (_, args, (((ZcaseT _)::_) as stk')) -> let (fxe,fxbd) = contract_fix_vect m.term in knit info fxe fxbd (args@stk') | (_,args,s) -> (m,args@s)) diff --git a/checker/closure.mli b/checker/closure.mli index 957cc4adb4..02d8b22fae 100644 --- a/checker/closure.mli +++ b/checker/closure.mli @@ -98,7 +98,6 @@ type fterm = | FProj of projection * fconstr | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs - | FCase of case_info * fconstr * fconstr * fconstr array | FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *) | FLambda of int * (Name.t * constr) list * constr * fconstr subs | FProd of Name.t * fconstr * fconstr @@ -115,7 +114,6 @@ type fterm = type stack_member = | Zapp of fconstr array - | Zcase of case_info * fconstr * fconstr array | ZcaseT of case_info * constr * constr array * fconstr subs | Zproj of int * int * projection | Zfix of fconstr * stack diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index 63e28448f9..4357a690ef 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -29,7 +29,7 @@ let check_constant_declaration env kn cb = (** [env'] contains De Bruijn universe variables *) let env' = match cb.const_universes with - | Monomorphic_const ctx -> push_context ~strict:true ctx env + | Monomorphic_const ctx -> push_context_set ~strict:true ctx env | Polymorphic_const auctx -> let ctx = Univ.AUContext.repr auctx in push_context ~strict:false ctx env diff --git a/checker/reduction.ml b/checker/reduction.ml index 6d8783d7e5..9b8eac04cd 100644 --- a/checker/reduction.ml +++ b/checker/reduction.ml @@ -42,8 +42,8 @@ let compare_stack_shape stk1 stk2 = | (_, Zapp l2::s2) -> compare_rec (bal-Array.length l2) stk1 s2 | (Zproj (n1,m1,p1)::s1, Zproj (n2,m2,p2)::s2) -> Int.equal bal 0 && compare_rec 0 s1 s2 - | ((Zcase(c1,_,_)|ZcaseT(c1,_,_,_))::s1, - (Zcase(c2,_,_)|ZcaseT(c2,_,_,_))::s2) -> + | ((ZcaseT(c1,_,_,_))::s1, + (ZcaseT(c2,_,_,_))::s2) -> bal=0 (* && c1.ci_ind = c2.ci_ind *) && compare_rec 0 s1 s2 | (Zfix(_,a1)::s1, Zfix(_,a2)::s2) -> bal=0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2 @@ -78,8 +78,7 @@ let pure_stack lfts stk = (l, Zlfix((lfx,fx),pa)::pstk) | (ZcaseT(ci,p,br,env),(l,pstk)) -> (l,Zlcase(ci,l,mk_clos env p,mk_clos_vect env br)::pstk) - | (Zcase(ci,p,br),(l,pstk)) -> - (l,Zlcase(ci,l,p,br)::pstk)) in + ) in snd (pure_rec lfts stk) (****************************************************************************) @@ -243,7 +242,6 @@ let rec no_arg_available = function | Zshift _ :: stk -> no_arg_available stk | Zapp v :: stk -> Array.length v = 0 && no_arg_available stk | Zproj _ :: _ -> true - | Zcase _ :: _ -> true | ZcaseT _ :: _ -> true | Zfix _ :: _ -> true @@ -256,7 +254,6 @@ let rec no_nth_arg_available n = function if n >= k then no_nth_arg_available (n-k) stk else false | Zproj _ :: _ -> true - | Zcase _ :: _ -> true | ZcaseT _ :: _ -> true | Zfix _ :: _ -> true @@ -266,13 +263,12 @@ let rec no_case_available = function | Zshift _ :: stk -> no_case_available stk | Zapp _ :: stk -> no_case_available stk | Zproj (_,_,_) :: _ -> false - | Zcase _ :: _ -> false | ZcaseT _ :: _ -> false | Zfix _ :: _ -> true let in_whnf (t,stk) = match fterm_of t with - | (FLetIn _ | FCase _ | FCaseT _ | FApp _ | FCLOS _ | FLIFT _ | FCast _) -> false + | (FLetIn _ | FCaseT _ | FApp _ | FCLOS _ | FLIFT _ | FCast _) -> false | FLambda _ -> no_arg_available stk | FConstruct _ -> no_case_available stk | FCoFix _ -> no_case_available stk @@ -504,8 +500,8 @@ and eqappr univ cv_pb infos (lft1,st1) (lft2,st2) = else raise NotConvertible (* Should not happen because both (hd1,v1) and (hd2,v2) are in whnf *) - | ( (FLetIn _, _) | (FCase _,_) | (FCaseT _,_) | (FApp _,_) | (FCLOS _,_) | (FLIFT _,_) - | (_, FLetIn _) | (_,FCase _) | (_,FCaseT _) | (_,FApp _) | (_,FCLOS _) | (_,FLIFT _) + | ( (FLetIn _, _) | (FCaseT _,_) | (FApp _,_) | (FCLOS _,_) | (FLIFT _,_) + | (_, FLetIn _) | (_,FCaseT _) | (_,FApp _) | (_,FCLOS _) | (_,FLIFT _) | (FLOCKED,_) | (_,FLOCKED) ) -> assert false (* In all other cases, terms are not convertible *) diff --git a/checker/values.ml b/checker/values.ml index 9e16c8435e..5a371164c6 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -13,7 +13,7 @@ To ensure this file is up-to-date, 'make' now compares the md5 of cic.mli with a copy we maintain here: -MD5 f4b00c567a972ae950b9ed10c533fda5 checker/cic.mli +MD5 56ac4cade33eff3d26ed5cdadb580c7e checker/cic.mli *) @@ -215,7 +215,7 @@ let v_projbody = let v_typing_flags = v_tuple "typing_flags" [|v_bool; v_bool|] -let v_const_univs = v_sum "constant_universes" 0 [|[|v_context|]; [|v_abs_context|]|] +let v_const_univs = v_sum "constant_universes" 0 [|[|v_context_set|]; [|v_abs_context|]|] let v_cb = v_tuple "constant_body" [|v_section_ctxt; @@ -265,7 +265,7 @@ let v_mind_record = Annot ("mind_record", let v_ind_pack_univs = v_sum "abstract_inductive_universes" 0 - [|[|v_context|]; [|v_abs_context|]; [|v_abs_cum_info|]|] + [|[|v_context_set|]; [|v_abs_context|]; [|v_abs_cum_info|]|] let v_ind_pack = v_tuple "mutual_inductive_body" [|Array v_one_ind; diff --git a/checker/votour.ml b/checker/votour.ml index 0998bb94b1..77c9999c42 100644 --- a/checker/votour.ml +++ b/checker/votour.ml @@ -10,6 +10,8 @@ open Values (** {6 Interactive visit of a vo} *) +let max_string_length = 1024 + let rec read_num max = let quit () = Printf.printf "\nGoodbye!\n%!"; @@ -75,48 +77,51 @@ struct type obj = data - let memory = ref [||] - let sizes = ref [||] + let memory = ref LargeArray.empty + let sizes = ref LargeArray.empty (** size, in words *) let ws = Sys.word_size / 8 - let rec init_size seen = function - | Int _ | Atm _ | Fun _ -> 0 + let rec init_size seen k = function + | Int _ | Atm _ | Fun _ -> k 0 | Ptr p -> - if seen.(p) then 0 + if LargeArray.get seen p then k 0 else - let () = seen.(p) <- true in - match (!memory).(p) with + let () = LargeArray.set seen p true in + match LargeArray.get !memory p with | Struct (tag, os) -> - let fold accu o = accu + 1 + init_size seen o in - let size = Array.fold_left fold 1 os in - let () = (!sizes).(p) <- size in - size + let len = Array.length os in + let rec fold i accu k = + if i == len then k accu + else + init_size seen (fun n -> fold (succ i) (accu + 1 + n) k) os.(i) + in + fold 0 1 (fun size -> let () = LargeArray.set !sizes p size in k size) | String s -> let size = 2 + (String.length s / ws) in - let () = (!sizes).(p) <- size in - size + let () = LargeArray.set !sizes p size in + k size let size = function | Int _ | Atm _ | Fun _ -> 0 - | Ptr p -> (!sizes).(p) + | Ptr p -> LargeArray.get !sizes p let repr = function | Int i -> INT i | Atm t -> BLOCK (t, [||]) | Fun _ -> OTHER | Ptr p -> - match (!memory).(p) with + match LargeArray.get !memory p with | Struct (tag, os) -> BLOCK (tag, os) | String s -> STRING s let input ch = let obj, mem = parse_channel ch in let () = memory := mem in - let () = sizes := Array.make (Array.length mem) (-1) in - let seen = Array.make (Array.length mem) false in - let _ = init_size seen obj in + let () = sizes := LargeArray.make (LargeArray.length mem) (-1) in + let seen = LargeArray.make (LargeArray.length mem) false in + let () = init_size seen ignore obj in obj let oid = function @@ -155,7 +160,8 @@ let get_string_in_tuple o = for i = 0 to Array.length o - 1 do match Repr.repr o.(i) with | STRING s -> - raise (TupleString (Printf.sprintf " [..%s..]" s)) + let len = min max_string_length (String.length s) in + raise (TupleString (Printf.sprintf " [..%s..]" (String.sub s 0 len))) | _ -> () done; "" @@ -165,7 +171,8 @@ let get_string_in_tuple o = let rec get_details v o = match v, Repr.repr o with | (String | Any), STRING s -> - Printf.sprintf " [%s]" (String.escaped s) + let len = min max_string_length (String.length s) in + Printf.sprintf " [%s]" (String.escaped (String.sub s 0 len)) |Tuple (_,v), BLOCK (_, o) -> get_string_in_tuple o |(Sum _|Any), BLOCK (tag, _) -> Printf.sprintf " [tag=%i]" tag @@ -192,13 +199,13 @@ let access_children vs os pos = else raise Exit let access_list v o pos = - let rec loop o pos = match Repr.repr o with - | INT 0 -> [] + let rec loop o pos accu = match Repr.repr o with + | INT 0 -> List.rev accu | BLOCK (0, [|hd; tl|]) -> - (v, hd, 0 :: pos) :: loop tl (1 :: pos) + loop tl (1 :: pos) ((v, hd, 0 :: pos) :: accu) | _ -> raise Exit in - Array.of_list (loop o pos) + Array.of_list (loop o pos []) let access_block o = match Repr.repr o with | BLOCK (tag, os) -> (tag, os) @@ -227,7 +234,16 @@ let rec get_children v o pos = match v with | BLOCK (0, [|x|]) -> [|(v, x, 0 :: pos)|] | _ -> raise Exit end - |String | Int -> [||] + | String -> + begin match Repr.repr o with + | STRING _ -> [||] + | _ -> raise Exit + end + | Int -> + begin match Repr.repr o with + | INT _ -> [||] + | _ -> raise Exit + end |Annot (s,v) -> get_children v o pos |Any -> raise Exit |Dyn -> diff --git a/configure.ml b/configure.ml index 0952b15f58..3850f119b2 100644 --- a/configure.ml +++ b/configure.ml @@ -178,6 +178,20 @@ let which prog = let program_in_path prog = try let _ = which prog in true with Not_found -> false +(** Choose a command among a list of candidates + (command name, mandatory arguments, arguments for this test). + Chooses the first one whose execution outputs a non-empty (first) line. + Dies with message [msg] if none is found. *) + +let select_command msg candidates = + let rec search = function + | [] -> die msg + | (p, x, y) :: tl -> + if fst (tryrun p (x @ y)) <> "" + then List.fold_left (Printf.sprintf "%s %s") p x + else search tl + in search candidates + (** As per bug #4828, ocamlfind on Windows/Cygwin barfs if you pass it a quoted path to camlpXo via -pp. So we only quote camlpXo on not Windows, and warn on Windows if the path contains spaces *) @@ -266,6 +280,7 @@ module Prefs = struct let nativecompiler = ref (not (os_type_win32 || os_type_cygwin)) let coqwebsite = ref "http://coq.inria.fr/" let force_caml_version = ref false + let force_findlib_version = ref false let warn_error = ref false end @@ -334,6 +349,8 @@ let args_options = Arg.align [ " URL of the coq website"; "-force-caml-version", Arg.Set Prefs.force_caml_version, " Force OCaml version"; + "-force-findlib-version", Arg.Set Prefs.force_findlib_version, + " Force findlib version"; "-warn-error", Arg.Set Prefs.warn_error, " Make OCaml warnings into errors"; "-camldir", Arg.String (fun _ -> ()), @@ -439,7 +456,7 @@ let browser = (** * OCaml programs *) -let camlbin, caml_version, camllib = +let camlbin, caml_version, camllib, findlib_version = let () = match !Prefs.ocamlfindcmd with | Some cmd -> reset_caml_find camlexec cmd | None -> @@ -451,6 +468,7 @@ let camlbin, caml_version, camllib = if not (is_executable camlexec.find) then die ("Error: cannot find the executable '"^camlexec.find^"'.") else + let findlib_version, _ = run camlexec.find ["query"; "findlib"; "-format"; "%v"] in let caml_version, _ = run camlexec.find ["ocamlc";"-version"] in let camllib, _ = run camlexec.find ["printconf";"stdlib"] in let camlbin = (* TODO beurk beurk beurk *) @@ -461,7 +479,7 @@ let camlbin, caml_version, camllib = let () = if is_executable (camlbin / "ocaml") then reset_caml_top camlexec (camlbin / "ocaml") in - camlbin, caml_version, camllib + camlbin, caml_version, camllib, findlib_version let camlp4compat = "-loc loc" @@ -491,8 +509,27 @@ let check_caml_version () = let _ = check_caml_version () -let coq_debug_flag_opt = - if caml_version_nums >= [3;10] then coq_debug_flag else "" +let findlib_version_list = numeric_prefix_list findlib_version + +let findlib_version_nums = + try + if List.length findlib_version_list < 2 then failwith "bad version"; + List.map s2i findlib_version_list + with _ -> + die ("I found ocamlfind but cannot read its version number!\n" ^ + "Is it installed properly?") + +let check_findlib_version () = + if findlib_version_nums >= [1;4;1] then + printf "You have OCamlfind %s. Good!\n" findlib_version + else + let () = printf "Your version of OCamlfind is %s.\n" findlib_version in + if !Prefs.force_findlib_version then + printf "*Warning* Your version of OCamlfind is outdated.\n" + else + die "You need OCamlfind 1.4.1 or later." + +let _ = check_findlib_version () let camltag = match caml_version_list with | x::y::_ -> "OCAML"^x^y @@ -655,6 +692,22 @@ let operating_system, osdeplibs = else (try Sys.getenv "OS" with Not_found -> ""), osdeplibs +(** Num library *) + +(* since 4.06, the Num library is no longer distributed with OCaml (replaced + by Zarith) +*) + +let check_for_numlib () = + if caml_version_nums >= [4;6;0] then + let numlib,_ = tryrun camlexec.find ["query";"num"] in + match numlib with + | "" -> + die "Num library not installed, required for OCaml 4.06 or later" + | _ -> printf "You have the Num library installed. Good!\n" + +let numlib = + check_for_numlib () (** * lablgtk2 and CoqIDE *) @@ -688,11 +741,11 @@ let get_lablgtkdir () = else "", msg | None -> let msg = OCamlFind in - let d1,_ = tryrun "ocamlfind" ["query";"lablgtk2.sourceview2"] in + let d1,_ = tryrun camlexec.find ["query";"lablgtk2.sourceview2"] in if d1 <> "" && check_lablgtkdir msg d1 then d1, msg else (* In debian wheezy, ocamlfind knows only of lablgtk2 *) - let d2,_ = tryrun "ocamlfind" ["query";"lablgtk2"] in + let d2,_ = tryrun camlexec.find ["query";"lablgtk2"] in if d2 <> "" && d2 <> d1 && check_lablgtkdir msg d2 then d2, msg else let msg = Stdlib in @@ -718,7 +771,7 @@ let check_lablgtk_version src dir = match src with if ans then printf "Warning: could not check the version of lablgtk2.\n"; (ans, "an unknown version") | OCamlFind -> - let v, _ = tryrun "ocamlfind" ["query"; "-format"; "%v"; "lablgtk2"] in + let v, _ = tryrun camlexec.find ["query"; "-format"; "%v"; "lablgtk2"] in try let vi = List.map s2i (numeric_prefix_list v) in ([2; 16] <= vi, v) @@ -775,7 +828,7 @@ let coqide_flags () = if !lablgtkdir <> "" then lablgtkincludes := sprintf "-I %S" !lablgtkdir; match coqide, arch with | "opt", "Darwin" when !Prefs.macintegration -> - let osxdir,_ = tryrun "ocamlfind" ["query";"lablgtkosx"] in + let osxdir,_ = tryrun camlexec.find ["query";"lablgtkosx"] in if osxdir <> "" then begin lablgtkincludes := sprintf "%s -I %S" !lablgtkincludes osxdir; idearchflags := "lablgtkosx.cma"; @@ -814,9 +867,10 @@ let strip = (** * md5sum command *) let md5sum = - if List.mem arch ["Darwin"; "FreeBSD"; "OpenBSD"] - then "md5 -q" else "md5sum" - + select_command "Don’t know how to compute MD5 checksums…" [ + "md5sum", [], [ "--version" ]; + "md5", ["-q"], [ "-s" ; "''" ]; + ] (** * Documentation : do we have latex, hevea, ... *) @@ -950,6 +1004,8 @@ let config_runtime () = let vmbyteflags = config_runtime () +let esc s = if String.contains s ' ' then "\"" ^ s ^ "\"" else s + (** * Summary of the configuration *) let print_summary () = @@ -962,16 +1018,16 @@ let print_summary () = pr " Other bytecode link flags : %s\n" custom_flag; pr " OS dependent libraries : %s\n" osdeplibs; pr " OCaml version : %s\n" caml_version; - pr " OCaml binaries in : %s\n" camlbin; - pr " OCaml library in : %s\n" camllib; + pr " OCaml binaries in : %s\n" (esc camlbin); + pr " OCaml library in : %s\n" (esc camllib); pr " OCaml flambda flags : %s\n" (String.concat " " !Prefs.flambda_flags); pr " %s version : %s\n" capitalized_camlpX camlpX_version; - pr " %s binaries in : %s\n" capitalized_camlpX camlpXbindir; - pr " %s library in : %s\n" capitalized_camlpX camlpXlibdir; + pr " %s binaries in : %s\n" capitalized_camlpX (esc camlpXbindir); + pr " %s library in : %s\n" capitalized_camlpX (esc camlpXlibdir); if best_compiler = "opt" then pr " Native dynamic link support : %B\n" hasnatdynlink; if coqide <> "no" then - pr " Lablgtk2 library in : %s\n" !lablgtkdir; + pr " Lablgtk2 library in : %s\n" (esc !lablgtkdir); if !idearchdef = "QUARTZ" then pr " Mac OS integration is on\n"; pr " CoqIde : %s\n" coqide; @@ -986,7 +1042,7 @@ let print_summary () = else (pr " Paths for true installation:\n"; List.iter - (fun (_,msg,dir,_) -> pr " - %s will be copied in %s\n" msg dir) + (fun (_,msg,dir,_) -> pr " - %s will be copied in %s\n" msg (esc dir)) install_dirs); pr "\n"; pr "If anything is wrong above, please restart './configure'.\n\n"; @@ -1168,7 +1224,7 @@ let write_makefile f = pr "CFLAGS=%s\n\n" cflags; pr "# Compilation debug flags\n"; pr "CAMLDEBUG=%s\n" coq_debug_flag; - pr "CAMLDEBUGOPT=%s\n\n" coq_debug_flag_opt; + pr "CAMLDEBUGOPT=%s\n\n" coq_debug_flag; pr "# Compilation profile flag\n"; pr "CAMLTIMEPROF=%s\n\n" coq_profile_flag; pr "# Camlp4 : flavor, binaries, libraries ...\n"; diff --git a/default.nix b/default.nix new file mode 100644 index 0000000000..3dd24bac4d --- /dev/null +++ b/default.nix @@ -0,0 +1,72 @@ +# How to use? + +# If you have Nix installed, you can get in an environment with everything +# needed to compile Coq and CoqIDE by running: +# $ nix-shell +# at the root of the Coq repository. + +# How to tweak default arguments? + +# nix-shell supports the --arg option (see Nix doc) that allows you for +# instance to do this: +# $ nix-shell --arg ocamlPackages "(import <nixpkgs> {}).ocamlPackages_latest" --arg buildIde false + +# You can also compile Coq and "install" it by running: +# $ make clean # (only needed if you have left-over compilation files) +# $ nix-build +# at the root of the Coq repository. +# nix-build also supports the --arg option, so you will be able to do: +# $ nix-build --arg doCheck false +# if you want to speed up things by not running the test-suite. +# Once the build is finished, you will find, in the current directory, +# a symlink to where Coq was installed. + +{ pkgs ? (import <nixpkgs> {}), ocamlPackages ? pkgs.ocamlPackages, + buildIde ? true, doCheck ? true }: + +with pkgs; + +stdenv.mkDerivation rec { + + name = "coq"; + + buildInputs = (with ocamlPackages; [ + + # Coq dependencies + ocaml + findlib + camlp5_strict + + ]) ++ (if buildIde then [ + + # CoqIDE dependencies + ocamlPackages.lablgtk + + ] else []) ++ (if doCheck then + + # Test-suite dependencies + let inherit (stdenv.lib) versionAtLeast optional; in + /* ncurses is required to build an OCaml REPL */ + optional (!versionAtLeast ocaml.version "4.07") ncurses + ++ [ + python + rsync + which + + ] else []) ++ (if lib.inNixShell then [ + ocamlPackages.merlin + ocamlPackages.ocpIndent + ocamlPackages.ocp-index + ] else []); + + src = + if lib.inNixShell then null + else + with builtins; filterSource + (path: _: !elem (baseNameOf path) [".git" "result" "bin"]) ./.; + + prefixKey = "-prefix "; + + inherit doCheck; + +} diff --git a/dev/base_include b/dev/base_include index f2912e1127..1da5e3ed18 100644 --- a/dev/base_include +++ b/dev/base_include @@ -130,7 +130,6 @@ open Reserve open Syntax_def open Constrexpr open Constrexpr_ops -open Topconstr open Notation_term open Notation_ops open Prettyp @@ -231,7 +230,7 @@ let pf_e gl s = let _ = Flags.in_debugger := false let _ = Flags.in_toplevel := true let _ = Constrextern.set_extern_reference - (fun ?loc _ r -> Libnames.Qualid (loc,Nametab.shortest_qualid_of_global Idset.empty r));; + (fun ?loc _ r -> Libnames.Qualid (loc,Nametab.shortest_qualid_of_global Id.Set.empty r));; let go () = Coqloop.loop Option.(get !Coqtop.drop_last_doc) diff --git a/dev/build/windows/patches_coq/coq_new.nsi b/dev/build/windows/patches_coq/coq_new.nsi index b88aa066d8..48f1d3759b 100644 --- a/dev/build/windows/patches_coq/coq_new.nsi +++ b/dev/build/windows/patches_coq/coq_new.nsi @@ -188,7 +188,7 @@ SectionEnd Section "Uninstall" ; Files and folders RMDir /r "$INSTDIR\bin" - RMDir /r "$INSTDIR\dev" + RMDir /r "$INSTDIR\doc" RMDir /r "$INSTDIR\etc" RMDir /r "$INSTDIR\lib" RMDir /r "$INSTDIR\libocaml" diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index cb1493d6aa..232b8a56e4 100644 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -115,7 +115,8 @@ ######################################################################## # CoLoR ######################################################################## -: ${Color_CI_SVNURL:=https://scm.gforge.inria.fr/anonscm/svn/color/trunk/color} +: ${CoLoR_CI_BRANCH:=master} +: ${CoLoR_CI_GITURL:=https://github.com/fblanqui/color.git} ######################################################################## # SF @@ -135,3 +136,9 @@ ######################################################################## : ${bignums_CI_BRANCH:=master} : ${bignums_CI_GITURL:=https://github.com/coq/bignums.git} + +######################################################################## +# Equations +######################################################################## +: ${Equations_CI_BRANCH:=8.8+alpha} +: ${Equations_CI_GITURL:=https://github.com/mattam82/Coq-Equations.git} diff --git a/dev/ci/ci-color.sh b/dev/ci/ci-color.sh index 309050057c..c3ae7552a9 100755 --- a/dev/ci/ci-color.sh +++ b/dev/ci/ci-color.sh @@ -3,33 +3,11 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -Color_CI_DIR=${CI_BUILD_DIR}/color +CoLoR_CI_DIR=${CI_BUILD_DIR}/color # Setup Bignums - source ${ci_dir}/ci-bignums.sh -# Compiles CoLoR - -svn checkout ${Color_CI_SVNURL} ${Color_CI_DIR} - -sed -i -e "s/From Coq Require Import BigN/From Bignums Require Import BigN/" ${Color_CI_DIR}/Util/*/*.v -sed -i -e "s/From Coq Require Export BigN/From Bignums Require Export BigN/" ${Color_CI_DIR}/Util/*/*.v -sed -i -e "s/From Coq Require Import BigZ/From Bignums Require Import BigZ/" ${Color_CI_DIR}/Util/*/*.v -sed -i -e "s/From Coq Require Export BigZ/From Bignums Require Export BigZ/" ${Color_CI_DIR}/Util/*/*.v - -# Adapt to PR #220 (FunInd not loaded in Prelude anymore) -sed -i -e "15i From Coq Require Import FunInd." ${Color_CI_DIR}/Coccinelle/basis/ordered_set.v -sed -i -e "8i From Coq Require Import FunInd." ${Color_CI_DIR}/Coccinelle/examples/cime_trace/equational_extension.v -sed -i -e "6i From Coq Require Import FunInd." ${Color_CI_DIR}/Coccinelle/examples/cime_trace/more_list_extention.v -sed -i -e "6i From Coq Require Import FunInd." ${Color_CI_DIR}/Coccinelle/examples/cime_trace/ring_extention.v -sed -i -e "27i From Coq Require Import FunInd." ${Color_CI_DIR}/Coccinelle/list_extensions/dickson.v -sed -i -e "26i From Coq Require Import FunInd." ${Color_CI_DIR}/Coccinelle/list_extensions/list_permut.v -sed -i -e "23i From Coq Require Import FunInd." ${Color_CI_DIR}/Coccinelle/list_extensions/list_set.v -sed -i -e "25i From Coq Require Import FunInd." ${Color_CI_DIR}/Coccinelle/list_extensions/list_sort.v -sed -i -e "21i From Coq Require Import FunInd." ${Color_CI_DIR}/Coccinelle/list_extensions/more_list.v -sed -i -e "21i From Coq Require Import FunInd." ${Color_CI_DIR}/Util/List/ListUtil.v -sed -i -e "17i From Coq Require Import FunInd." ${Color_CI_DIR}/Util/Multiset/MultisetOrder.v -sed -i -e "13i From Coq Require Import FunInd." ${Color_CI_DIR}/Util/Set/SetUtil.v - -( cd ${Color_CI_DIR} && make ) +# Compile CoLoR +git_checkout ${CoLoR_CI_BRANCH} ${CoLoR_CI_GITURL} ${CoLoR_CI_DIR} +( cd ${CoLoR_CI_DIR} && make ) diff --git a/dev/ci/ci-compcert.sh b/dev/ci/ci-compcert.sh index 4cfe0911b6..7bf2c7427d 100755 --- a/dev/ci/ci-compcert.sh +++ b/dev/ci/ci-compcert.sh @@ -8,6 +8,5 @@ CompCert_CI_DIR=${CI_BUILD_DIR}/CompCert opam install -j ${NJOBS} -y menhir git_checkout ${CompCert_CI_BRANCH} ${CompCert_CI_GITURL} ${CompCert_CI_DIR} -# Patch to avoid the upper version limit +#( cd ${CompCert_CI_DIR} && ./configure -ignore-coq-version x86_32-linux && make && make check-proof ) ( cd ${CompCert_CI_DIR} && ./configure -ignore-coq-version x86_32-linux && make ) - diff --git a/dev/ci/ci-equations.sh b/dev/ci/ci-equations.sh new file mode 100755 index 0000000000..f7470463d9 --- /dev/null +++ b/dev/ci/ci-equations.sh @@ -0,0 +1,10 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +Equations_CI_DIR=${CI_BUILD_DIR}/Equations + +git_checkout ${Equations_CI_BRANCH} ${Equations_CI_GITURL} ${Equations_CI_DIR} + +( cd ${Equations_CI_DIR} && coq_makefile -f _CoqProject -o Makefile && make -j ${NJOBS} && make -j ${NJOBS} test-suite && make -j ${NJOBS} examples && make install) diff --git a/dev/ci/ci-ltac2.sh b/dev/ci/ci-ltac2.sh index 4865be31ec..ed40036012 100755 --- a/dev/ci/ci-ltac2.sh +++ b/dev/ci/ci-ltac2.sh @@ -3,7 +3,7 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -ltac2_CI_DIR=${CI_BUILD_DIR}/coq-dpdgraph +ltac2_CI_DIR=${CI_BUILD_DIR}/ltac2 git_checkout ${ltac2_CI_BRANCH} ${ltac2_CI_GITURL} ${ltac2_CI_DIR} diff --git a/dev/ci/ci-sf.sh b/dev/ci/ci-sf.sh index 272041205c..4e8c7e145e 100755 --- a/dev/ci/ci-sf.sh +++ b/dev/ci/ci-sf.sh @@ -3,17 +3,33 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh -# XXX: Needs fixing to properly set the build directory. -wget ${sf_lf_CI_TARURL} -wget ${sf_plf_CI_TARURL} -wget ${sf_vfa_CI_TARURL} -tar xvfz lf.tgz -tar xvfz plf.tgz -tar xvfz vfa.tgz +mkdir -p ${CI_BUILD_DIR} && cd ${CI_BUILD_DIR} +wget -qO- ${sf_lf_CI_TARURL} | tar xvz +wget -qO- ${sf_plf_CI_TARURL} | tar xvz +wget -qO- ${sf_vfa_CI_TARURL} | tar xvz sed -i.bak '1i From Coq Require Extraction.' lf/Extraction.v sed -i.bak '1i From Coq Require Extraction.' vfa/Extract.v +# Delete useless calls to try omega; unfold +patch vfa/SearchTree.v <<EOF +*** SearchTree.v.bak 2017-09-06 19:12:59.000000000 +0200 +--- SearchTree.v 2017-11-21 16:34:41.000000000 +0100 +*************** +*** 674,683 **** + forall i j : key, ~ (i > j) -> ~ (i < j) -> i=j. + Proof. + intros. +- try omega. (* Oops! [omega] cannot solve this one. +- The problem is that [i] and [j] have type [key] instead of type [nat]. +- The solution is easy enough: *) +- unfold key in *. + omega. + + (** So, if you get stuck on an [omega] that ought to work, +--- 674,679 ---- +EOF + ( cd lf && make clean && make ) ( cd plf && sed -i.bak 's/(K,N)/((K,N))/' LibTactics.v && make clean && make ) diff --git a/dev/ci/ci-vst.sh b/dev/ci/ci-vst.sh index 5bfc408e96..5760fbafb0 100755 --- a/dev/ci/ci-vst.sh +++ b/dev/ci/ci-vst.sh @@ -8,6 +8,6 @@ VST_CI_DIR=${CI_BUILD_DIR}/VST # opam install -j ${NJOBS} -y menhir git_checkout ${VST_CI_BRANCH} ${VST_CI_GITURL} ${VST_CI_DIR} -# Targets are: msl veric floyd +# Targets are: msl veric floyd progs , we remove progs to save time # Patch to avoid the upper version limit -( cd ${VST_CI_DIR} && make IGNORECOQVERSION=true ) +( cd ${VST_CI_DIR} && make IGNORECOQVERSION=true .loadpath version.vo msl veric floyd ) diff --git a/dev/ci/user-overlays/01033-SkySkimmer-restrict-harder.sh b/dev/ci/user-overlays/01033-SkySkimmer-restrict-harder.sh new file mode 100644 index 0000000000..5c4dd1324f --- /dev/null +++ b/dev/ci/user-overlays/01033-SkySkimmer-restrict-harder.sh @@ -0,0 +1,9 @@ +if [ "$TRAVIS_PULL_REQUEST" = "1033" ] || [ "$TRAVIS_BRANCH" = "restrict-harder" ]; then + formal_topology_CI_BRANCH=ci + formal_topology_CI_GITURL=https://github.com/SkySkimmer/topology.git + + HoTT_CI_BRANCH=coq-pr-1033 + HoTT_CI_GITURL=https://github.com/SkySkimmer/HoTT.git + + Equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations.git +fi diff --git a/dev/ci/user-overlays/06158-herbelin-master+fix-pr6158-ltac-value-printer.sh b/dev/ci/user-overlays/06158-herbelin-master+fix-pr6158-ltac-value-printer.sh new file mode 100644 index 0000000000..cdca8e525a --- /dev/null +++ b/dev/ci/user-overlays/06158-herbelin-master+fix-pr6158-ltac-value-printer.sh @@ -0,0 +1,4 @@ +if [ "$TRAVIS_PULL_REQUEST" = "6158" ] || [ "$TRAVIS_BRANCH" = "master+some-fix-ltac-printing+refined-printers" ]; then + ltac2_CI_BRANCH=master+fix-pr6158-ltac-value-printer + ltac2_CI_GITURL=https://github.com/herbelin/ltac2.git +fi diff --git a/dev/ci/user-overlays/06197-ejgallego-plugins+remove_locality_hack.sh b/dev/ci/user-overlays/06197-ejgallego-plugins+remove_locality_hack.sh new file mode 100644 index 0000000000..c9f1272bed --- /dev/null +++ b/dev/ci/user-overlays/06197-ejgallego-plugins+remove_locality_hack.sh @@ -0,0 +1,4 @@ +if [ "$TRAVIS_PULL_REQUEST" = "6197" ] || [ "$TRAVIS_BRANCH" = "plugins+remove_locality_hack" ]; then + ltac2_CI_BRANCH=localityfixyou + ltac2_CI_GITURL=https://github.com/ejgallego/ltac2.git +fi diff --git a/dev/ci/user-overlays/06324-SkySkimmer-abstract-vs-restrict.sh b/dev/ci/user-overlays/06324-SkySkimmer-abstract-vs-restrict.sh new file mode 100644 index 0000000000..7e9b5febdd --- /dev/null +++ b/dev/ci/user-overlays/06324-SkySkimmer-abstract-vs-restrict.sh @@ -0,0 +1,4 @@ +if [ "$TRAVIS_PULL_REQUEST" = "6324" ] || [ "$TRAVIS_BRANCH" = "fix-6323-restrict+abstract" ]; then + Equations_CI_BRANCH=fix-coq-6324 + Equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations.git +fi diff --git a/dev/doc/changes.md b/dev/doc/changes.md index 707adce308..c69be4f4de 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -46,9 +46,9 @@ We changed the type of the following functions: - `Global.body_of_constant`: same as above. -We renamed the following datatypes: +We have changed the representation of the following types: -- `Pp.std_ppcmds` -> `Pp.t` +- `Lib.object_prefix` is now a record instead of a nested tuple. Some tactics and related functions now support static configurability, e.g.: diff --git a/dev/doc/univpoly.txt b/dev/doc/univpoly.txt index 6a69c57934..ca3d520c70 100644 --- a/dev/doc/univpoly.txt +++ b/dev/doc/univpoly.txt @@ -12,7 +12,7 @@ type pinductive = inductive puniverses type pconstructor = constructor puniverses type constr = ... - | Const of puniversess + | Const of puniverses | Ind of pinductive | Constr of pconstructor | Proj of constant * constr diff --git a/dev/lint-repository.sh b/dev/lint-repository.sh index ecf7880e20..87a8297461 100755 --- a/dev/lint-repository.sh +++ b/dev/lint-repository.sh @@ -11,6 +11,13 @@ CODE=0 if [ "(" "-n" "${TRAVIS_PULL_REQUEST}" ")" "-a" "(" "${TRAVIS_PULL_REQUEST}" "!=" "false" ")" ]; then + # skip PRs from before the linter existed + if [ -z "$(git ls-tree --name-only "${TRAVIS_PULL_REQUEST_SHA}" dev/lint-commits.sh)" ]; + then + 2>&1 echo "Linting skipped: pull request older than the linter." + exit 0 + fi + # Some problems are too widespread to fix in one commit, but we # can still check that they don't worsen. CUR_HEAD=${TRAVIS_COMMIT_RANGE%%...*} diff --git a/dev/tools/backport-pr.sh b/dev/tools/backport-pr.sh new file mode 100755 index 0000000000..4c4dbe1e97 --- /dev/null +++ b/dev/tools/backport-pr.sh @@ -0,0 +1,60 @@ +#!/usr/bin/env bash + +# Usage: dev/tools/backport-pr.sh <PR number> + +set -e + +PRNUM=$1 + +if ! git log master --grep "Merge PR #${PRNUM}" | grep "." > /dev/null; then + echo "PR #${PRNUM} does not exist." + exit 1 +fi + +SIGNATURE_STATUS=$(git log master --grep "Merge PR #${PRNUM}" --format="%G?") +git log master --grep "Merge PR #${PRNUM}" --format="%GG" +if [[ "${SIGNATURE_STATUS}" != "G" ]]; then + echo + read -p "Merge commit does not have a good (valid) signature. Bypass? [y/N] " -n 1 -r + echo + if [[ ! $REPLY =~ ^[Yy]$ ]]; then + exit 1 + fi +fi + +BRANCH=backport-pr-${PRNUM} +RANGE=$(git log master --grep "Merge PR #${PRNUM}" --format="%P" | sed 's/ /../') +MESSAGE=$(git log master --grep "Merge PR #${PRNUM}" --format="%s" | sed 's/Merge/Backport/') + +if git checkout -b ${BRANCH}; then + + if ! git cherry-pick -x ${RANGE}; then + echo "Please fix the conflicts, then exit." + bash + while ! git cherry-pick --continue; do + echo "Please fix the conflicts, then exit." + bash + done + fi + git checkout - + +else + + echo + read -p "Skip directly to merging phase? [y/N] " -n 1 -r + echo + if [[ ! $REPLY =~ ^[Yy]$ ]]; then + exit 1 + fi + +fi + +git merge -S --no-ff ${BRANCH} -m "${MESSAGE}" +git branch -d ${BRANCH} + +# To-Do: +# - Support for backporting a PR before it is merged +# - Automatically backport all PRs in the "Waiting to be backported" column using a command like: +# $ curl -s -H "Authorization: token ${GITHUB_TOKEN}" -H "Accept: application/vnd.github.inertia-preview+json" https://api.github.com/projects/columns/1358120/cards | jq -r '.[].content_url' | grep issue | sed 's/^.*issues\/\([0-9]*\)$/\1/' | tac +# (The ID of the column must first be obtained through https://api.github.com/repos/coq/coq/projects then https://api.github.com/projects/819866/columns.) +# - Then move each of the backported PR to the subsequent columns automatically as well... diff --git a/dev/tools/merge-pr.sh b/dev/tools/merge-pr.sh new file mode 100755 index 0000000000..0c4a79bfd3 --- /dev/null +++ b/dev/tools/merge-pr.sh @@ -0,0 +1,50 @@ +#!/usr/bin/env bash + +set -e + +# This script depends (at least) on git and jq. +# It should be used like this: dev/tools/merge-pr.sh /PR number/ + +#TODO: check arguments and show usage if relevant + +PR=$1 + +CURRENT_LOCAL_BRANCH=`git rev-parse --abbrev-ref HEAD` +REMOTE=`git config --get branch.$CURRENT_LOCAL_BRANCH.remote` +git fetch $REMOTE refs/pull/$PR/head + +API=https://api.github.com/repos/coq/coq + +BASE_BRANCH=`curl -s $API/pulls/$PR | jq -r '.base.label'` + +COMMIT=`git rev-parse FETCH_HEAD` +STATUS=`curl -s $API/commits/$COMMIT/status | jq -r '.state'` + +if [ $BASE_BRANCH != "coq:$CURRENT_LOCAL_BRANCH" ]; then + echo "Wrong base branch" + read -p "Bypass? [y/N] " -n 1 -r + echo + if [[ ! $REPLY =~ ^[Yy]$ ]] + then + exit 1 + fi +fi; + +if [ $STATUS != "success" ]; then + echo "CI status is \"$STATUS\"" + read -p "Bypass? [y/N] " -n 1 -r + echo + if [[ ! $REPLY =~ ^[Yy]$ ]] + then + exit 1 + fi +fi; + +git merge -S --no-ff FETCH_HEAD -m "Merge PR #$PR: `curl -s $API/pulls/$PR | jq -r '.title'`" -e + +# TODO: improve this check +if [[ `git diff $REMOTE/$CURRENT_LOCAL_BRANCH dev/ci` ]]; then + echo "******************************************" + echo "** WARNING: does this PR have overlays? **" + echo "******************************************" +fi diff --git a/dev/tools/should-check-whitespace.sh b/dev/tools/should-check-whitespace.sh index 8159506b41..d85d651070 100755 --- a/dev/tools/should-check-whitespace.sh +++ b/dev/tools/should-check-whitespace.sh @@ -2,4 +2,5 @@ # determine if a file has whitespace checking enabled in .gitattributes -git check-attr whitespace -- "$1" | grep -q -v 'unspecified$' +git ls-files --error-unmatch "$1" >/dev/null 2>&1 && +git check-attr whitespace -- "$1" | grep -q -v -e 'unset$' -e 'unspecified$' diff --git a/dev/top_printers.ml b/dev/top_printers.ml index b4c8ae33ca..832040ad2c 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -18,7 +18,6 @@ open Univ open Environ open Printer open Constr -open Evd open Goptions open Genarg open Clenv @@ -39,7 +38,7 @@ let ppfuture kx = pp (Future.print (fun _ -> str "_") kx) let ppid id = pp (Id.print id) let pplab l = pp (Label.print l) let ppmbid mbid = pp (str (MBId.debug_to_string mbid)) -let ppdir dir = pp (pr_dirpath dir) +let ppdir dir = pp (DirPath.print dir) let ppmp mp = pp(str (ModPath.debug_to_string mp)) let ppcon con = pp(Constant.debug_print con) let ppproj con = pp(Constant.debug_print (Projection.constant con)) @@ -60,8 +59,9 @@ let pprecarg = function let ppwf_paths x = pp (Rtree.pp_tree pprecarg x) (* term printers *) +let envpp pp = let sigma,env = Pfedit.get_current_context () in pp env sigma let rawdebug = ref false -let ppevar evk = pp (str (Evd.string_of_existential evk)) +let ppevar evk = pp (Evar.print evk) let ppconstr x = pp (Termops.print_constr (EConstr.of_constr x)) let ppeconstr x = pp (Termops.print_constr x) let ppconstr_expr x = pp (Ppconstr.pr_constr_expr x) @@ -69,9 +69,9 @@ let ppconstrdb x = pp(Flags.with_option rawdebug Termops.print_constr (EConstr.o let ppterm = ppconstr let ppsconstr x = ppconstr (Mod_subst.force_constr x) let ppconstr_univ x = Constrextern.with_universes ppconstr x -let ppglob_constr = (fun x -> pp(pr_lglob_constr x)) -let pppattern = (fun x -> pp(pr_constr_pattern x)) -let pptype = (fun x -> try pp(pr_ltype x) with e -> pp (str (Printexc.to_string e))) +let ppglob_constr = (fun x -> pp(pr_lglob_constr_env (Global.env()) x)) +let pppattern = (fun x -> pp(envpp pr_constr_pattern_env x)) +let pptype = (fun x -> try pp(envpp pr_ltype_env x) with e -> pp (str (Printexc.to_string e))) let ppfconstr c = ppconstr (CClosure.term_of_fconstr c) let ppbigint n = pp (str (Bigint.to_string n));; @@ -121,7 +121,7 @@ let rec pr_closure {idents=idents;typed=typed;untyped=untyped} = and pr_closed_glob_constr_idmap x = pridmap (fun _ -> pr_closed_glob_constr) x and pr_closed_glob_constr {closure=closure;term=term} = - pr_closure closure ++ pr_lglob_constr term + pr_closure closure ++ (pr_lglob_constr_env Global.(env ())) term let ppclosure x = pp (pr_closure x) let ppclosedglobconstr x = pp (pr_closed_glob_constr x) @@ -140,14 +140,14 @@ let safe_pr_global = function let ppglobal x = try pp(pr_global x) with _ -> safe_pr_global x let ppconst (sp,j) = - pp (str"#" ++ KerName.print sp ++ str"=" ++ pr_lconstr j.uj_val) + pp (str"#" ++ KerName.print sp ++ str"=" ++ envpp pr_lconstr_env j.uj_val) let ppvar ((id,a)) = - pp (str"#" ++ Id.print id ++ str":" ++ pr_lconstr a) + pp (str"#" ++ Id.print id ++ str":" ++ envpp pr_lconstr_env a) let genppj f j = let (c,t) = f j in (c ++ str " : " ++ t) -let ppj j = pp (genppj pr_ljudge j) +let ppj j = pp (genppj (envpp pr_ljudge_env) j) let prsubst s = pp (Mod_subst.debug_pr_subst s) let prdelta s = pp (Mod_subst.debug_pr_delta s) @@ -175,13 +175,13 @@ let ppclenv clenv = pp(pr_clenv clenv) let ppgoalgoal gl = pp(Goal.pr_goal gl) let ppgoal g = pp(Printer.pr_goal g) let ppgoalsigma g = pp(Printer.pr_goal g ++ Termops.pr_evar_map None (Refiner.project g)) -let pphintdb db = pp(Hints.pr_hint_db db) +let pphintdb db = pp(envpp Hints.pr_hint_db_env db) let ppproofview p = let gls,sigma = Proofview.proofview p in pp(pr_enum Goal.pr_goal gls ++ fnl () ++ Termops.pr_evar_map (Some 1) sigma) let ppopenconstr (x : Evd.open_constr) = - let (evd,c) = x in pp (Termops.pr_evar_map (Some 2) evd ++ pr_constr c) + let (evd,c) = x in pp (Termops.pr_evar_map (Some 2) evd ++ envpp pr_constr_env c) (* spiwack: deactivated until a replacement is found let pppftreestate p = pp(print_pftreestate p) *) @@ -262,7 +262,7 @@ let constr_display csr = "LetIn("^(name_display na)^","^(term_display b)^"," ^(term_display t)^","^(term_display c)^")" | App (c,l) -> "App("^(term_display c)^","^(array_display l)^")\n" - | Evar (e,l) -> "Evar("^(string_of_existential e)^","^(array_display l)^")" + | Evar (e,l) -> "Evar("^(Pp.string_of_ppcmds (Evar.print e))^","^(array_display l)^")" | Const (c,u) -> "Const("^(Constant.to_string c)^","^(universes_display u)^")" | Ind ((sp,i),u) -> "MutInd("^(MutInd.to_string sp)^","^(string_of_int i)^","^(universes_display u)^")" @@ -508,7 +508,7 @@ let _ = (function [c] when genarg_tag c = unquote (topwit wit_constr) && true -> let c = out_gen (rawwit wit_constr) c in - (fun _ -> in_current_context constr_display c) + (fun ~atts ~st -> in_current_context constr_display c; st) | _ -> failwith "Vernac extension: cannot occur") with e -> pp (CErrors.print e) @@ -524,7 +524,7 @@ let _ = (function [c] when genarg_tag c = unquote (topwit wit_constr) && true -> let c = out_gen (rawwit wit_constr) c in - (fun _ -> in_current_context print_pure_constr c) + (fun ~atts ~st -> in_current_context print_pure_constr c; st) | _ -> failwith "Vernac extension: cannot occur") with e -> pp (CErrors.print e) diff --git a/doc/common/macros.tex b/doc/common/macros.tex index 0a4251a373..81def1674c 100644 --- a/doc/common/macros.tex +++ b/doc/common/macros.tex @@ -94,8 +94,8 @@ \newcommand{\gallina}{\textsc{Gallina}} \newcommand{\Gallina}{\textsc{Gallina}} \newcommand{\CoqIDE}{\textsc{CoqIDE}} -\newcommand{\ocaml}{\textsc{Objective Caml}} -\newcommand{\camlpppp}{\textsc{Camlp4}} +\newcommand{\ocaml}{\textsc{OCaml}} +\newcommand{\camlpppp}{\textsc{Camlp5}} \newcommand{\emacs}{\textsc{GNU Emacs}} \newcommand{\ProofGeneral}{\textsc{Proof General}} \newcommand{\CIC}{\textsc{Cic}} diff --git a/doc/refman/Classes.tex b/doc/refman/Classes.tex index 22c75b4fc8..cab6739998 100644 --- a/doc/refman/Classes.tex +++ b/doc/refman/Classes.tex @@ -462,11 +462,18 @@ abbreviate a type, like {\tt relation A := A -> A -> Prop}. This is equivalent to {\tt Hint Transparent,Opaque} {\ident} {\tt: typeclass\_instances}. +\subsection{\tt Set Typeclasses Axioms Are Instances} +\optindex{Typeclasses Axioms Are Instances} + +This option (off by default since 8.8) automatically declares axioms +whose type is a typeclass at declaration time as instances of that +class. + \subsection{\tt Set Typeclasses Dependency Order} \optindex{Typeclasses Dependency Order} This option (on by default since 8.6) respects the dependency order between -subgoals, meaning that subgoals which are depended on by other subgoals +subgoals, meaning that subgoals which are depended on by other subgoals come first, while the non-dependent subgoals were put before the dependent ones previously (Coq v8.5 and below). This can result in quite different performance behaviors of proof search. diff --git a/doc/refman/Extraction.tex b/doc/refman/Extraction.tex index 83e866e9f3..79060e6062 100644 --- a/doc/refman/Extraction.tex +++ b/doc/refman/Extraction.tex @@ -391,9 +391,11 @@ Extract Inductive bool => "bool" [ "true" "false" ]. Extract Inductive sumbool => "bool" [ "true" "false" ]. \end{coq_example} -\noindent If an inductive constructor or type has arity 2 and the corresponding -string is enclosed by parenthesis, then the rest of the string is used -as infix constructor or type. +\noindent When extracting to {\ocaml}, if an inductive constructor or type +has arity 2 and the corresponding string is enclosed by parentheses, +and the string meets {\ocaml}'s lexical criteria for an infix symbol, +then the rest of the string is used as infix constructor or type. + \begin{coq_example} Extract Inductive list => "list" [ "[]" "(::)" ]. Extract Inductive prod => "(*)" [ "(,)" ]. diff --git a/doc/refman/RefMan-com.tex b/doc/refman/RefMan-com.tex index 8b1fc7c8f3..04a8a25c12 100644 --- a/doc/refman/RefMan-com.tex +++ b/doc/refman/RefMan-com.tex @@ -299,8 +299,9 @@ The following command-line options are recognized by the commands {\tt \section{Compiled libraries checker ({\tt coqchk})} -The {\tt coqchk} command takes a list of library paths as argument. -The corresponding compiled libraries (.vo files) are searched in the +The {\tt coqchk} command takes a list of library paths as argument, described +either by their logical name or by their physical filename, which must end in +{\tt .vo}. The corresponding compiled libraries (.vo files) are searched in the path, recursively processing the libraries they depend on. The content of all these libraries is then type-checked. The effect of {\tt coqchk} is only to return with normal exit code in case of success, @@ -330,9 +331,12 @@ code, it cannot be guaranteed that the produced compiled libraries are correct. {\tt coqchk} is a standalone verifier, and thus it cannot be tainted by such malicious code. -Command-line options {\tt -I}, {\tt -R}, {\tt -where} and +Command-line options {\tt -Q}, {\tt -R}, {\tt -where} and {\tt -impredicative-set} are supported by {\tt coqchk} and have the -same meaning as for {\tt coqtop}. Extra options are: +same meaning as for {\tt coqtop}. As there is no notion of relative paths in +object files {\tt -Q} and {\tt -R} have exactly the same meaning. + +Extra options are: \begin{description} \item[{\tt -norec} {\em module}]\ % diff --git a/doc/refman/RefMan-ltac.tex b/doc/refman/RefMan-ltac.tex index 5fb4585884..7034c56081 100644 --- a/doc/refman/RefMan-ltac.tex +++ b/doc/refman/RefMan-ltac.tex @@ -311,10 +311,11 @@ A sequence is an expression of the following form: \begin{quote} {\tacexpr}$_1$ {\tt ;} {\tacexpr}$_2$ \end{quote} -The expressions {\tacexpr}$_1$ and {\tacexpr}$_2$ are evaluated -to $v_1$ and $v_2$ which have to be tactic values. The tactic $v_1$ is -then applied and $v_2$ is applied to the goals generated by the -application of $v_1$. Sequence is left-associative. +The expression {\tacexpr}$_1$ is evaluated to $v_1$, which must be +a tactic value. The tactic $v_1$ is applied to the current goal, +possibly producing more goals. Then {\tacexpr}$_2$ is evaluated to +produce $v_2$, which must be a tactic value. The tactic $v_2$ is applied to +all the goals produced by the prior application. Sequence is associative. \subsubsection[Local application of tactics]{Local application of tactics\tacindex{[>\ldots$\mid$\ldots$\mid$\ldots]}\tacindex{;[\ldots$\mid$\ldots$\mid$\ldots]}\index{Tacticals![> \mid ]@{\tt {\tac$_0$};[{\tac$_1$}$\mid$\ldots$\mid$\tac$_n$]}}\index{Tacticals!; [ \mid ]@{\tt {\tac$_0$};[{\tac$_1$}$\mid$\ldots$\mid$\tac$_n$]}}} %\tacindex{; [ | ]} diff --git a/doc/refman/RefMan-oth.tex b/doc/refman/RefMan-oth.tex index 60cd8b73a4..3ebeba178a 100644 --- a/doc/refman/RefMan-oth.tex +++ b/doc/refman/RefMan-oth.tex @@ -10,6 +10,8 @@ defined object referred by {\qualid}. \begin{ErrMsgs} \item {\qualid} \errindex{not a defined object} +\item \errindex{Universe instance should have length} $n$. +\item \errindex{This object does not support universe names.} \end{ErrMsgs} \begin{Variants} @@ -27,6 +29,11 @@ constructor, abbreviation, \ldots), long name, type, implicit arguments and argument scopes. It does not print the body of definitions or proofs. +\item {\tt Print {\qualid}@\{names\}.}\\ +This locally renames the polymorphic universes of {\qualid}. +An underscore means the raw universe is printed. +This form can be used with {\tt Print Term} and {\tt About}. + %\item {\tt Print Proof {\qualid}.}\comindex{Print Proof}\\ %In case \qualid\ denotes an opaque theorem defined in a section, %it is stored on a special unprintable form and displayed as diff --git a/doc/refman/RefMan-uti.tex b/doc/refman/RefMan-uti.tex index 8f846f2f59..c411db1001 100644 --- a/doc/refman/RefMan-uti.tex +++ b/doc/refman/RefMan-uti.tex @@ -467,7 +467,7 @@ the \Coq\ language, and also a rudimentary indentation facility: \end{itemize} An inferior mode to run \Coq\ under Emacs, by Marco Maggesi, is also -included in the distribution, in file \texttt{coq-inferior.el}. +included in the distribution, in file \texttt{inferior-coq.el}. Instructions to use it are contained in this file. \subsection[{\ProofGeneral}]{{\ProofGeneral}\index{Proof General@{\ProofGeneral}}} diff --git a/doc/refman/Universes.tex b/doc/refman/Universes.tex index 75fac9454a..a1a6a43918 100644 --- a/doc/refman/Universes.tex +++ b/doc/refman/Universes.tex @@ -285,8 +285,10 @@ universes and explicitly instantiate polymorphic definitions. \label{UniverseCmd}} In the monorphic case, this command declares a new global universe named -{\ident}. It supports the polymorphic flag only in sections, meaning the -universe quantification will be discharged on each section definition +{\ident}, which can be referred to using its qualified name as +well. Global universe names live in a separate namespace. The command +supports the polymorphic flag only in sections, meaning the universe +quantification will be discharged on each section definition independently. One cannot mix polymorphic and monomorphic declarations in the same section. diff --git a/engine/eConstr.ml b/engine/eConstr.ml index bcfbc8081e..d303038c5d 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -9,7 +9,6 @@ open CErrors open Util open Names -open Term open Constr open Context open Evd @@ -55,7 +54,7 @@ struct type t = Sorts.t let make s = s let kind sigma = function - | Type u -> sort_of_univ (Evd.normalize_universe sigma u) + | Sorts.Type u -> Sorts.sort_of_univ (Evd.normalize_universe sigma u) | s -> s let unsafe_to_sorts s = s end @@ -85,16 +84,16 @@ let rec whd_evar sigma c = | Some c -> whd_evar sigma c | None -> c end - | App (f, args) when Term.isEvar f -> + | App (f, args) when isEvar f -> (** Enforce smart constructor invariant on applications *) - let ev = Term.destEvar f in + let ev = destEvar f in begin match safe_evar_value sigma ev with | None -> c | Some f -> whd_evar sigma (mkApp (f, args)) end - | Cast (c0, k, t) when Term.isEvar c0 -> + | Cast (c0, k, t) when isEvar c0 -> (** Enforce smart constructor invariant on casts. *) - let ev = Term.destEvar c0 in + let ev = destEvar c0 in begin match safe_evar_value sigma ev with | None -> c | Some c -> whd_evar sigma (mkCast (c, k, t)) @@ -115,7 +114,7 @@ let rec to_constr sigma c = match Constr.kind c with | Some c -> to_constr sigma c | None -> Constr.map (fun c -> to_constr sigma c) c end -| Sort (Type u) -> +| Sort (Sorts.Type u) -> let u' = Evd.normalize_universe sigma u in if u' == u then c else mkSort (Sorts.sort_of_univ u') | Const (c', u) when not (Univ.Instance.is_empty u) -> @@ -646,6 +645,37 @@ let eq_constr_universes_proj env sigma m n = let res = eq_constr' (unsafe_to_constr m) (unsafe_to_constr n) in if res then Some !cstrs else None +let universes_of_constr env sigma c = + let open Univ in + let open Declarations in + let rec aux s c = + match kind sigma c with + | Const (c, u) -> + begin match (Environ.lookup_constant c env).const_universes with + | Polymorphic_const _ -> + LSet.fold LSet.add (Instance.levels (EInstance.kind sigma u)) s + | Monomorphic_const (univs, _) -> + LSet.union s univs + end + | Ind ((mind,_), u) | Construct (((mind,_),_), u) -> + begin match (Environ.lookup_mind mind env).mind_universes with + | Cumulative_ind _ | Polymorphic_ind _ -> + LSet.fold LSet.add (Instance.levels (EInstance.kind sigma u)) s + | Monomorphic_ind (univs,_) -> + LSet.union s univs + end + | Sort u -> + let sort = ESorts.kind sigma u in + if Sorts.is_small sort then s + else + let u = Sorts.univ_of_sort sort in + LSet.fold LSet.add (Universe.levels u) s + | Evar (k, args) -> + let concl = Evd.evar_concl (Evd.find sigma k) in + fold sigma aux (aux s (of_constr concl)) c + | _ -> fold sigma aux s c + in aux LSet.empty c + open Context open Environ diff --git a/engine/eConstr.mli b/engine/eConstr.mli index e9ef302cf6..f54c422adc 100644 --- a/engine/eConstr.mli +++ b/engine/eConstr.mli @@ -187,9 +187,9 @@ val whd_evar : Evd.evar_map -> constr -> constr val eq_constr : Evd.evar_map -> t -> t -> bool val eq_constr_nounivs : Evd.evar_map -> t -> t -> bool -val eq_constr_universes : Evd.evar_map -> t -> t -> Universes.universe_constraints option -val leq_constr_universes : Evd.evar_map -> t -> t -> Universes.universe_constraints option -val eq_constr_universes_proj : Environ.env -> Evd.evar_map -> t -> t -> Universes.universe_constraints option +val eq_constr_universes : Evd.evar_map -> t -> t -> Universes.Constraints.t option +val leq_constr_universes : Evd.evar_map -> t -> t -> Universes.Constraints.t option +val eq_constr_universes_proj : Environ.env -> Evd.evar_map -> t -> t -> Universes.Constraints.t option val compare_constr : Evd.evar_map -> (t -> t -> bool) -> t -> t -> bool (** {6 Iterators} *) @@ -201,6 +201,10 @@ val iter_with_binders : Evd.evar_map -> ('a -> 'a) -> ('a -> t -> unit) -> 'a -> val iter_with_full_binders : Evd.evar_map -> (rel_declaration -> 'a -> 'a) -> ('a -> t -> unit) -> 'a -> t -> unit val fold : Evd.evar_map -> ('a -> t -> 'a) -> 'a -> t -> 'a +(** Gather the universes transitively used in the term, including in the + type of evars appearing in it. *) +val universes_of_constr : Environ.env -> Evd.evar_map -> t -> Univ.LSet.t + (** {6 Substitutions} *) module Vars : diff --git a/engine/engine.mllib b/engine/engine.mllib index afc02d7f6d..a3614f6c4a 100644 --- a/engine/engine.mllib +++ b/engine/engine.mllib @@ -1,12 +1,13 @@ -Logic_monad Universes +Univops UState +Nameops Evd EConstr Namegen Termops -Proofview_monad Evarutil +Logic_monad +Proofview_monad Proofview Ftactic -Geninterp diff --git a/engine/evarutil.ml b/engine/evarutil.ml index df4ef2ce71..3445b744a1 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -11,11 +11,11 @@ open Util open Names open Term open Constr -open Termops -open Namegen open Pre_env open Environ open Evd +open Termops +open Namegen module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration @@ -54,7 +54,7 @@ let new_global evd x = (* flush_and_check_evars fails if an existential is undefined *) -exception Uninstantiated_evar of existential_key +exception Uninstantiated_evar of Evar.t let rec flush_and_check_evars sigma c = match kind c with @@ -199,9 +199,10 @@ let whd_head_evar sigma c = let meta_counter_summary_name = "meta counter" (* Generator of metavariables *) -let new_meta = - let meta_ctr = Summary.ref 0 ~name:meta_counter_summary_name in - fun () -> incr meta_ctr; !meta_ctr +let meta_ctr, meta_counter_summary_tag = + Summary.ref_tag 0 ~name:meta_counter_summary_name + +let new_meta () = incr meta_ctr; !meta_ctr let mk_new_meta () = EConstr.mkMeta(new_meta()) diff --git a/engine/evarutil.mli b/engine/evarutil.mli index 62288ced46..9d0b973a7e 100644 --- a/engine/evarutil.mli +++ b/engine/evarutil.mli @@ -38,9 +38,9 @@ val new_pure_evar : named_context_val -> evar_map -> ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> ?candidates:constr list -> ?store:Store.t -> ?naming:Misctypes.intro_pattern_naming_expr -> - ?principal:bool -> types -> evar_map * evar + ?principal:bool -> types -> evar_map * Evar.t -val new_pure_evar_full : evar_map -> evar_info -> evar_map * evar +val new_pure_evar_full : evar_map -> evar_info -> evar_map * Evar.t (** the same with side-effects *) val e_new_evar : @@ -63,8 +63,8 @@ val e_new_type_evar : env -> evar_map ref -> val new_Type : ?rigid:rigid -> env -> evar_map -> evar_map * constr val e_new_Type : ?rigid:rigid -> env -> evar_map ref -> constr -val restrict_evar : evar_map -> existential_key -> Filter.t -> - ?src:Evar_kinds.t Loc.located -> constr list option -> evar_map * existential_key +val restrict_evar : evar_map -> Evar.t -> Filter.t -> + ?src:Evar_kinds.t Loc.located -> constr list option -> evar_map * Evar.t (** Polymorphic constants *) @@ -96,7 +96,7 @@ val non_instantiated : evar_map -> evar_info Evar.Map.t (** [head_evar c] returns the head evar of [c] if any *) exception NoHeadEvar -val head_evar : evar_map -> constr -> existential_key (** may raise NoHeadEvar *) +val head_evar : evar_map -> constr -> Evar.t (** may raise NoHeadEvar *) (* Expand head evar if any *) val whd_head_evar : evar_map -> constr -> constr @@ -116,13 +116,13 @@ val is_ground_env : evar_map -> env -> bool associating to each dependent evar [None] if it has no (partial) definition or [Some s] if [s] is the list of evars appearing in its (partial) definition. *) -val gather_dependent_evars : evar_map -> evar list -> (Evar.Set.t option) Evar.Map.t +val gather_dependent_evars : evar_map -> Evar.t list -> (Evar.Set.t option) Evar.Map.t (** [advance sigma g] returns [Some g'] if [g'] is undefined and is the current avatar of [g] (for instance [g] was changed by [clear] into [g']). It returns [None] if [g] has been (partially) solved. *) -val advance : evar_map -> evar -> evar option +val advance : evar_map -> Evar.t -> Evar.t option (** The following functions return the set of undefined evars contained in the object, the defined evars being traversed. @@ -177,7 +177,7 @@ val e_nf_evars_and_universes : evar_map ref -> (Constr.constr -> Constr.constr) val nf_evar_map_universes : evar_map -> evar_map * (Constr.constr -> Constr.constr) (** Replacing all evars, possibly raising [Uninstantiated_evar] *) -exception Uninstantiated_evar of existential_key +exception Uninstantiated_evar of Evar.t val flush_and_check_evars : evar_map -> constr -> Constr.constr (** {6 Term manipulation up to instantiation} *) @@ -233,12 +233,13 @@ val evd_comb0 : (evar_map -> evar_map * 'a) -> evar_map ref -> 'a val evd_comb1 : (evar_map -> 'b -> evar_map * 'a) -> evar_map ref -> 'b -> 'a val evd_comb2 : (evar_map -> 'b -> 'c -> evar_map * 'a) -> evar_map ref -> 'b -> 'c -> 'a -val subterm_source : existential_key -> Evar_kinds.t Loc.located -> +val subterm_source : Evar.t -> Evar_kinds.t Loc.located -> Evar_kinds.t Loc.located -val meta_counter_summary_name : string - -(** Deprecater *) +val meta_counter_summary_tag : int Summary.Dyn.tag +(** Deprecated *) type type_constraint = types option +[@@ocaml.deprecated "use the version in Evardefine"] type val_constraint = constr option +[@@ocaml.deprecated "use the version in Evardefine"] diff --git a/engine/evd.ml b/engine/evd.ml index 8d465384b1..e33c851f6e 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -127,7 +127,7 @@ end module Store = Store.Make () -type evar = existential_key +type evar = Evar.t let string_of_existential evk = "?X" ^ string_of_int (Evar.repr evk) @@ -243,7 +243,7 @@ let evar_instance_array test_id info args = instrec filter (evar_context info) 0 let make_evar_instance_array info args = - evar_instance_array (NamedDecl.get_id %> Term.isVarId) info args + evar_instance_array (NamedDecl.get_id %> isVarId) info args let instantiate_evar_array info c args = let inst = make_evar_instance_array info args in @@ -371,7 +371,7 @@ val key : Id.t -> t -> Evar.t end = struct -type t = Id.t EvMap.t * existential_key Id.Map.t +type t = Id.t EvMap.t * Evar.t Id.Map.t let empty = (EvMap.empty, Id.Map.empty) @@ -401,7 +401,7 @@ let rename evk id (evtoid, idtoev) = | None -> (EvMap.add evk id evtoid, Id.Map.add id evk idtoev) | Some id' -> if Id.Map.mem id idtoev then anomaly (str "Evar name already in use."); - (EvMap.update evk id evtoid (* overwrite old name *), Id.Map.add id evk (Id.Map.remove id' idtoev)) + (EvMap.set evk id evtoid (* overwrite old name *), Id.Map.add id evk (Id.Map.remove id' idtoev)) let reassign_name_defined evk evk' (evtoid, idtoev as names) = let id = try Some (EvMap.find evk evtoid) with Not_found -> None in @@ -466,9 +466,8 @@ let add d e i = add_with_name d e i let evar_counter_summary_name = "evar counter" (* Generator of existential names *) -let new_untyped_evar = - let evar_ctr = Summary.ref 0 ~name:evar_counter_summary_name in - fun () -> incr evar_ctr; Evar.unsafe_of_int !evar_ctr +let evar_ctr, evar_counter_summary_tag = Summary.ref_tag 0 ~name:evar_counter_summary_name +let new_untyped_evar () = incr evar_ctr; Evar.unsafe_of_int !evar_ctr let new_evar evd ?name evi = let evk = new_untyped_evar () in @@ -707,10 +706,10 @@ let extract_all_conv_pbs evd = extract_conv_pbs evd (fun _ -> true) let loc_of_conv_pb evd (pbty,env,t1,t2) = - match kind (fst (Term.decompose_app t1)) with + match kind (fst (decompose_app t1)) with | Evar (evk1,_) -> fst (evar_source evk1 evd) | _ -> - match kind (fst (Term.decompose_app t2)) with + match kind (fst (decompose_app t2)) with | Evar (evk2,_) -> fst (evar_source evk2 evd) | _ -> None @@ -756,10 +755,12 @@ let evar_universe_context d = d.universes let universe_context_set d = UState.context_set d.universes -let universe_context ~names ~extensible evd = - UState.universe_context ~names ~extensible evd.universes +let to_universe_context evd = UState.context evd.universes -let check_univ_decl evd decl = UState.check_univ_decl evd.universes decl +let const_univ_entry ~poly evd = UState.const_univ_entry ~poly evd.universes +let ind_univ_entry ~poly evd = UState.ind_univ_entry ~poly evd.universes + +let check_univ_decl ~poly evd decl = UState.check_univ_decl ~poly evd.universes decl let restrict_universe_context evd vars = { evd with universes = UState.restrict evd.universes vars } @@ -802,7 +803,7 @@ let make_evar_universe_context e l = | Some us -> List.fold_left (fun uctx (loc,id) -> - fst (UState.new_univ_variable ?loc univ_rigid (Some (Id.to_string id)) uctx)) + fst (UState.new_univ_variable ?loc univ_rigid (Some id) uctx)) uctx us (****************************************) @@ -933,8 +934,7 @@ let nf_constraints evd = let universe_of_name evd s = UState.universe_of_name evd.universes s -let add_universe_name evd s l = - { evd with universes = UState.add_universe_name evd.universes s l } +let universe_binders evd = UState.universe_binders evd.universes let universes evd = UState.ugraph evd.universes diff --git a/engine/evd.mli b/engine/evd.mli index af53735821..b28ce2a62d 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -28,12 +28,13 @@ open Environ (** {5 Existential variables and unification states} *) -(** {6 Evars} *) - -type evar = existential_key +type evar = Evar.t +[@@ocaml.deprecated "use Evar.t"] (** Existential variables. *) -val string_of_existential : evar -> string +(** {6 Evars} *) +val string_of_existential : Evar.t -> string +[@@ocaml.deprecated "use Evar.print"] (** {6 Evar filters} *) @@ -150,44 +151,44 @@ val has_undefined : evar_map -> bool there are uninstantiated evars in [sigma]. *) val new_evar : evar_map -> - ?name:Id.t -> evar_info -> evar_map * evar + ?name:Id.t -> evar_info -> evar_map * Evar.t (** Creates a fresh evar mapping to the given information. *) -val add : evar_map -> evar -> evar_info -> evar_map +val add : evar_map -> Evar.t -> evar_info -> evar_map (** [add sigma ev info] adds [ev] with evar info [info] in sigma. Precondition: ev must not preexist in [sigma]. *) -val find : evar_map -> evar -> evar_info +val find : evar_map -> Evar.t -> evar_info (** Recover the data associated to an evar. *) -val find_undefined : evar_map -> evar -> evar_info +val find_undefined : evar_map -> Evar.t -> evar_info (** Same as {!find} but restricted to undefined evars. For efficiency reasons. *) -val remove : evar_map -> evar -> evar_map +val remove : evar_map -> Evar.t -> evar_map (** Remove an evar from an evar map. Use with caution. *) -val mem : evar_map -> evar -> bool +val mem : evar_map -> Evar.t -> bool (** Whether an evar is present in an evarmap. *) -val fold : (evar -> evar_info -> 'a -> 'a) -> evar_map -> 'a -> 'a +val fold : (Evar.t -> evar_info -> 'a -> 'a) -> evar_map -> 'a -> 'a (** Apply a function to all evars and their associated info in an evarmap. *) -val fold_undefined : (evar -> evar_info -> 'a -> 'a) -> evar_map -> 'a -> 'a +val fold_undefined : (Evar.t -> evar_info -> 'a -> 'a) -> evar_map -> 'a -> 'a (** Same as {!fold}, but restricted to undefined evars. For efficiency reasons. *) -val raw_map : (evar -> evar_info -> evar_info) -> evar_map -> evar_map +val raw_map : (Evar.t -> evar_info -> evar_info) -> evar_map -> evar_map (** Apply the given function to all evars in the map. Beware: this function expects the argument function to preserve the kind of [evar_body], i.e. it must send [Evar_empty] to [Evar_empty] and [Evar_defined c] to some [Evar_defined c']. *) -val raw_map_undefined : (evar -> evar_info -> evar_info) -> evar_map -> evar_map +val raw_map_undefined : (Evar.t -> evar_info -> evar_info) -> evar_map -> evar_map (** Same as {!raw_map}, but restricted to undefined evars. For efficiency reasons. *) -val define : evar -> constr -> evar_map -> evar_map +val define : Evar.t-> constr -> evar_map -> evar_map (** Set the body of an evar to the given constr. It is expected that: {ul {- The evar is already present in the evarmap.} @@ -198,16 +199,16 @@ val define : evar -> constr -> evar_map -> evar_map val cmap : (constr -> constr) -> evar_map -> evar_map (** Map the function on all terms in the evar map. *) -val is_evar : evar_map -> evar -> bool +val is_evar : evar_map -> Evar.t-> bool (** Alias for {!mem}. *) -val is_defined : evar_map -> evar -> bool +val is_defined : evar_map -> Evar.t-> bool (** Whether an evar is defined in an evarmap. *) -val is_undefined : evar_map -> evar -> bool +val is_undefined : evar_map -> Evar.t-> bool (** Whether an evar is not defined in an evarmap. *) -val add_constraints : evar_map -> Univ.constraints -> evar_map +val add_constraints : evar_map -> Univ.Constraint.t -> evar_map (** Add universe constraints in an evar map. *) val undefined_map : evar_map -> evar_info Evar.Map.t @@ -240,31 +241,31 @@ val evars_reset_evd : ?with_conv_pbs:bool -> ?with_univs:bool -> (** {6 Misc} *) -val restrict : evar -> Filter.t -> ?candidates:constr list -> - ?src:Evar_kinds.t located -> evar_map -> evar_map * evar +val restrict : Evar.t-> Filter.t -> ?candidates:constr list -> + ?src:Evar_kinds.t located -> evar_map -> evar_map * Evar.t (** Restrict an undefined evar into a new evar by filtering context and possibly limiting the instances to a set of candidates *) -val is_restricted_evar : evar_info -> evar option +val is_restricted_evar : evar_info -> Evar.t option (** Tell if an evar comes from restriction of another evar, and if yes, which *) -val downcast : evar -> types -> evar_map -> evar_map +val downcast : Evar.t-> types -> evar_map -> evar_map (** Change the type of an undefined evar to a new type assumed to be a subtype of its current type; subtyping must be ensured by caller *) -val evar_source : existential_key -> evar_map -> Evar_kinds.t located +val evar_source : Evar.t -> evar_map -> Evar_kinds.t located (** Convenience function. Wrapper around {!find} to recover the source of an evar in a given evar map. *) -val evar_ident : existential_key -> evar_map -> Id.t option +val evar_ident : Evar.t -> evar_map -> Id.t option -val rename : existential_key -> Id.t -> evar_map -> evar_map +val rename : Evar.t -> Id.t -> evar_map -> evar_map -val evar_key : Id.t -> evar_map -> existential_key +val evar_key : Id.t -> evar_map -> Evar.t val evar_source_of_meta : metavariable -> evar_map -> Evar_kinds.t located -val dependent_evar_ident : existential_key -> evar_map -> Id.t +val dependent_evar_ident : Evar.t -> evar_map -> Id.t (** {5 Side-effects} *) @@ -315,7 +316,7 @@ val whd_sort_variable : evar_map -> constr -> constr exception UniversesDiffer -val add_universe_constraints : evar_map -> Universes.universe_constraints -> evar_map +val add_universe_constraints : evar_map -> Universes.Constraints.t -> evar_map (** Add the given universe unification constraints to the evar map. @raises UniversesDiffer in case a first-order unification fails. @raises UniverseInconsistency @@ -490,8 +491,10 @@ val univ_flexible_alg : rigid type 'a in_evar_universe_context = 'a * UState.t val evar_universe_context_set : UState.t -> Univ.ContextSet.t -val evar_universe_context_constraints : UState.t -> Univ.constraints +val evar_universe_context_constraints : UState.t -> Univ.Constraint.t val evar_context_universe_context : UState.t -> Univ.UContext.t +[@@ocaml.deprecated "alias of UState.context"] + val evar_universe_context_of : Univ.ContextSet.t -> UState.t val empty_evar_universe_context : UState.t val union_evar_universe_context : UState.t -> UState.t -> @@ -502,15 +505,15 @@ val constrain_variables : Univ.LSet.t -> UState.t -> UState.t val evar_universe_context_of_binders : Universes.universe_binders -> UState.t - + val make_evar_universe_context : env -> (Id.t located) list option -> UState.t -val restrict_universe_context : evar_map -> Univ.LSet.t -> evar_map +val restrict_universe_context : evar_map -> Univ.LSet.t -> evar_map (** Raises Not_found if not a name for a universe in this map. *) -val universe_of_name : evar_map -> string -> Univ.Level.t -val add_universe_name : evar_map -> string -> Univ.Level.t -> evar_map +val universe_of_name : evar_map -> Id.t -> Univ.Level.t -val add_constraints_context : UState.t -> - Univ.constraints -> UState.t +val universe_binders : evar_map -> Universes.universe_binders +val add_constraints_context : UState.t -> + Univ.Constraint.t -> UState.t val normalize_evar_universe_context_variables : UState.t -> @@ -519,9 +522,9 @@ val normalize_evar_universe_context_variables : UState.t -> val normalize_evar_universe_context : UState.t -> UState.t -val new_univ_level_variable : ?loc:Loc.t -> ?name:string -> rigid -> evar_map -> evar_map * Univ.Level.t -val new_univ_variable : ?loc:Loc.t -> ?name:string -> rigid -> evar_map -> evar_map * Univ.Universe.t -val new_sort_variable : ?loc:Loc.t -> ?name:string -> rigid -> evar_map -> evar_map * Sorts.t +val new_univ_level_variable : ?loc:Loc.t -> ?name:Id.t -> rigid -> evar_map -> evar_map * Univ.Level.t +val new_univ_variable : ?loc:Loc.t -> ?name:Id.t -> rigid -> evar_map -> evar_map * Univ.Universe.t +val new_sort_variable : ?loc:Loc.t -> ?name:Id.t -> rigid -> evar_map -> evar_map * Sorts.t val add_global_univ : evar_map -> Univ.Level.t -> evar_map @@ -551,13 +554,20 @@ val check_leq : evar_map -> Univ.Universe.t -> Univ.Universe.t -> bool val evar_universe_context : evar_map -> UState.t val universe_context_set : evar_map -> Univ.ContextSet.t -val universe_context : names:(Id.t located) list -> extensible:bool -> evar_map -> - (Id.t * Univ.Level.t) list * Univ.UContext.t 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.UContext.t +(** [to_universe_context evm] extracts the local universes and + constraints of [evm] and orders the universes the same as + [Univ.ContextSet.to_context]. *) +val to_universe_context : evar_map -> Univ.UContext.t + +val const_univ_entry : poly:bool -> evar_map -> Entries.constant_universes_entry + +(** NB: [ind_univ_entry] cannot create cumulative entries. *) +val ind_univ_entry : poly:bool -> evar_map -> Entries.inductive_universes + +val check_univ_decl : poly:bool -> evar_map -> UState.universe_decl -> Entries.constant_universes_entry val merge_universe_context : evar_map -> UState.t -> evar_map val set_universe_context : evar_map -> UState.t -> evar_map @@ -599,11 +609,16 @@ type open_constr = evar_map * constr (* Special case when before is empty *) type unsolvability_explanation = SeveralInstancesFound of int (** Failure explanation. *) +(** {5 Summary names} *) + +(* This stuff is internal and should not be used. Currently a hack in + the STM relies on it. *) +val evar_counter_summary_tag : int Summary.Dyn.tag + (** {5 Deprecated functions} *) +val create_evar_defs : evar_map -> evar_map +(* XXX: This is supposed to be deprecated by used by ssrmatching, what + should the replacement be? *) -val create_evar_defs : evar_map -> evar_map (** Create an [evar_map] with empty meta map: *) -(** {5 Summary names} *) - -val evar_counter_summary_name : string diff --git a/engine/logic_monad.ml b/engine/logic_monad.ml index bf1b3e0e86..9dc5d473b9 100644 --- a/engine/logic_monad.ml +++ b/engine/logic_monad.ml @@ -95,7 +95,7 @@ struct let print_char = fun c -> (); fun () -> print_char c let timeout = fun n t -> (); fun () -> - Control.timeout n t (Exception Timeout) + Control.timeout n t () (Exception Timeout) let make f = (); fun () -> try f () diff --git a/library/nameops.ml b/engine/nameops.ml index d598a63b8d..5105d7becc 100644 --- a/library/nameops.ml +++ b/engine/nameops.ml @@ -203,13 +203,14 @@ let pr_name = print let pr_lab l = Label.print l -let default_library = Names.DirPath.initial (* = ["Top"] *) - -(*s Roots of the space of absolute names *) -let coq_string = "Coq" -let coq_root = Id.of_string coq_string -let default_root_prefix = DirPath.empty - (* Metavariables *) let pr_meta = Pp.int let string_of_meta = string_of_int + +(* Deprecated *) +open Libnames +let default_library = default_library +let coq_string = coq_string +let coq_root = coq_root +let default_root_prefix = default_root_prefix + diff --git a/library/nameops.mli b/engine/nameops.mli index 60e5a90bb5..0fec8a925d 100644 --- a/library/nameops.mli +++ b/engine/nameops.mli @@ -89,6 +89,10 @@ module Name : sig end +(** Metavariables *) +val pr_meta : Constr.metavariable -> Pp.t +val string_of_meta : Constr.metavariable -> string + val out_name : Name.t -> Id.t [@@ocaml.deprecated "Same as [Name.get_id]"] @@ -119,18 +123,16 @@ val pr_id : Id.t -> Pp.t val pr_lab : Label.t -> Pp.t [@@ocaml.deprecated "Same as [Names.Label.print]"] -(** some preset paths *) - +(** Deprecated stuff to libnames *) val default_library : DirPath.t +[@@ocaml.deprecated "Same as [Libnames.default_library]"] -(** This is the root of the standard library of Coq *) val coq_root : module_ident (** "Coq" *) +[@@ocaml.deprecated "Same as [Libnames.coq_root]"] + val coq_string : string (** "Coq" *) +[@@ocaml.deprecated "Same as [Libnames.coq_string]"] -(** This is the default root prefix for developments which doesn't - mention a root *) val default_root_prefix : DirPath.t +[@@ocaml.deprecated "Same as [Libnames.default_root_prefix]"] -(** Metavariables *) -val pr_meta : Constr.metavariable -> Pp.t -val string_of_meta : Constr.metavariable -> string diff --git a/engine/proofview.ml b/engine/proofview.ml index 598358c472..3b945c87f9 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -1200,7 +1200,7 @@ module V82 = struct { Evd.it = comb ; sigma = solution } let top_goals initial { solution=solution; } = - let goals = CList.map (fun (t,_) -> fst (Term.destEvar (EConstr.Unsafe.to_constr t))) initial in + let goals = CList.map (fun (t,_) -> fst (Constr.destEvar (EConstr.Unsafe.to_constr t))) initial in { Evd.it = goals ; sigma=solution; } let top_evars initial = diff --git a/engine/proofview.mli b/engine/proofview.mli index 0379d4b493..59728a2fd1 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -25,7 +25,7 @@ type proofview new nearly identical function everytime. Hence the generic name. *) (* In this version: returns the list of focused goals together with the [evar_map] context. *) -val proofview : proofview -> Evd.evar list * Evd.evar_map +val proofview : proofview -> Evar.t list * Evd.evar_map (** {6 Starting and querying a proof view} *) @@ -88,7 +88,7 @@ type focus_context new nearly identical function everytime. Hence the generic name. *) (* In this version: the goals in the context, as a "zipper" (the first list is in reversed order). *) -val focus_context : focus_context -> Evd.evar list * Evd.evar list +val focus_context : focus_context -> Evar.t list * Evar.t list (** [focus i j] focuses a proofview on the goals from index [i] to index [j] (inclusive, goals are indexed from [1]). I.e. goals @@ -148,7 +148,7 @@ type +'a tactic {!Logic_monad.TacticFailure}*) val apply : Environ.env -> 'a tactic -> proofview -> 'a * proofview - * (bool*Evd.evar list*Evd.evar list) + * (bool*Evar.t list*Evar.t list) * Proofview_monad.Info.tree (** {7 Monadic primitives} *) @@ -304,12 +304,12 @@ val shelve : unit tactic (** Shelves the given list of goals, which might include some that are under focus and some that aren't. All the goals are placed on the shelf for later use (or being solved by side-effects). *) -val shelve_goals : Evd.evar list -> unit tactic +val shelve_goals : Evar.t list -> unit tactic (** [unifiable sigma g l] checks whether [g] appears in another subgoal of [l]. The list [l] may contain [g], but it does not affect the result. Used by [shelve_unifiable]. *) -val unifiable : Evd.evar_map -> Evd.evar -> Evd.evar list -> bool +val unifiable : Evd.evar_map -> Evar.t -> Evar.t list -> bool (** Shelves the unifiable goals under focus, i.e. the goals which appear in other goals under focus (the unfocused goals are not @@ -322,15 +322,15 @@ val guard_no_unifiable : Names.Name.t list option tactic (** [unshelve l p] adds all the goals in [l] at the end of the focused goals of p *) -val unshelve : Evd.evar list -> proofview -> proofview +val unshelve : Evar.t list -> proofview -> proofview (** [depends_on g1 g2 sigma] checks if g1 occurs in the type/ctx of g2 *) -val depends_on : Evd.evar_map -> Evd.evar -> Evd.evar -> bool +val depends_on : Evd.evar_map -> Evar.t -> Evar.t -> bool (** [with_shelf tac] executes [tac] and returns its result together with the set of goals shelved by [tac]. The current shelf is unchanged and the returned list contains only unsolved goals. *) -val with_shelf : 'a tactic -> (Evd.evar list * 'a) tactic +val with_shelf : 'a tactic -> (Evar.t list * 'a) tactic (** If [n] is positive, [cycle n] puts the [n] first goal last. If [n] is negative, then it puts the [n] last goals first.*) @@ -416,14 +416,14 @@ module Unsafe : sig (** [tclNEWGOALS gls] adds the goals [gls] to the ones currently being proved, appending them to the list of focused goals. If a goal is already solved, it is not added. *) - val tclNEWGOALS : Evd.evar list -> unit tactic + val tclNEWGOALS : Evar.t list -> unit tactic (** [tclSETGOALS gls] sets goals [gls] as the goals being under focus. If a goal is already solved, it is not set. *) - val tclSETGOALS : Evd.evar list -> unit tactic + val tclSETGOALS : Evar.t list -> unit tactic (** [tclGETGOALS] returns the list of goals under focus. *) - val tclGETGOALS : Evd.evar list tactic + val tclGETGOALS : Evar.t list tactic (** Sets the evar universe context. *) val tclEVARUNIVCONTEXT : UState.t -> unit tactic @@ -563,11 +563,12 @@ module V82 : sig (* Returns the open goals of the proofview together with the evar_map to interpret them. *) val goals : proofview -> Evar.t list Evd.sigma + [@@ocaml.deprecated "Use [Proofview.proofview]"] val top_goals : entry -> proofview -> Evar.t list Evd.sigma - + (* returns the existential variable used to start the proof *) - val top_evars : entry -> Evd.evar list + val top_evars : entry -> Evar.t list (* Caution: this function loses quite a bit of information. It should be avoided as much as possible. It should work as diff --git a/engine/termops.ml b/engine/termops.ml index 46fac50f22..a71bdff31e 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -205,8 +205,7 @@ let pr_evar_source = function | Evar_kinds.MatchingVar _ -> str "matching variable" | Evar_kinds.VarInstance id -> str "instance of " ++ Id.print id | Evar_kinds.SubEvar evk -> - let open Evd in - str "subterm of " ++ str (string_of_existential evk) + str "subterm of " ++ Evar.print evk let pr_evar_info evi = let open Evd in @@ -289,6 +288,7 @@ let has_no_evar sigma = with Exit -> false let pr_evd_level evd = UState.pr_uctx_level (Evd.evar_universe_context evd) +let reference_of_level evd l = UState.reference_of_level (Evd.evar_universe_context evd) l let pr_evar_universe_context ctx = let open UState in @@ -356,7 +356,7 @@ let pr_evar_map_gen with_univs pr_evars sigma = let pr_evar_list sigma l = let open Evd in let pr (ev, evi) = - h 0 (str (string_of_existential ev) ++ + h 0 (Evar.print ev ++ str "==" ++ pr_evar_info evi ++ (if evi.evar_body == Evar_empty then str " {" ++ pr_existential_key sigma ev ++ str "}" diff --git a/engine/termops.mli b/engine/termops.mli index 793490798a..c1600abe80 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -91,7 +91,7 @@ exception Occur val occur_meta : Evd.evar_map -> constr -> bool val occur_existential : Evd.evar_map -> constr -> bool val occur_meta_or_existential : Evd.evar_map -> constr -> bool -val occur_evar : Evd.evar_map -> existential_key -> constr -> bool +val occur_evar : Evd.evar_map -> Evar.t -> constr -> bool val occur_var : env -> Evd.evar_map -> Id.t -> constr -> bool val occur_var_in_decl : env -> Evd.evar_map -> @@ -271,6 +271,8 @@ val is_Prop : Evd.evar_map -> constr -> bool val is_Set : Evd.evar_map -> constr -> bool val is_Type : Evd.evar_map -> constr -> bool +val reference_of_level : Evd.evar_map -> Univ.Level.t -> Libnames.reference + (** Combinators on judgments *) val on_judgment : ('a -> 'b) -> ('a, 'a) punsafe_judgment -> ('b, 'b) punsafe_judgment @@ -281,9 +283,9 @@ val on_judgment_type : ('t -> 't) -> ('c, 't) punsafe_judgment -> ('c, 't) puns open Evd -val pr_existential_key : evar_map -> evar -> Pp.t +val pr_existential_key : evar_map -> Evar.t -> Pp.t -val pr_evar_suggested_name : existential_key -> evar_map -> Id.t +val pr_evar_suggested_name : Evar.t -> evar_map -> Id.t val pr_evar_info : evar_info -> Pp.t val pr_evar_constraints : evar_map -> evar_constraint list -> Pp.t diff --git a/engine/uState.ml b/engine/uState.ml index dfea25dd04..6566ad989c 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -11,29 +11,18 @@ open CErrors open Util open Names -module StringOrd = struct type t = string let compare = String.compare end -module UNameMap = struct +module UNameMap = Names.Id.Map - include Map.Make(StringOrd) - - let union s t = - if s == t then s - else - merge (fun k l r -> - match l, r with - | Some _, _ -> l - | _, _ -> r) s t -end - type uinfo = { - uname : string option; + uname : Id.t option; uloc : Loc.t option; } (* 2nd part used to check consistency on the fly. *) type t = - { uctx_names : Univ.Level.t UNameMap.t * uinfo Univ.LMap.t; + { uctx_names : Universes.universe_binders * uinfo Univ.LMap.t; uctx_local : Univ.ContextSet.t; (** The local context of variables *) + uctx_seff_univs : Univ.LSet.t; (** Local universes used through private constants *) uctx_univ_variables : Universes.universe_opt_subst; (** The local universes that are unification variables *) uctx_univ_algebraic : Univ.LSet.t; @@ -46,6 +35,7 @@ type t = let empty = { uctx_names = UNameMap.empty, Univ.LMap.empty; uctx_local = Univ.ContextSet.empty; + uctx_seff_univs = Univ.LSet.empty; uctx_univ_variables = Univ.LMap.empty; uctx_univ_algebraic = Univ.LSet.empty; uctx_universes = UGraph.initial_universes; @@ -59,12 +49,21 @@ let is_empty ctx = Univ.ContextSet.is_empty ctx.uctx_local && Univ.LMap.is_empty ctx.uctx_univ_variables +let uname_union s t = + if s == t then s + else + UNameMap.merge (fun k l r -> + match l, r with + | Some _, _ -> l + | _, _ -> r) s t + let union ctx ctx' = if ctx == ctx' then ctx else if is_empty ctx' then ctx else let local = Univ.ContextSet.union ctx.uctx_local ctx'.uctx_local in - let names = UNameMap.union (fst ctx.uctx_names) (fst ctx'.uctx_names) in + let seff = Univ.LSet.union ctx.uctx_seff_univs ctx'.uctx_seff_univs in + let names = uname_union (fst ctx.uctx_names) (fst ctx'.uctx_names) in let newus = Univ.LSet.diff (Univ.ContextSet.levels ctx'.uctx_local) (Univ.ContextSet.levels ctx.uctx_local) in let newus = Univ.LSet.diff newus (Univ.LMap.domain ctx.uctx_univ_variables) in @@ -74,6 +73,7 @@ let union ctx ctx' = let names_rev = Univ.LMap.union (snd ctx.uctx_names) (snd ctx'.uctx_names) in { uctx_names = (names, names_rev); uctx_local = local; + uctx_seff_univs = seff; uctx_univ_variables = Univ.LMap.subst_union ctx.uctx_univ_variables ctx'.uctx_univ_variables; uctx_univ_algebraic = @@ -91,6 +91,17 @@ let constraints ctx = snd ctx.uctx_local let context ctx = Univ.ContextSet.to_context ctx.uctx_local +let const_univ_entry ~poly uctx = + let open Entries in + if poly then Polymorphic_const_entry (context uctx) + else Monomorphic_const_entry (context_set uctx) + +(* does not support cumulativity since you need more info *) +let ind_univ_entry ~poly uctx = + let open Entries in + if poly then Polymorphic_ind_entry (context uctx) + else Monomorphic_ind_entry (context_set uctx) + let of_context_set ctx = { empty with uctx_local = ctx } let subst ctx = ctx.uctx_univ_variables @@ -102,6 +113,9 @@ let initial_graph ctx = ctx.uctx_initial_universes let algebraics ctx = ctx.uctx_univ_algebraic let add_uctx_names ?loc s l (names, names_rev) = + if UNameMap.mem s names + then user_err ?loc ~hdr:"add_uctx_names" + Pp.(str "Universe " ++ Names.Id.print s ++ str" already bound."); (UNameMap.add s l names, Univ.LMap.add l { uname = Some s; uloc = loc } names_rev) let add_uctx_loc l loc (names, names_rev) = @@ -111,13 +125,17 @@ let add_uctx_loc l loc (names, names_rev) = let of_binders b = let ctx = empty in - let names = - List.fold_left (fun acc (id, l) -> add_uctx_names (Id.to_string id) l acc) - ctx.uctx_names b - in { ctx with uctx_names = names } + let rmap = + UNameMap.fold (fun id l rmap -> + Univ.LMap.add l { uname = Some id; uloc = None } rmap) + b Univ.LMap.empty + in + { ctx with uctx_names = b, rmap } + +let universe_binders ctx = fst ctx.uctx_names let instantiate_variable l b v = - try v := Univ.LMap.update l (Some b) !v + try v := Univ.LMap.set l (Some b) !v with Not_found -> assert false exception UniversesDiffer @@ -249,76 +267,123 @@ let constrain_variables diff ctx = in { ctx with uctx_local = (univs, local); uctx_univ_variables = vars } - -let pr_uctx_level uctx = +let reference_of_level uctx = let map, map_rev = uctx.uctx_names in fun l -> - try str (Option.get (Univ.LMap.find l map_rev).uname) + try Libnames.Ident (Loc.tag @@ Option.get (Univ.LMap.find l map_rev).uname) with Not_found | Option.IsNone -> - Universes.pr_with_global_universes l + Universes.reference_of_level l + +let pr_uctx_level uctx l = + Libnames.pr_reference (reference_of_level uctx l) 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 error_unbound_universes left uctx = + let open Univ in + let n = LSet.cardinal left in + let loc = + try + let info = + LMap.find (LSet.choose left) (snd uctx.uctx_names) in + info.uloc + with Not_found -> None + in + user_err ?loc ~hdr:"universe_context" + ((str(CString.plural n "Universe") ++ spc () ++ + LSet.pr (pr_uctx_level uctx) left ++ + spc () ++ str (CString.conjugate_verb_to_be n) ++ + str" unbound.")) + +let universe_context ~names ~extensible uctx = + let open Univ in + let levels = ContextSet.levels uctx.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 " ++ Id.print id ++ str" is not bound anymore.") - in (l :: newinst, Univ.LSet.remove l acc)) + try UNameMap.find id (fst uctx.uctx_names) + with Not_found -> assert false + in (l :: newinst, 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.")) + if not extensible && not (LSet.is_empty left) + then error_unbound_universes left uctx else - let left = Univ.ContextSet.sort_levels (Array.of_list (Univ.LSet.elements left)) in + let left = ContextSet.sort_levels (Array.of_list (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 inst = Instance.of_array inst in + let ctx = UContext.make (inst, ContextSet.constraints uctx.uctx_local) in + ctx -let check_implication uctx cstrs ctx = +let check_universe_context_set ~names ~extensible uctx = + if extensible then () + else + let open Univ in + let left = List.fold_left (fun left (loc,id) -> + let l = + try UNameMap.find id (fst uctx.uctx_names) + with Not_found -> assert false + in LSet.remove l left) + (ContextSet.levels uctx.uctx_local) names + in + if not (LSet.is_empty left) + then error_unbound_universes left uctx + +let check_implication uctx cstrs cstrs' = 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 check_mono_univ_decl uctx decl = let open Misctypes in - let pl, ctx = universe_context - ~names:decl.univdecl_instance - ~extensible:decl.univdecl_extensible_instance - uctx + let () = + let names = decl.univdecl_instance in + let extensible = decl.univdecl_extensible_instance in + check_universe_context_set ~names ~extensible uctx in if not decl.univdecl_extensible_constraints then - check_implication uctx decl.univdecl_constraints ctx; - pl, ctx + check_implication uctx + decl.univdecl_constraints + (Univ.ContextSet.constraints uctx.uctx_local); + uctx.uctx_local + +let check_univ_decl ~poly uctx decl = + let open Misctypes in + let ctx = + let names = decl.univdecl_instance in + let extensible = decl.univdecl_extensible_instance in + if poly + then Entries.Polymorphic_const_entry (universe_context ~names ~extensible uctx) + else + let () = check_universe_context_set ~names ~extensible uctx in + Entries.Monomorphic_const_entry uctx.uctx_local + in + if not decl.univdecl_extensible_constraints then + check_implication uctx + decl.univdecl_constraints + (Univ.ContextSet.constraints uctx.uctx_local); + ctx let restrict ctx vars = + let vars = Univ.LSet.union vars ctx.uctx_seff_univs in + let vars = Names.Id.Map.fold (fun na l vars -> Univ.LSet.add l vars) + (fst ctx.uctx_names) vars + in let uctx' = Univops.restrict_universe_context ctx.uctx_local vars in { ctx with uctx_local = uctx' } +let demote_seff_univs entry uctx = + let open Entries in + match entry.const_entry_universes with + | Polymorphic_const_entry _ -> uctx + | Monomorphic_const_entry (univs, _) -> + let seff = Univ.LSet.union uctx.uctx_seff_univs univs in + { uctx with uctx_seff_univs = seff } + type rigid = | UnivRigid | UnivFlexible of bool (** Is substitution by an algebraic ok? *) @@ -380,7 +445,7 @@ let emit_side_effects eff u = let new_univ_variable ?loc rigid name ({ uctx_local = ctx; uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as uctx) = - let u = Universes.new_univ_level (Global.current_dirpath ()) in + let u = Universes.new_univ_level () in let ctx' = Univ.ContextSet.add_universe u ctx in let uctx', pred = match rigid with @@ -437,6 +502,9 @@ let make_flexible_variable ctx ~algebraic u = {ctx with uctx_univ_variables = uvars'; uctx_univ_algebraic = avars'} +let make_flexible_nonalgebraic ctx = + {ctx with uctx_univ_algebraic = Univ.LSet.empty} + let is_sort_variable uctx s = match s with | Sorts.Type u -> @@ -497,7 +565,8 @@ let refresh_undefined_univ_variables uctx = let initial = declare uctx.uctx_initial_universes in let univs = declare UGraph.initial_universes in let uctx' = {uctx_names = uctx.uctx_names; - uctx_local = ctx'; + uctx_local = ctx'; + uctx_seff_univs = uctx.uctx_seff_univs; uctx_univ_variables = vars; uctx_univ_algebraic = alg; uctx_universes = univs; uctx_initial_universes = initial } in @@ -514,7 +583,8 @@ let normalize uctx = Universes.refresh_constraints uctx.uctx_initial_universes us' in { uctx_names = uctx.uctx_names; - uctx_local = us'; + uctx_local = us'; + uctx_seff_univs = uctx.uctx_seff_univs; (* not sure about this *) uctx_univ_variables = vars'; uctx_univ_algebraic = algs'; uctx_universes = universes; @@ -523,10 +593,6 @@ let normalize uctx = let universe_of_name uctx s = UNameMap.find s (fst uctx.uctx_names) -let add_universe_name uctx s l = - let names' = add_uctx_names s l uctx.uctx_names in - { uctx with uctx_names = names' } - let update_sigma_env uctx env = let univs = Environ.universes env in let eunivs = diff --git a/engine/uState.mli b/engine/uState.mli index b31e94b285..6657d6047d 100644 --- a/engine/uState.mli +++ b/engine/uState.mli @@ -32,6 +32,8 @@ val of_context_set : Univ.ContextSet.t -> t val of_binders : Universes.universe_binders -> t +val universe_binders : t -> Universes.universe_binders + (** {5 Projections} *) val context_set : t -> Univ.ContextSet.t @@ -51,36 +53,42 @@ 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. *) -val constraints : t -> Univ.constraints +val constraints : t -> Univ.Constraint.t (** Shorthand for {!context_set} composed with {!ContextSet.constraints}. *) val context : t -> Univ.UContext.t (** Shorthand for {!context_set} with {!Context_set.to_context}. *) +val const_univ_entry : poly:bool -> t -> Entries.constant_universes_entry +(** Pick from {!context} or {!context_set} based on [poly]. *) + +val ind_univ_entry : poly:bool -> t -> Entries.inductive_universes +(** Pick from {!context} or {!context_set} based on [poly]. + Cannot create cumulative entries. *) + (** {5 Constraints handling} *) -val add_constraints : t -> Univ.constraints -> t +val add_constraints : t -> Univ.Constraint.t -> t (** @raise UniversesDiffer when universes differ *) -val add_universe_constraints : t -> Universes.universe_constraints -> t +val add_universe_constraints : t -> Universes.Constraints.t -> t (** @raise UniversesDiffer when universes differ *) (** {5 Names} *) -val add_universe_name : t -> string -> Univ.Level.t -> t -(** Associate a human-readable name to a local variable. *) - -val universe_of_name : t -> string -> Univ.Level.t +val universe_of_name : t -> Id.t -> Univ.Level.t (** Retrieve the universe associated to the name. *) (** {5 Unification} *) val restrict : t -> Univ.LSet.t -> t +val demote_seff_univs : Safe_typing.private_constants Entries.definition_entry -> t -> t + type rigid = | UnivRigid | UnivFlexible of bool (** Is substitution by an algebraic ok? *) @@ -93,7 +101,7 @@ val merge : ?loc:Loc.t -> bool -> rigid -> t -> Univ.ContextSet.t -> t val merge_subst : t -> Universes.universe_opt_subst -> t val emit_side_effects : Safe_typing.private_constants -> t -> t -val new_univ_variable : ?loc:Loc.t -> rigid -> string option -> t -> t * Univ.Level.t +val new_univ_variable : ?loc:Loc.t -> rigid -> Id.t option -> t -> t * Univ.Level.t val add_global_univ : t -> Univ.Level.t -> t (** [make_flexible_variable g algebraic l] @@ -104,6 +112,11 @@ val add_global_univ : t -> Univ.Level.t -> t universe. Otherwise the variable is just made flexible. *) val make_flexible_variable : t -> algebraic:bool -> Univ.Level.t -> t +(** Turn all undefined flexible algebraic variables into simply flexible + ones. Can be used in case the variables might appear in universe instances + (typically for polymorphic program obligations). *) +val make_flexible_nonalgebraic : t -> t + val is_sort_variable : t -> Sorts.t -> Univ.Level.t option val normalize_variables : t -> Univ.universe_subst * t @@ -118,24 +131,23 @@ val refresh_undefined_univ_variables : t -> t * Univ.universe_level_subst val normalize : t -> t -(** [universe_context names extensible ctx] +type universe_decl = + (Names.Id.t Loc.located list, Univ.Constraint.t) Misctypes.gen_universe_decl - 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. +(** [check_univ_decl ctx decl] - If [extensible] is false, check that the universes of [names] are - the only local universes. + If non extensible in [decl], check that the local universes (resp. + universe constraints) in [ctx] are implied by [decl]. - 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.UContext.t + Return a [Entries.constant_universes_entry] containing the local + universes of [ctx] and their constraints. -type universe_decl = - (Names.Id.t Loc.located list, Univ.Constraint.t) Misctypes.gen_universe_decl + When polymorphic, the universes corresponding to + [decl.univdecl_instance] come first in the order defined by that + list. *) +val check_univ_decl : poly:bool -> t -> universe_decl -> Entries.constant_universes_entry -val check_univ_decl : t -> universe_decl -> Universes.universe_binders * Univ.UContext.t +val check_mono_univ_decl : t -> universe_decl -> Univ.ContextSet.t (** {5 TODO: Document me} *) @@ -144,3 +156,4 @@ val update_sigma_env : t -> Environ.env -> t (** {5 Pretty-printing} *) val pr_uctx_level : t -> Univ.Level.t -> Pp.t +val reference_of_level : t -> Univ.Level.t -> Libnames.reference diff --git a/engine/universes.ml b/engine/universes.ml index 6c1b64d742..0250295fdf 100644 --- a/engine/universes.ml +++ b/engine/universes.ml @@ -14,25 +14,99 @@ open Constr open Environ open Univ open Globnames - -let pr_with_global_universes l = - try Id.print (LMap.find l (snd (Global.global_universe_names ()))) - with Not_found -> Level.pr l +open Nametab + +let reference_of_level l = + match Level.name l with + | Some (d, n as na) -> + let qid = + try Nametab.shortest_qualid_of_universe na + with Not_found -> + let name = Id.of_string_soft (string_of_int n) in + Libnames.make_qualid d name + in Libnames.Qualid (Loc.tag @@ qid) + | None -> Libnames.Ident (Loc.tag @@ Id.of_string_soft (Level.to_string l)) + +let pr_with_global_universes l = Libnames.pr_reference (reference_of_level l) + +(** Global universe information outside the kernel, to handle + polymorphic universe names in sections that have to be discharged. *) + +let universe_map = (Summary.ref UnivIdMap.empty ~name:"global universe info" : bool Nametab.UnivIdMap.t ref) + +let add_global_universe u p = + match Level.name u with + | Some n -> universe_map := Nametab.UnivIdMap.add n p !universe_map + | None -> () + +let is_polymorphic l = + match Level.name l with + | Some n -> + (try Nametab.UnivIdMap.find n !universe_map + with Not_found -> false) + | None -> false (** Local universe names of polymorphic references *) -type universe_binders = (Id.t * Univ.Level.t) list +type universe_binders = Univ.Level.t Names.Id.Map.t + +let empty_binders = Id.Map.empty let universe_binders_table = Summary.ref Refmap.empty ~name:"universe binders" -let universe_binders_of_global ref = +let universe_binders_of_global ref : universe_binders = try let l = Refmap.find ref !universe_binders_table in l - with Not_found -> [] + with Not_found -> Names.Id.Map.empty -let register_universe_binders ref l = +let cache_ubinder (_,(ref,l)) = universe_binders_table := Refmap.add ref l !universe_binders_table +let subst_ubinder (subst,(ref,l as orig)) = + let ref' = fst (Globnames.subst_global subst ref) in + if ref == ref' then orig else ref', l + +let discharge_ubinder (_,(ref,l)) = + Some (Lib.discharge_global ref, l) + +let ubinder_obj : Globnames.global_reference * universe_binders -> Libobject.obj = + let open Libobject in + declare_object { (default_object "universe binder") with + cache_function = cache_ubinder; + load_function = (fun _ x -> cache_ubinder x); + classify_function = (fun x -> Substitute x); + subst_function = subst_ubinder; + discharge_function = discharge_ubinder; + rebuild_function = (fun x -> x); } + +let register_universe_binders ref ubinders = + let open Names in + (* Add the polymorphic (section) universes *) + let ubinders = UnivIdMap.fold (fun lvl poly ubinders -> + let qid = Nametab.shortest_qualid_of_universe lvl in + let level = Level.make (fst lvl) (snd lvl) in + if poly then Id.Map.add (snd (Libnames.repr_qualid qid)) level ubinders + else ubinders) + !universe_map ubinders + in + if not (Id.Map.is_empty ubinders) + then Lib.add_anonymous_leaf (ubinder_obj (ref,ubinders)) + +type univ_name_list = Name.t Loc.located list + +let universe_binders_with_opt_names ref levels = function + | None -> universe_binders_of_global ref + | Some udecl -> + if Int.equal(List.length levels) (List.length udecl) + then + List.fold_left2 (fun acc (_,na) lvl -> match na with + | Anonymous -> acc + | Name na -> Names.Id.Map.add na lvl acc) + empty_binders udecl levels + else + CErrors.user_err ~hdr:"universe_binders_with_opt_names" + Pp.(str "Universe instance should have length " ++ int (List.length levels)) + (* To disallow minimization to Set *) let set_minimization = ref true @@ -191,14 +265,17 @@ let eq_constr_universes_proj env m n = res, !cstrs (* Generator of levels *) -let new_univ_level, set_remote_new_univ_level = +type universe_id = DirPath.t * int + +let new_univ_id, set_remote_new_univ_id = RemoteCounter.new_counter ~name:"Universes" 0 ~incr:((+) 1) - ~build:(fun n -> Univ.Level.make (Global.current_dirpath ()) n) + ~build:(fun n -> Global.current_dirpath (), n) -let new_univ_level _ = new_univ_level () - (* Univ.Level.make db (new_univ_level ()) *) +let new_univ_level () = + let dp, id = new_univ_id () in + Univ.Level.make dp id -let fresh_level () = new_univ_level (Global.current_dirpath ()) +let fresh_level () = new_univ_level () (* TODO: remove *) let new_univ dp = Univ.Universe.make (new_univ_level dp) @@ -206,7 +283,7 @@ let new_Type dp = mkType (new_univ dp) let new_Type_sort dp = Type (new_univ dp) let fresh_universe_instance ctx = - let init _ = new_univ_level (Global.current_dirpath ()) in + let init _ = new_univ_level () in Instance.of_array (Array.init (AUContext.size ctx) init) let fresh_instance_from_context ctx = @@ -217,7 +294,7 @@ let fresh_instance_from_context ctx = let fresh_instance ctx = let ctx' = ref LSet.empty in let init _ = - let u = new_univ_level (Global.current_dirpath ()) in + let u = new_univ_level () in ctx' := LSet.add u !ctx'; u in let inst = Instance.of_array (Array.init (AUContext.size ctx) init) @@ -414,7 +491,7 @@ module LevelUnionFind = Unionfind.Make (Univ.LSet) (Univ.LMap) let add_list_map u t map = try let l = LMap.find u map in - LMap.update u (t :: l) map + LMap.set u (t :: l) map with Not_found -> LMap.add u [t] map @@ -507,7 +584,7 @@ let normalize_univ_variable_subst subst = let find l = Univ.LMap.find l !subst in let update l b = assert (match Universe.level b with Some l' -> not (Level.equal l l') | None -> true); - try subst := Univ.LMap.update l b !subst; b with Not_found -> assert false in + try subst := Univ.LMap.set l b !subst; b with Not_found -> assert false in normalize_univ_variable ~find ~update let normalize_universe_opt_subst subst = diff --git a/engine/universes.mli b/engine/universes.mli index 24613c4b91..1a98d969b4 100644 --- a/engine/universes.mli +++ b/engine/universes.mli @@ -18,23 +18,46 @@ val is_set_minimization : unit -> bool (** Universes *) val pr_with_global_universes : Level.t -> Pp.t +val reference_of_level : Level.t -> Libnames.reference + +(** Global universe information outside the kernel, to handle + polymorphic universes in sections that have to be discharged. *) +val add_global_universe : Level.t -> Decl_kinds.polymorphic -> unit + +val is_polymorphic : Level.t -> bool (** Local universe name <-> level mapping *) -type universe_binders = (Id.t * Univ.Level.t) list +type universe_binders = Univ.Level.t Names.Id.Map.t + +val empty_binders : universe_binders val register_universe_binders : Globnames.global_reference -> universe_binders -> unit val universe_binders_of_global : Globnames.global_reference -> universe_binders +type univ_name_list = Name.t Loc.located list + +(** [universe_binders_with_opt_names ref u l] + + If [l] is [Some univs] return the universe binders naming the levels of [u] by [univs] (skipping Anonymous). + May error if the lengths mismatch. + + Otherwise return [universe_binders_of_global ref]. *) +val universe_binders_with_opt_names : Globnames.global_reference -> + Univ.Level.t list -> univ_name_list option -> universe_binders + (** The global universe counter *) -val set_remote_new_univ_level : Level.t RemoteCounter.installer +type universe_id = DirPath.t * int + +val set_remote_new_univ_id : universe_id RemoteCounter.installer (** Side-effecting functions creating new universe levels. *) -val new_univ_level : DirPath.t -> Level.t -val new_univ : DirPath.t -> Universe.t -val new_Type : DirPath.t -> types -val new_Type_sort : DirPath.t -> Sorts.t +val new_univ_id : unit -> universe_id +val new_univ_level : unit -> Level.t +val new_univ : unit -> Universe.t +val new_Type : unit -> types +val new_Type_sort : unit -> Sorts.t val new_global_univ : unit -> Universe.t in_universe_context_set val new_sort_in_family : Sorts.family -> Sorts.t @@ -51,21 +74,23 @@ type universe_constraint_type = ULe | UEq | ULub type universe_constraint = Universe.t * universe_constraint_type * Universe.t module Constraints : sig include Set.S with type elt = universe_constraint - + val pr : t -> Pp.t end type universe_constraints = Constraints.t -type 'a constraint_accumulator = universe_constraints -> 'a -> 'a option -type 'a universe_constrained = 'a * universe_constraints -type 'a universe_constraint_function = 'a -> 'a -> universe_constraints -> universe_constraints +[@@ocaml.deprecated "Use Constraints.t"] + +type 'a constraint_accumulator = Constraints.t -> 'a -> 'a option +type 'a universe_constrained = 'a * Constraints.t +type 'a universe_constraint_function = 'a -> 'a -> Constraints.t -> Constraints.t val subst_univs_universe_constraints : universe_subst_fn -> - universe_constraints -> universe_constraints + Constraints.t -> Constraints.t val enforce_eq_instances_univs : bool -> Instance.t universe_constraint_function -val to_constraints : UGraph.t -> universe_constraints -> constraints +val to_constraints : UGraph.t -> Constraints.t -> Constraint.t (** [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 @@ -169,6 +194,7 @@ val constr_of_global : Globnames.global_reference -> constr (** ** DEPRECATED ** synonym of [constr_of_global] *) val constr_of_reference : Globnames.global_reference -> constr +[@@ocaml.deprecated "synonym of [constr_of_global]"] (** Returns the type of the global reference, by creating a fresh instance of polymorphic references and computing their instantiated universe context. (side-effect on the diff --git a/engine/univops.ml b/engine/univops.ml new file mode 100644 index 0000000000..df25d87252 --- /dev/null +++ b/engine/univops.ml @@ -0,0 +1,111 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Univ +open Constr + +let universes_of_constr env c = + let open Declarations in + let rec aux s c = + match kind c with + | Const (c, u) -> + begin match (Environ.lookup_constant c env).const_universes with + | Polymorphic_const _ -> + LSet.fold LSet.add (Instance.levels u) s + | Monomorphic_const (univs, _) -> + LSet.union s univs + end + | Ind ((mind,_), u) | Construct (((mind,_),_), u) -> + begin match (Environ.lookup_mind mind env).mind_universes with + | Cumulative_ind _ | Polymorphic_ind _ -> + LSet.fold LSet.add (Instance.levels u) s + | Monomorphic_ind (univs,_) -> + LSet.union s univs + end + | Sort u when not (Sorts.is_small u) -> + let u = Sorts.univ_of_sort u in + LSet.fold LSet.add (Universe.levels u) s + | _ -> Constr.fold aux s c + in aux LSet.empty c + +type graphnode = { + mutable up : constraint_type LMap.t; + mutable visited : bool +} + +let merge_types d d0 = + match d, d0 with + | _, Lt | Lt, _ -> Lt + | Le, _ | _, Le -> Le + | Eq, Eq -> Eq + +let merge_up d b up = + let find = try Some (LMap.find b up) with Not_found -> None in + match find with + | Some d0 -> + let d = merge_types d d0 in + if d == d0 then up else LMap.add b d up + | None -> LMap.add b d up + +let add_up a d b graph = + let node, graph = + try LMap.find a graph, graph + with Not_found -> + let node = { up = LMap.empty; visited = false } in + node, LMap.add a node graph + in + node.up <- merge_up d b node.up; + graph + +(* for each node transitive close until you find a non removable, discard the rest *) +let transitive_close removable graph = + let rec do_node a node = + if not node.visited + then + let keepup = + LMap.fold (fun b d keepup -> + if not (LSet.mem b removable) + then merge_up d b keepup + else + begin + match LMap.find b graph with + | bnode -> + do_node b bnode; + LMap.fold (fun k d' keepup -> + merge_up (merge_types d d') k keepup) + bnode.up keepup + | exception Not_found -> keepup + end + ) + node.up LMap.empty + in + node.up <- keepup; + node.visited <- true + in + LMap.iter do_node graph + +let restrict_universe_context (univs,csts) keep = + let removable = LSet.diff univs keep in + let (csts, rem) = + Constraint.fold (fun (a,d,b as cst) (csts, rem) -> + if LSet.mem a removable || LSet.mem b removable + then (csts, add_up a d b rem) + else (Constraint.add cst csts, rem)) + csts (Constraint.empty, LMap.empty) + in + transitive_close removable rem; + let csts = + LMap.fold (fun a node csts -> + if LSet.mem a removable + then csts + else + LMap.fold (fun b d csts -> Constraint.add (a,d,b) csts) + node.up csts) + rem csts + in + (LSet.inter univs keep, csts) diff --git a/library/univops.mli b/engine/univops.mli index 9af568bcb3..30fcc43681 100644 --- a/library/univops.mli +++ b/engine/univops.mli @@ -9,7 +9,8 @@ open Constr open Univ -(** Shrink a universe context to a restricted set of variables *) +(** The universes of monomorphic constants appear. *) +val universes_of_constr : Environ.env -> constr -> LSet.t -val universes_of_constr : constr -> LSet.t +(** Shrink a universe context to a restricted set of variables *) val restrict_universe_context : ContextSet.t -> LSet.t -> ContextSet.t diff --git a/grammar/vernacextend.mlp b/grammar/vernacextend.mlp index 874712124c..a561ea3703 100644 --- a/grammar/vernacextend.mlp +++ b/grammar/vernacextend.mlp @@ -82,7 +82,7 @@ let make_clause_classifier cg s { r_patt = pt; r_class = c; } = "classifiers. Only one classifier is called.") ^ "\n"); (make_patt pt, ploc_vala None, - <:expr< fun loc -> (Vernacexpr.VtUnknown, Vernacexpr.VtNow) >>) + <:expr< fun () -> ( CErrors.anomaly (Pp.str "No classification given for command " ^ s ) ) >>) let make_fun_clauses loc s l = let map c = @@ -136,6 +136,10 @@ EXTEND OPT "|"; l = LIST1 rule SEP "|"; "END" -> declare_command loc s c <:expr<None>> l + | "VERNAC"; "COMMAND"; "FUNCTIONAL"; "EXTEND"; s = UIDENT; c = OPT classification; + OPT "|"; l = LIST1 fun_rule SEP "|"; + "END" -> + declare_command loc s c <:expr<None>> l | "VERNAC"; nt = LIDENT ; "EXTEND"; s = UIDENT; c = OPT classification; OPT "|"; l = LIST1 rule SEP "|"; "END" -> @@ -158,18 +162,31 @@ EXTEND deprecation: [ [ "DEPRECATED" -> () ] ] ; - (* spiwack: comment-by-guessing: it seems that the isolated string (which - otherwise could have been another argument) is not passed to the - VernacExtend interpreter function to discriminate between the clauses. *) + (* spiwack: comment-by-guessing: it seems that the isolated string + (which otherwise could have been another argument) is not passed + to the VernacExtend interpreter function to discriminate between + the clauses. *) rule: [ [ "["; s = STRING; l = LIST0 args; "]"; d = OPT deprecation; c = OPT classifier; "->"; "["; e = Pcaml.expr; "]" -> let () = if s = "" then failwith "Command name is empty." in - let b = <:expr< fun loc -> $e$ >> in + let b = <:expr< fun ~{atts} ~{st} -> ( let () = $e$ in st ) >> in + { r_head = Some s; r_patt = l; r_class = c; r_branch = b; r_depr = d; } + | "[" ; "-" ; l = LIST1 args ; "]" ; + d = OPT deprecation; c = OPT classifier; "->"; "["; e = Pcaml.expr; "]" -> + let b = <:expr< fun ~{atts} ~{st} -> ( let () = $e$ in st ) >> in + { r_head = None; r_patt = l; r_class = c; r_branch = b; r_depr = d; } + ] ] + ; + fun_rule: + [ [ "["; s = STRING; l = LIST0 args; "]"; + d = OPT deprecation; c = OPT classifier; "->"; "["; e = Pcaml.expr; "]" -> + let () = if s = "" then failwith "Command name is empty." in + let b = <:expr< $e$ >> in { r_head = Some s; r_patt = l; r_class = c; r_branch = b; r_depr = d; } | "[" ; "-" ; l = LIST1 args ; "]" ; d = OPT deprecation; c = OPT classifier; "->"; "["; e = Pcaml.expr; "]" -> - let b = <:expr< fun loc -> $e$ >> in + let b = <:expr< $e$ >> in { r_head = None; r_patt = l; r_class = c; r_branch = b; r_depr = d; } ] ] ; diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index 7cbab56d44..43d7aa3635 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -217,7 +217,7 @@ let evars () = let doc = get_doc () in set_doc @@ Stm.finish ~doc; let pfts = Proof_global.give_me_the_proof () in - let { Evd.it = all_goals ; sigma = sigma } = Proof.V82.subgoals pfts in + let all_goals, _, _, _, sigma = Proof.proof pfts in let exl = Evar.Map.bindings (Evd.undefined_map sigma) in let map_evar ev = { Interface.evar_info = string_of_ppcmds (pr_evar sigma ev); } in let el = List.map map_evar exl in @@ -227,7 +227,7 @@ let evars () = let hints () = try let pfts = Proof_global.give_me_the_proof () in - let { Evd.it = all_goals ; sigma = sigma } = Proof.V82.subgoals pfts in + let all_goals, _, _, _, sigma = Proof.proof pfts in match all_goals with | [] -> None | g :: _ -> @@ -377,15 +377,8 @@ let init = match file with | None -> init_sid | Some file -> - let dir = Filename.dirname file in - let open Loadpath in let open CUnix in let doc, initial_id, _ = - let doc = get_doc () in - if not (is_in_load_paths (physical_path_of_string dir)) then begin - let pa = Pcoq.Gram.parsable (Stream.of_string (Printf.sprintf "Add LoadPath \"%s\". " dir)) in - let loc_ast = Stm.parse_sentence ~doc init_sid pa in - Stm.add false ~doc ~ontop:init_sid loc_ast - end else doc, init_sid, `NewTip in + get_doc (), init_sid, `NewTip in if Filename.check_suffix file ".v" then Stm.set_compilation_hints file; set_doc (Stm.finish ~doc); diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index 771c137344..8b78a91b5b 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -9,6 +9,7 @@ open Pp open Util open Names +open Nameops open Libnames open Constrexpr open Misctypes @@ -72,22 +73,22 @@ let rec cases_pattern_expr_eq p1 p2 = Option.equal (List.equal cases_pattern_expr_eq) a1 a2 && List.equal cases_pattern_expr_eq b1 b2 | CPatAtom(r1), CPatAtom(r2) -> - Option.equal eq_reference r1 r2 + Option.equal eq_reference r1 r2 | CPatOr a1, CPatOr a2 -> - List.equal cases_pattern_expr_eq a1 a2 + List.equal cases_pattern_expr_eq a1 a2 | CPatNotation (n1, s1, l1), CPatNotation (n2, s2, l2) -> String.equal n1 n2 && cases_pattern_notation_substitution_eq s1 s2 && List.equal cases_pattern_expr_eq l1 l2 | CPatPrim i1, CPatPrim i2 -> - prim_token_eq i1 i2 + prim_token_eq i1 i2 | CPatRecord l1, CPatRecord l2 -> - let equal (r1, e1) (r2, e2) = - eq_reference r1 r2 && cases_pattern_expr_eq e1 e2 - in - List.equal equal l1 l2 + let equal (r1, e1) (r2, e2) = + eq_reference r1 r2 && cases_pattern_expr_eq e1 e2 + in + List.equal equal l1 l2 | CPatDelimiters(s1,e1), CPatDelimiters(s2,e2) -> - String.equal s1 s2 && cases_pattern_expr_eq e1 e2 + String.equal s1 s2 && cases_pattern_expr_eq e1 e2 | _ -> false and cases_pattern_notation_substitution_eq (s1, n1) (s2, n2) = @@ -103,79 +104,79 @@ let eq_universes u1 u2 = let rec constr_expr_eq e1 e2 = if CAst.(e1.v == e2.v) then true else match CAst.(e1.v, e2.v) with - | CRef (r1,u1), CRef (r2,u2) -> eq_reference r1 r2 && eq_universes u1 u2 - | CFix(id1,fl1), CFix(id2,fl2) -> + | CRef (r1,u1), CRef (r2,u2) -> eq_reference r1 r2 && eq_universes u1 u2 + | CFix(id1,fl1), CFix(id2,fl2) -> eq_located Id.equal id1 id2 && List.equal fix_expr_eq fl1 fl2 - | CCoFix(id1,fl1), CCoFix(id2,fl2) -> + | CCoFix(id1,fl1), CCoFix(id2,fl2) -> eq_located Id.equal id1 id2 && List.equal cofix_expr_eq fl1 fl2 - | CProdN(bl1,a1), CProdN(bl2,a2) -> + | CProdN(bl1,a1), CProdN(bl2,a2) -> List.equal binder_expr_eq bl1 bl2 && constr_expr_eq a1 a2 - | CLambdaN(bl1,a1), CLambdaN(bl2,a2) -> + | CLambdaN(bl1,a1), CLambdaN(bl2,a2) -> List.equal binder_expr_eq bl1 bl2 && constr_expr_eq a1 a2 - | CLetIn((_,na1),a1,t1,b1), CLetIn((_,na2),a2,t2,b2) -> + | CLetIn((_,na1),a1,t1,b1), CLetIn((_,na2),a2,t2,b2) -> Name.equal na1 na2 && constr_expr_eq a1 a2 && Option.equal constr_expr_eq t1 t2 && constr_expr_eq b1 b2 - | CAppExpl((proj1,r1,_),al1), CAppExpl((proj2,r2,_),al2) -> + | CAppExpl((proj1,r1,_),al1), CAppExpl((proj2,r2,_),al2) -> Option.equal Int.equal proj1 proj2 && eq_reference r1 r2 && List.equal constr_expr_eq al1 al2 - | CApp((proj1,e1),al1), CApp((proj2,e2),al2) -> + | CApp((proj1,e1),al1), CApp((proj2,e2),al2) -> Option.equal Int.equal proj1 proj2 && constr_expr_eq e1 e2 && List.equal args_eq al1 al2 - | CRecord l1, CRecord l2 -> - let field_eq (r1, e1) (r2, e2) = - eq_reference r1 r2 && constr_expr_eq e1 e2 - in - List.equal field_eq l1 l2 - | CCases(_,r1,a1,brl1), CCases(_,r2,a2,brl2) -> + | CRecord l1, CRecord l2 -> + let field_eq (r1, e1) (r2, e2) = + eq_reference r1 r2 && constr_expr_eq e1 e2 + in + List.equal field_eq l1 l2 + | CCases(_,r1,a1,brl1), CCases(_,r2,a2,brl2) -> (** Don't care about the case_style *) Option.equal constr_expr_eq r1 r2 && List.equal case_expr_eq a1 a2 && List.equal branch_expr_eq brl1 brl2 - | CLetTuple (n1, (m1, e1), t1, b1), CLetTuple (n2, (m2, e2), t2, b2) -> - List.equal (eq_located Name.equal) n1 n2 && - Option.equal (eq_located Name.equal) m1 m2 && - Option.equal constr_expr_eq e1 e2 && - constr_expr_eq t1 t2 && - constr_expr_eq b1 b2 - | CIf (e1, (n1, r1), t1, f1), CIf (e2, (n2, r2), t2, f2) -> - constr_expr_eq e1 e2 && - Option.equal (eq_located Name.equal) n1 n2 && - Option.equal constr_expr_eq r1 r2 && - constr_expr_eq t1 t2 && - constr_expr_eq f1 f2 - | CHole _, CHole _ -> true - | CPatVar i1, CPatVar i2 -> - Id.equal i1 i2 - | CEvar (id1, c1), CEvar (id2, c2) -> - Id.equal id1 id2 && List.equal instance_eq c1 c2 - | CSort s1, CSort s2 -> - Miscops.glob_sort_eq s1 s2 - | CCast(a1,(CastConv b1|CastVM b1)), CCast(a2,(CastConv b2|CastVM b2)) -> - constr_expr_eq a1 a2 && + | CLetTuple (n1, (m1, e1), t1, b1), CLetTuple (n2, (m2, e2), t2, b2) -> + List.equal (eq_located Name.equal) n1 n2 && + Option.equal (eq_located Name.equal) m1 m2 && + Option.equal constr_expr_eq e1 e2 && + constr_expr_eq t1 t2 && constr_expr_eq b1 b2 - | CCast(a1,CastCoerce), CCast(a2, CastCoerce) -> - constr_expr_eq a1 a2 - | CNotation(n1, s1), CNotation(n2, s2) -> + | CIf (e1, (n1, r1), t1, f1), CIf (e2, (n2, r2), t2, f2) -> + constr_expr_eq e1 e2 && + Option.equal (eq_located Name.equal) n1 n2 && + Option.equal constr_expr_eq r1 r2 && + constr_expr_eq t1 t2 && + constr_expr_eq f1 f2 + | CHole _, CHole _ -> true + | CPatVar i1, CPatVar i2 -> + Id.equal i1 i2 + | CEvar (id1, c1), CEvar (id2, c2) -> + Id.equal id1 id2 && List.equal instance_eq c1 c2 + | CSort s1, CSort s2 -> + Miscops.glob_sort_eq s1 s2 + | CCast(t1,c1), CCast(t2,c2) -> + constr_expr_eq t1 t2 && cast_expr_eq c1 c2 + | CNotation(n1, s1), CNotation(n2, s2) -> String.equal n1 n2 && constr_notation_substitution_eq s1 s2 - | CPrim i1, CPrim i2 -> - prim_token_eq i1 i2 - | CGeneralization (bk1, ak1, e1), CGeneralization (bk2, ak2, e2) -> - binding_kind_eq bk1 bk2 && - Option.equal abstraction_kind_eq ak1 ak2 && - constr_expr_eq e1 e2 - | CDelimiters(s1,e1), CDelimiters(s2,e2) -> - String.equal s1 s2 && - constr_expr_eq e1 e2 - | _ -> false + | CPrim i1, CPrim i2 -> + prim_token_eq i1 i2 + | CGeneralization (bk1, ak1, e1), CGeneralization (bk2, ak2, e2) -> + binding_kind_eq bk1 bk2 && + Option.equal abstraction_kind_eq ak1 ak2 && + constr_expr_eq e1 e2 + | CDelimiters(s1,e1), CDelimiters(s2,e2) -> + String.equal s1 s2 && + constr_expr_eq e1 e2 + | (CRef _ | CFix _ | CCoFix _ | CProdN _ | CLambdaN _ | CLetIn _ | CAppExpl _ + | CApp _ | CRecord _ | CCases _ | CLetTuple _ | CIf _ | CHole _ + | CPatVar _ | CEvar _ | CSort _ | CCast _ | CNotation _ | CPrim _ + | CGeneralization _ | CDelimiters _), _ -> false and args_eq (a1,e1) (a2,e2) = Option.equal (eq_located explicitation_eq) e1 e2 && @@ -209,19 +210,19 @@ and cofix_expr_eq (id1,bl1,a1,b1) (id2,bl2,a2,b2) = constr_expr_eq b1 b2 and recursion_order_expr_eq r1 r2 = match r1, r2 with -| CStructRec, CStructRec -> true -| CWfRec e1, CWfRec e2 -> constr_expr_eq e1 e2 -| CMeasureRec (e1, o1), CMeasureRec (e2, o2) -> - constr_expr_eq e1 e2 && Option.equal constr_expr_eq o1 o2 -| _ -> false + | CStructRec, CStructRec -> true + | CWfRec e1, CWfRec e2 -> constr_expr_eq e1 e2 + | CMeasureRec (e1, o1), CMeasureRec (e2, o2) -> + constr_expr_eq e1 e2 && Option.equal constr_expr_eq o1 o2 + | _ -> false and local_binder_eq l1 l2 = match l1, l2 with -| CLocalDef (n1, e1, t1), CLocalDef (n2, e2, t2) -> - eq_located Name.equal n1 n2 && constr_expr_eq e1 e2 && Option.equal constr_expr_eq t1 t2 -| CLocalAssum (n1, _, e1), CLocalAssum (n2, _, e2) -> - (** Don't care about the [binder_kind] *) - List.equal (eq_located Name.equal) n1 n2 && constr_expr_eq e1 e2 -| _ -> false + | CLocalDef (n1, e1, t1), CLocalDef (n2, e2, t2) -> + eq_located Name.equal n1 n2 && constr_expr_eq e1 e2 && Option.equal constr_expr_eq t1 t2 + | CLocalAssum (n1, _, e1), CLocalAssum (n2, _, e2) -> + (** Don't care about the [binder_kind] *) + List.equal (eq_located Name.equal) n1 n2 && constr_expr_eq e1 e2 + | _ -> false and constr_notation_substitution_eq (e1, el1, bl1) (e2, el2, bl2) = List.equal constr_expr_eq e1 e2 && @@ -231,6 +232,16 @@ and constr_notation_substitution_eq (e1, el1, bl1) (e2, el2, bl2) = and instance_eq (x1,c1) (x2,c2) = Id.equal x1 x2 && constr_expr_eq c1 c2 +and cast_expr_eq c1 c2 = match c1, c2 with +| CastConv t1, CastConv t2 +| CastVM t1, CastVM t2 +| CastNative t1, CastNative t2 -> constr_expr_eq t1 t2 +| CastCoerce, CastCoerce -> true +| CastConv _, _ +| CastVM _, _ +| CastNative _, _ +| CastCoerce, _ -> false + let constr_loc c = CAst.(c.loc) let cases_pattern_expr_loc cp = CAst.(cp.loc) @@ -245,6 +256,270 @@ let local_binders_loc bll = match bll with | [] -> None | h :: l -> Loc.merge_opt (local_binder_loc h) (local_binder_loc (List.last bll)) +(** Folds and maps *) + +(* Legacy functions *) +let down_located f (_l, x) = f x +let located_fold_left f x (_l, y) = f x y + +let is_constructor id = + try Globnames.isConstructRef + (Smartlocate.global_of_extended_global + (Nametab.locate_extended (qualid_of_ident id))) + with Not_found -> false + +let rec cases_pattern_fold_names f a pt = match CAst.(pt.v) with + | CPatRecord l -> + List.fold_left (fun acc (r, cp) -> cases_pattern_fold_names f acc cp) a l + | CPatAlias (pat,id) -> f id a + | CPatOr (patl) -> + List.fold_left (cases_pattern_fold_names f) a patl + | CPatCstr (_,patl1,patl2) -> + List.fold_left (cases_pattern_fold_names f) + (Option.fold_left (List.fold_left (cases_pattern_fold_names f)) a patl1) patl2 + | CPatNotation (_,(patl,patll),patl') -> + List.fold_left (cases_pattern_fold_names f) + (List.fold_left (cases_pattern_fold_names f) a (patl@List.flatten patll)) patl' + | CPatDelimiters (_,pat) -> cases_pattern_fold_names f a pat + | CPatAtom (Some (Ident (_,id))) when not (is_constructor id) -> f id a + | CPatPrim _ | CPatAtom _ -> a + | CPatCast ({CAst.loc},_) -> + CErrors.user_err ?loc ~hdr:"cases_pattern_fold_names" + (Pp.strbrk "Casts are not supported here.") + +let ids_of_pattern = + cases_pattern_fold_names Id.Set.add Id.Set.empty + +let ids_of_pattern_list = + List.fold_left + (located_fold_left + (List.fold_left (cases_pattern_fold_names Id.Set.add))) + Id.Set.empty + +let ids_of_cases_indtype p = + cases_pattern_fold_names Id.Set.add Id.Set.empty p + +let ids_of_cases_tomatch tms = + List.fold_right + (fun (_, ona, indnal) l -> + Option.fold_right (fun t ids -> cases_pattern_fold_names Id.Set.add ids t) + indnal + (Option.fold_right (down_located (Name.fold_right Id.Set.add)) ona l)) + tms Id.Set.empty + +let rec fold_constr_expr_binders g f n acc b = function + | (nal,bk,t)::l -> + let nal = snd (List.split nal) in + let n' = List.fold_right (Name.fold_right g) nal n in + f n (fold_constr_expr_binders g f n' acc b l) t + | [] -> + f n acc b + +let rec fold_local_binders g f n acc b = function + | CLocalAssum (nal,bk,t)::l -> + let nal = snd (List.split nal) in + let n' = List.fold_right (Name.fold_right g) nal n in + f n (fold_local_binders g f n' acc b l) t + | CLocalDef ((_,na),c,t)::l -> + Option.fold_left (f n) (f n (fold_local_binders g f (Name.fold_right g na n) acc b l) c) t + | CLocalPattern (_,(pat,t))::l -> + let acc = fold_local_binders g f (cases_pattern_fold_names g n pat) acc b l in + Option.fold_left (f n) acc t + | [] -> + f n acc b + +let fold_constr_expr_with_binders g f n acc = CAst.with_val (function + | CAppExpl ((_,_,_),l) -> List.fold_left (f n) acc l + | CApp ((_,t),l) -> List.fold_left (f n) (f n acc t) (List.map fst l) + | CProdN (l,b) | CLambdaN (l,b) -> fold_constr_expr_binders g f n acc b l + | CLetIn (na,a,t,b) -> + f (Name.fold_right g (snd na) n) (Option.fold_left (f n) (f n acc a) t) b + | CCast (a,(CastConv b|CastVM b|CastNative b)) -> f n (f n acc a) b + | CCast (a,CastCoerce) -> f n acc a + | CNotation (_,(l,ll,bll)) -> + (* The following is an approximation: we don't know exactly if + an ident is binding nor to which subterms bindings apply *) + let acc = List.fold_left (f n) acc (l@List.flatten ll) in + List.fold_left (fun acc bl -> fold_local_binders g f n acc (CAst.make @@ CHole (None,IntroAnonymous,None)) bl) acc bll + | CGeneralization (_,_,c) -> f n acc c + | CDelimiters (_,a) -> f n acc a + | CHole _ | CEvar _ | CPatVar _ | CSort _ | CPrim _ | CRef _ -> + acc + | CRecord l -> List.fold_left (fun acc (id, c) -> f n acc c) acc l + | CCases (sty,rtnpo,al,bl) -> + let ids = ids_of_cases_tomatch al in + let acc = Option.fold_left (f (Id.Set.fold g ids n)) acc rtnpo in + let acc = List.fold_left (f n) acc (List.map (fun (fst,_,_) -> fst) al) in + List.fold_right (fun (loc,(patl,rhs)) acc -> + let ids = ids_of_pattern_list patl in + f (Id.Set.fold g ids n) acc rhs) bl acc + | CLetTuple (nal,(ona,po),b,c) -> + let n' = List.fold_right (down_located (Name.fold_right g)) nal n in + f (Option.fold_right (down_located (Name.fold_right g)) ona n') (f n acc b) c + | CIf (c,(ona,po),b1,b2) -> + let acc = f n (f n (f n acc b1) b2) c in + Option.fold_left + (f (Option.fold_right (down_located (Name.fold_right g)) ona n)) acc po + | CFix (_,l) -> + let n' = List.fold_right (fun ((_,id),_,_,_,_) -> g id) l n in + List.fold_right (fun (_,(_,o),lb,t,c) acc -> + fold_local_binders g f n' + (fold_local_binders g f n acc t lb) c lb) l acc + | CCoFix (_,_) -> + Feedback.msg_warning (strbrk "Capture check in multiple binders not done"); acc + ) + +let free_vars_of_constr_expr c = + let rec aux bdvars l = function + | { CAst.v = CRef (Ident (_,id),_) } -> if Id.List.mem id bdvars then l else Id.Set.add id l + | c -> fold_constr_expr_with_binders (fun a l -> a::l) aux bdvars l c + in aux [] Id.Set.empty c + +let occur_var_constr_expr id c = Id.Set.mem id (free_vars_of_constr_expr c) + +(* Used in correctness and interface *) +let map_binder g e nal = List.fold_right (down_located (Name.fold_right g)) nal e + +let map_binders f g e bl = + (* TODO: avoid variable capture in [t] by some [na] in [List.tl nal] *) + let h (e,bl) (nal,bk,t) = (map_binder g e nal,(nal,bk,f e t)::bl) in + let (e,rbl) = List.fold_left h (e,[]) bl in + (e, List.rev rbl) + +let map_local_binders f g e bl = + (* TODO: avoid variable capture in [t] by some [na] in [List.tl nal] *) + let h (e,bl) = function + CLocalAssum(nal,k,ty) -> + (map_binder g e nal, CLocalAssum(nal,k,f e ty)::bl) + | CLocalDef((loc,na),c,ty) -> + (Name.fold_right g na e, CLocalDef((loc,na),f e c,Option.map (f e) ty)::bl) + | CLocalPattern (loc,(pat,t)) -> + let ids = ids_of_pattern pat in + (Id.Set.fold g ids e, CLocalPattern (loc,(pat,Option.map (f e) t))::bl) in + let (e,rbl) = List.fold_left h (e,[]) bl in + (e, List.rev rbl) + +let map_constr_expr_with_binders g f e = CAst.map (function + | CAppExpl (r,l) -> CAppExpl (r,List.map (f e) l) + | CApp ((p,a),l) -> + CApp ((p,f e a),List.map (fun (a,i) -> (f e a,i)) l) + | CProdN (bl,b) -> + let (e,bl) = map_binders f g e bl in CProdN (bl,f e b) + | CLambdaN (bl,b) -> + let (e,bl) = map_binders f g e bl in CLambdaN (bl,f e b) + | CLetIn (na,a,t,b) -> + CLetIn (na,f e a,Option.map (f e) t,f (Name.fold_right g (snd na) e) b) + | CCast (a,c) -> CCast (f e a, Miscops.map_cast_type (f e) c) + | CNotation (n,(l,ll,bll)) -> + (* This is an approximation because we don't know what binds what *) + CNotation (n,(List.map (f e) l,List.map (List.map (f e)) ll, + List.map (fun bl -> snd (map_local_binders f g e bl)) bll)) + | CGeneralization (b,a,c) -> CGeneralization (b,a,f e c) + | CDelimiters (s,a) -> CDelimiters (s,f e a) + | CHole _ | CEvar _ | CPatVar _ | CSort _ + | CPrim _ | CRef _ as x -> x + | CRecord l -> CRecord (List.map (fun (id, c) -> (id, f e c)) l) + | CCases (sty,rtnpo,a,bl) -> + let bl = List.map (fun (loc,(patl,rhs)) -> + let ids = ids_of_pattern_list patl in + (loc,(patl,f (Id.Set.fold g ids e) rhs))) bl in + let ids = ids_of_cases_tomatch a in + let po = Option.map (f (Id.Set.fold g ids e)) rtnpo in + CCases (sty, po, List.map (fun (tm,x,y) -> f e tm,x,y) a,bl) + | CLetTuple (nal,(ona,po),b,c) -> + let e' = List.fold_right (down_located (Name.fold_right g)) nal e in + let e'' = Option.fold_right (down_located (Name.fold_right g)) ona e in + CLetTuple (nal,(ona,Option.map (f e'') po),f e b,f e' c) + | CIf (c,(ona,po),b1,b2) -> + let e' = Option.fold_right (down_located (Name.fold_right g)) ona e in + CIf (f e c,(ona,Option.map (f e') po),f e b1,f e b2) + | CFix (id,dl) -> + CFix (id,List.map (fun (id,n,bl,t,d) -> + let (e',bl') = map_local_binders f g e bl in + let t' = f e' t in + (* Note: fix names should be inserted before the arguments... *) + let e'' = List.fold_left (fun e ((_,id),_,_,_,_) -> g id e) e' dl in + let d' = f e'' d in + (id,n,bl',t',d')) dl) + | CCoFix (id,dl) -> + CCoFix (id,List.map (fun (id,bl,t,d) -> + let (e',bl') = map_local_binders f g e bl in + let t' = f e' t in + let e'' = List.fold_left (fun e ((_,id),_,_,_) -> g id e) e' dl in + let d' = f e'' d in + (id,bl',t',d')) dl) + ) + +(* Used in constrintern *) +let rec replace_vars_constr_expr l = function + | { CAst.loc; v = CRef (Ident (loc_id,id),us) } as x -> + (try CAst.make ?loc @@ CRef (Ident (loc_id,Id.Map.find id l),us) with Not_found -> x) + | c -> map_constr_expr_with_binders Id.Map.remove + replace_vars_constr_expr l c + +(* Returns the ranges of locs of the notation that are not occupied by args *) +(* and which are then occupied by proper symbols of the notation (or spaces) *) + +let locs_of_notation ?loc locs ntn = + let unloc loc = Option.cata Loc.unloc (0,0) loc in + let (bl, el) = unloc loc in + let locs = List.map unloc locs in + let rec aux pos = function + | [] -> if Int.equal pos el then [] else [(pos,el)] + | (ba,ea)::l -> if Int.equal pos ba then aux ea l else (pos,ba)::aux ea l + in aux bl (List.sort (fun l1 l2 -> fst l1 - fst l2) locs) + +let ntn_loc ?loc (args,argslist,binderslist) = + locs_of_notation ?loc + (List.map constr_loc (args@List.flatten argslist)@ + List.map local_binders_loc binderslist) + +let patntn_loc ?loc (args,argslist) = + locs_of_notation ?loc + (List.map cases_pattern_expr_loc (args@List.flatten argslist)) + +let error_invalid_pattern_notation ?loc () = + CErrors.user_err ?loc (str "Invalid notation for pattern.") + +(* Interpret the index of a recursion order annotation *) +let split_at_annot bl na = + let names = List.map snd (names_of_local_assums bl) in + match na with + | None -> + begin match names with + | [] -> CErrors.user_err (Pp.str "A fixpoint needs at least one parameter.") + | _ -> ([], bl) + end + | Some (loc, id) -> + let rec aux acc = function + | CLocalAssum (bls, k, t) as x :: rest -> + let test (_, na) = match na with + | Name id' -> Id.equal id id' + | Anonymous -> false + in + let l, r = List.split_when test bls in + begin match r with + | [] -> aux (x :: acc) rest + | _ -> + let ans = match l with + | [] -> acc + | _ -> CLocalAssum (l, k, t) :: acc + in + (List.rev ans, CLocalAssum (r, k, t) :: rest) + end + | CLocalDef ((_,na),_,_) as x :: rest -> + if Name.equal (Name id) na then + CErrors.user_err ?loc + (Id.print id ++ str" must be a proper parameter and not a local definition.") + else + aux (x :: acc) rest + | CLocalPattern (_,_) :: rest -> + Loc.raise ?loc (Stream.Error "pattern with quote not allowed after fix") + | [] -> + CErrors.user_err ?loc + (str "No parameter named " ++ Id.print id ++ str".") + in aux [] bl + (** Pseudo-constructors *) let mkIdentC id = CAst.make @@ CRef (Ident (Loc.tag id),None) @@ -265,38 +540,40 @@ let add_name_in_env env n = | Anonymous -> env | Name id -> id :: env -let (fresh_var, fresh_var_hook) = Hook.make ~default:(fun _ _ -> assert false) () +let fresh_var env c = + Namegen.next_ident_away (Id.of_string "pat") + (List.fold_left (fun accu id -> Id.Set.add id accu) (free_vars_of_constr_expr c) env) let expand_binders ?loc mkC bl c = let rec loop ?loc bl c = match bl with | [] -> ([], c) | b :: bl -> - match b with - | CLocalDef ((loc1,_) as n, oty, b) -> - let env, c = loop ?loc:(Loc.merge_opt loc1 loc) bl c in - let env = add_name_in_env env n in - (env, CAst.make ?loc @@ CLetIn (n,oty,b,c)) - | CLocalAssum ((loc1,_)::_ as nl, bk, t) -> - let env, c = loop ?loc:(Loc.merge_opt loc1 loc) bl c in - let env = List.fold_left add_name_in_env env nl in - (env, mkC ?loc (nl,bk,t) c) - | CLocalAssum ([],_,_) -> loop ?loc bl c - | CLocalPattern (loc1, (p, ty)) -> - let env, c = loop ?loc:(Loc.merge_opt loc1 loc) bl c in - let ni = Hook.get fresh_var env c in - let id = (loc1, Name ni) in - let ty = match ty with - | Some ty -> ty - | None -> CAst.make ?loc:loc1 @@ CHole (None, IntroAnonymous, None) - in - let e = CAst.make @@ CRef (Libnames.Ident (loc1, ni), None) in - let c = CAst.make ?loc @@ - CCases - (LetPatternStyle, None, [(e,None,None)], - [(Loc.tag ?loc:loc1 ([(loc1,[p])], c))]) - in - (ni :: env, mkC ?loc ([id],Default Explicit,ty) c) + match b with + | CLocalDef ((loc1,_) as n, oty, b) -> + let env, c = loop ?loc:(Loc.merge_opt loc1 loc) bl c in + let env = add_name_in_env env n in + (env, CAst.make ?loc @@ CLetIn (n,oty,b,c)) + | CLocalAssum ((loc1,_)::_ as nl, bk, t) -> + let env, c = loop ?loc:(Loc.merge_opt loc1 loc) bl c in + let env = List.fold_left add_name_in_env env nl in + (env, mkC ?loc (nl,bk,t) c) + | CLocalAssum ([],_,_) -> loop ?loc bl c + | CLocalPattern (loc1, (p, ty)) -> + let env, c = loop ?loc:(Loc.merge_opt loc1 loc) bl c in + let ni = fresh_var env c in + let id = (loc1, Name ni) in + let ty = match ty with + | Some ty -> ty + | None -> CAst.make ?loc:loc1 @@ CHole (None, IntroAnonymous, None) + in + let e = CAst.make @@ CRef (Libnames.Ident (loc1, ni), None) in + let c = CAst.make ?loc @@ + CCases + (LetPatternStyle, None, [(e,None,None)], + [(Loc.tag ?loc:loc1 ([(loc1,[p])], c))]) + in + (ni :: env, mkC ?loc ([id],Default Explicit,ty) c) in let (_, c) = loop ?loc bl c in c @@ -309,24 +586,34 @@ let mkCLambdaN ?loc bll c = let mk ?loc b c = CAst.make ?loc @@ CLambdaN ([b],c) in expand_binders ?loc mk bll c -(* Deprecated *) -let abstract_constr_expr c bl = mkCLambdaN ?loc:(local_binders_loc bl) bl c -let prod_constr_expr c bl = mkCProdN ?loc:(local_binders_loc bl) bl c - let coerce_reference_to_id = function | Ident (_,id) -> id | Qualid (loc,_) -> - CErrors.user_err ?loc ~hdr:"coerce_reference_to_id" - (str "This expression should be a simple identifier.") + CErrors.user_err ?loc ~hdr:"coerce_reference_to_id" + (str "This expression should be a simple identifier.") let coerce_to_id = function | { 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.") + ~hdr:"coerce_to_id" + (str "This expression should be a simple identifier.") let coerce_to_name = function | { 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.") + +let asymmetric_patterns = ref (false) +let _ = Goptions.declare_bool_option { + Goptions.optdepr = false; + Goptions.optname = "no parameters in constructors"; + Goptions.optkey = ["Asymmetric";"Patterns"]; + Goptions.optread = (fun () -> !asymmetric_patterns); + Goptions.optwrite = (fun a -> asymmetric_patterns:=a); +} + +(************************************************************************) +(* Deprecated *) +let abstract_constr_expr c bl = mkCLambdaN ?loc:(local_binders_loc bl) bl c +let prod_constr_expr c bl = mkCProdN ?loc:(local_binders_loc bl) bl c diff --git a/interp/constrexpr_ops.mli b/interp/constrexpr_ops.mli index 7bd275e510..3ecb3d3212 100644 --- a/interp/constrexpr_ops.mli +++ b/interp/constrexpr_ops.mli @@ -56,11 +56,11 @@ val mkCProdN : ?loc:Loc.t -> local_binder_expr list -> constr_expr -> constr_exp (** @deprecated variant of mkCLambdaN *) val abstract_constr_expr : constr_expr -> local_binder_expr list -> constr_expr +[@@ocaml.deprecated "deprecated variant of mkCLambdaN"] (** @deprecated variant of mkCProdN *) val prod_constr_expr : constr_expr -> local_binder_expr list -> constr_expr - -val fresh_var_hook : (Names.Id.t list -> Constrexpr.constr_expr -> Names.Id.t) Hook.t +[@@ocaml.deprecated "deprecated variant of mkCProdN"] (** {6 Destructors}*) @@ -83,3 +83,36 @@ val names_of_local_binders : local_binder_expr list -> Name.t located list val names_of_local_assums : local_binder_expr list -> Name.t located list (** Same as [names_of_local_binder_exprs], but does not take the [let] bindings into account. *) + +(** { 6 Folds and maps } *) + +(** Used in typeclasses *) +val fold_constr_expr_with_binders : (Id.t -> 'a -> 'a) -> + ('a -> 'b -> constr_expr -> 'b) -> 'a -> 'b -> constr_expr -> 'b + +(** Used in correctness and interface; absence of var capture not guaranteed + in pattern-matching clauses and in binders of the form [x,y:T(x)] *) + +val map_constr_expr_with_binders : + (Id.t -> 'a -> 'a) -> ('a -> constr_expr -> constr_expr) -> + 'a -> constr_expr -> constr_expr + +val replace_vars_constr_expr : + Id.t Id.Map.t -> constr_expr -> constr_expr + +(** Specific function for interning "in indtype" syntax of "match" *) +val ids_of_cases_indtype : cases_pattern_expr -> Id.Set.t + +val free_vars_of_constr_expr : constr_expr -> Id.Set.t +val occur_var_constr_expr : Id.t -> constr_expr -> bool + +val split_at_annot : local_binder_expr list -> Id.t located option -> local_binder_expr list * local_binder_expr list + +val ntn_loc : ?loc:Loc.t -> constr_notation_substitution -> string -> (int * int) list +val patntn_loc : ?loc:Loc.t -> cases_pattern_notation_substitution -> string -> (int * int) list + +(** For cases pattern parsing errors *) +val error_invalid_pattern_notation : ?loc:Loc.t -> unit -> 'a + +(** Placeholder for global option, should be moved to a parameter *) +val asymmetric_patterns : bool ref diff --git a/interp/constrextern.ml b/interp/constrextern.ml index e1cf8f196d..bc8debd02d 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -21,7 +21,6 @@ open CAst open Constrexpr open Constrexpr_ops open Notation_ops -open Topconstr open Glob_term open Glob_ops open Pattern @@ -185,18 +184,8 @@ let with_universes f = Flags.with_option print_universes f let with_meta_as_hole f = Flags.with_option print_meta_as_hole f let without_symbols f = Flags.with_option print_no_symbol f -(* XXX: Where to put this in the library? Util maybe? *) -let protect_ref r nf f x = - let old_ref = !r in - r := nf !r; - try let res = f x in r := old_ref; res - with reraise -> - let reraise = Backtrace.add_backtrace reraise in - r := old_ref; - Exninfo.iraise reraise - let without_specific_symbols l = - protect_ref inactive_notations_table + Flags.with_modified_ref inactive_notations_table (fun tbl -> IRuleSet.(union (of_list l) tbl)) (**********************************************************************) @@ -394,7 +383,7 @@ let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat = try if !Flags.in_debugger || !Flags.raw_print || !print_no_symbol then raise No_match; extern_notation_pattern scopes vars pat - (uninterp_cases_pattern_notations pat) + (uninterp_cases_pattern_notations scopes pat) with No_match -> lift (fun ?loc -> function | PatVar (Name id) -> CPatAtom (Some (Ident (loc,id))) @@ -424,7 +413,7 @@ let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat = with Not_found | No_match | Exit -> let c = extern_reference ?loc Id.Set.empty (ConstructRef cstrsp) in - if !Topconstr.asymmetric_patterns then + if !asymmetric_patterns then if pattern_printable_in_both_syntax cstrsp then CPatCstr (c, None, args) else CPatCstr (c, Some (add_patt_for_params (fst cstrsp) args), []) @@ -456,7 +445,7 @@ and apply_notation_to_pattern ?loc gr ((subst,substlist),(nb_to_drop,more_args)) List.map (extern_cases_pattern_in_scope subscope vars) c) substlist in let l2 = List.map (extern_cases_pattern_in_scope allscopes vars) more_args in - let l2' = if !Topconstr.asymmetric_patterns || not (List.is_empty ll) then l2 + let l2' = if !asymmetric_patterns || not (List.is_empty ll) then l2 else match drop_implicits_in_patt gr nb_to_drop l2 with |Some true_args -> true_args @@ -472,7 +461,7 @@ and apply_notation_to_pattern ?loc gr ((subst,substlist),(nb_to_drop,more_args)) extern_cases_pattern_in_scope (scopt,scl@scopes) vars c) subst in let l2 = List.map (extern_cases_pattern_in_scope allscopes vars) more_args in - let l2' = if !Topconstr.asymmetric_patterns then l2 + let l2' = if !asymmetric_patterns then l2 else match drop_implicits_in_patt gr (nb_to_drop + List.length l1) l2 with |Some true_args -> true_args @@ -525,7 +514,7 @@ let extern_ind_pattern_in_scope (scopes:local_scopes) vars ind args = try if !Flags.raw_print || !print_no_symbol then raise No_match; extern_notation_ind_pattern scopes vars ind args - (uninterp_ind_pattern_notations ind) + (uninterp_ind_pattern_notations scopes ind) with No_match -> let c = extern_reference vars (IndRef ind) in let args = List.map (extern_cases_pattern_in_scope scopes vars) args in @@ -745,7 +734,7 @@ let rec extern inctx scopes vars r = try let r'' = flatten_application r' in if !Flags.raw_print || !print_no_symbol then raise No_match; - extern_notation scopes vars r'' (uninterp_notations r'') + extern_notation scopes vars r'' (uninterp_notations scopes r'') with No_match -> lift (fun ?loc -> function | GRef (ref,us) -> extern_global (select_stronger_impargs (implicits_of_global ref)) diff --git a/interp/constrextern.mli b/interp/constrextern.mli index d980b1995f..51b06580e8 100644 --- a/interp/constrextern.mli +++ b/interp/constrextern.mli @@ -60,6 +60,19 @@ val set_extern_reference : val get_extern_reference : unit -> (?loc:Loc.t -> Id.Set.t -> global_reference -> reference) +(** WARNING: The following functions are evil due to + side-effects. Think of the following case as used in the printer: + + without_specific_symbols [SynDefRule kn] (pr_glob_constr_env env) c + + vs + + without_specific_symbols [SynDefRule kn] pr_glob_constr_env env c + + which one is wrong? We should turn this kind of state into an + explicit argument. +*) + (** This forces printing universe names of Type\{.\} *) val with_universes : ('a -> 'b) -> 'a -> 'b diff --git a/interp/constrintern.ml b/interp/constrintern.ml index c4e0ac500c..977146b2fe 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -24,7 +24,6 @@ open Constrexpr open Constrexpr_ops open Notation_term open Notation_ops -open Topconstr open Nametab open Notation open Inductiveops @@ -534,8 +533,9 @@ let traverse_binder (terms,_,_ as subst) avoid (renaming,env) = function | Name id -> try (* Binders bound in the notation are considered first-order objects *) - let _,na = coerce_to_name (fst (Id.Map.find id terms)) in - (renaming,{env with ids = Name.fold_right Id.Set.add na env.ids}), na + let _,na as locna = coerce_to_name (fst (Id.Map.find id terms)) in + let env = push_name_env Id.Map.empty (Variable,[],[],[]) env locna in + (renaming,env), na with Not_found -> (* Binders not bound in the notation do not capture variables *) (* outside the notation (i.e. in the substitution) *) @@ -747,7 +747,14 @@ let gvar (loc, id) us = match us with str " cannot have a universe instance") let intern_var genv (ltacvars,ntnvars) namedctx loc id us = - (* Is [id] an inductive type potentially with implicit *) + (* Is [id] a notation variable *) + if Id.Map.mem id ntnvars then + begin + if not (Id.Map.mem id genv.impls) then set_var_scope ?loc id true genv ntnvars; + gvar (loc,id) us, [], [], [] + end + else + (* Is [id] registered with implicit arguments *) try let ty,expl_impls,impls,argsc = Id.Map.find id genv.impls in let expl_impls = List.map @@ -760,12 +767,8 @@ let intern_var genv (ltacvars,ntnvars) namedctx loc id us = if Id.Set.mem id genv.ids || Id.Set.mem id ltacvars.ltac_vars then gvar (loc,id) us, [], [], [] - (* Is [id] a notation variable *) - else if Id.Map.mem id ntnvars - then - (set_var_scope ?loc id true genv ntnvars; gvar (loc,id) us, [], [], []) - (* Is [id] the special variable for recursive notations *) else if Id.equal id ldots_var + (* Is [id] the special variable for recursive notations? *) then if Id.Map.is_empty ntnvars then error_ldots_var ?loc else gvar (loc,id) us, [], [], [] diff --git a/interp/declare.ml b/interp/declare.ml index 1a589897bd..0adad14198 100644 --- a/interp/declare.ml +++ b/interp/declare.ml @@ -203,12 +203,9 @@ let declare_constant_common id cst = update_tables c; c +let default_univ_entry = Monomorphic_const_entry Univ.ContextSet.empty let definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?types - ?(poly=false) ?(univs=Univ.UContext.empty) ?(eff=Safe_typing.empty_private_constants) body = - let univs = - if poly then Polymorphic_const_entry univs - else Monomorphic_const_entry univs - in + ?(univs=default_univ_entry) ?(eff=Safe_typing.empty_private_constants) body = { const_entry_body = Future.from_val ?fix_exn ((body,Univ.ContextSet.empty), eff); const_entry_secctx = None; const_entry_type = types; @@ -261,9 +258,9 @@ let declare_constant ?(internal = UserIndividualRequest) ?(local = false) id ?(e let declare_definition ?(internal=UserIndividualRequest) ?(opaque=false) ?(kind=Decl_kinds.Definition) ?(local = false) - ?(poly=false) id ?types (body,ctx) = + id ?types (body,univs) = let cb = - definition_entry ?types ~poly ~univs:(Univ.ContextSet.to_context ctx) ~opaque body + definition_entry ?types ~univs ~opaque body in declare_constant ~internal ~local id (Entries.DefinitionEntry cb, Decl_kinds.IsDefinition kind) @@ -340,7 +337,7 @@ let dummy_inductive_entry (_,m) = ([],{ mind_entry_record = None; mind_entry_finite = Decl_kinds.BiFinite; mind_entry_inds = List.map dummy_one_inductive_entry m.mind_entry_inds; - mind_entry_universes = Monomorphic_ind_entry Univ.UContext.empty; + mind_entry_universes = Monomorphic_ind_entry Univ.ContextSet.empty; mind_entry_private = None; }) @@ -456,28 +453,95 @@ let input_universe_context : universe_context_decl -> Libobject.obj = let declare_universe_context poly ctx = Lib.add_anonymous_leaf (input_universe_context (poly, ctx)) -(* Discharged or not *) -type universe_decl = polymorphic * (Id.t * Univ.Level.t) list - -let cache_universes (p, l) = - let glob = Global.global_universe_names () in - let glob', ctx = - List.fold_left (fun ((idl,lid),ctx) (id, lev) -> - ((Id.Map.add id (p, lev) idl, - Univ.LMap.add lev id lid), - Univ.ContextSet.add_universe lev ctx)) - (glob, Univ.ContextSet.empty) l +(** Global universes are not substitutive objects but global objects + bound at the *library* or *module* level. The polymorphic flag is + used to distinguish universes declared in polymorphic sections, which + are discharged and do not remain in scope. *) + +type universe_source = + | BoundUniv (* polymorphic universe, bound in a function (this will go away someday) *) + | QualifiedUniv of Id.t (* global universe introduced by some global value *) + | UnqualifiedUniv (* other global universe *) + +type universe_decl = universe_source * Nametab.universe_id + +let add_universe src (dp, i) = + let level = Univ.Level.make dp i in + let optpoly = match src with + | BoundUniv -> Some true + | UnqualifiedUniv -> Some false + | QualifiedUniv _ -> None in - cache_universe_context (p, ctx); - Global.set_global_universe_names glob' + Option.iter (fun poly -> + let ctx = Univ.ContextSet.add_universe level Univ.ContextSet.empty in + Global.push_context_set poly ctx; + Universes.add_global_universe level poly; + if poly then Lib.add_section_context ctx) + optpoly -let input_universes : universe_decl -> Libobject.obj = +let check_exists sp = + let depth = sections_depth () in + let sp = Libnames.make_path (pop_dirpath_n depth (dirpath sp)) (basename sp) in + if Nametab.exists_universe sp then + alreadydeclared (str "Universe " ++ Id.print (basename sp) ++ str " already exists") + else () + +let qualify_univ src (sp,i as orig) = + match src with + | BoundUniv | UnqualifiedUniv -> orig + | QualifiedUniv l -> + let sp0, id = Libnames.repr_path sp in + let sp0 = DirPath.repr sp0 in + Libnames.make_path (DirPath.make (l::sp0)) id, i+1 + +let cache_universe ((sp, _), (src, id)) = + let sp, i = qualify_univ src (sp,1) in + let () = check_exists sp in + let () = Nametab.push_universe (Nametab.Until i) sp id in + add_universe src id + +let load_universe i ((sp, _), (src, id)) = + let sp, i = qualify_univ src (sp,i) in + let () = Nametab.push_universe (Nametab.Until i) sp id in + add_universe src id + +let open_universe i ((sp, _), (src, id)) = + let sp, i = qualify_univ src (sp,i) in + let () = Nametab.push_universe (Nametab.Exactly i) sp id in + () + +let discharge_universe = function + | _, (BoundUniv, _) -> None + | _, ((QualifiedUniv _ | UnqualifiedUniv), _ as x) -> Some x + +let input_universe : universe_decl -> Libobject.obj = declare_object { (default_object "Global universe name state") with - cache_function = (fun (na, pi) -> cache_universes pi); - load_function = (fun _ (_, pi) -> cache_universes pi); - discharge_function = (fun (_, (p, _ as x)) -> if p then None else Some x); - classify_function = (fun a -> Keep a) } + cache_function = cache_universe; + load_function = load_universe; + open_function = open_universe; + discharge_function = discharge_universe; + subst_function = (fun (subst, a) -> (** Actually the name is generated once and for all. *) a); + classify_function = (fun a -> Substitute a) } + +let declare_univ_binders gr pl = + if Global.is_polymorphic gr then + Universes.register_universe_binders gr pl + else + let l = match gr with + | ConstRef c -> Label.to_id @@ Constant.label c + | IndRef (c, _) -> Label.to_id @@ MutInd.label c + | VarRef id -> id + | ConstructRef _ -> + anomaly ~label:"declare_univ_binders" + Pp.(str "declare_univ_binders on an constructor reference") + in + Id.Map.iter (fun id lvl -> + match Univ.Level.name lvl with + | None -> () + | Some na -> + ignore (Lib.add_leaf id (input_universe (QualifiedUniv l, na)))) + pl let do_universe poly l = let in_section = Lib.sections_are_opened () in @@ -488,12 +552,15 @@ let do_universe poly l = in let l = List.map (fun (l, id) -> - let lev = Universes.new_univ_level (Global.current_dirpath ()) in - (id, lev)) l + let lev = Universes.new_univ_id () in + (id, lev)) l in - Lib.add_anonymous_leaf (input_universes (poly, l)) + let src = if poly then BoundUniv else UnqualifiedUniv in + List.iter (fun (id,lev) -> + ignore(Lib.add_leaf id (input_universe (src, lev)))) + l -type constraint_decl = polymorphic * Univ.constraints +type constraint_decl = polymorphic * Univ.Constraint.t let cache_constraints (na, (p, c)) = let ctx = @@ -513,20 +580,15 @@ let input_constraints : constraint_decl -> Libobject.obj = discharge_function = discharge_constraints; classify_function = (fun a -> Keep a) } +let loc_of_glob_level = function + | Misctypes.GType (Misctypes.UNamed n) -> Libnames.loc_of_reference n + | _ -> None + let do_constraint poly l = - let open Misctypes in let u_of_id x = - match x with - | GProp -> Loc.tag (false, Univ.Level.prop) - | GSet -> Loc.tag (false, Univ.Level.set) - | GType None | GType (Some (_, Anonymous)) -> - user_err ~hdr:"Constraint" - (str "Cannot declare constraints on anonymous universes") - | GType (Some (loc, Name id)) -> - let names, _ = Global.global_universe_names () in - try loc, Id.Map.find id names - with Not_found -> - user_err ?loc ~hdr:"Constraint" (str "Undeclared universe " ++ Id.print id) + let level = Pretyping.interp_known_glob_level (Evd.from_env (Global.env ())) x in + let loc = loc_of_glob_level x in + loc, Universes.is_polymorphic level, level in let in_section = Lib.sections_are_opened () in let () = @@ -544,7 +606,7 @@ let do_constraint poly l = ++ str "Polymorphic Constraint instead") in let constraints = List.fold_left (fun acc (l, d, r) -> - let ploc, (p, lu) = u_of_id l and rloc, (p', ru) = u_of_id r in + let ploc, p, lu = u_of_id l and rloc, p', ru = u_of_id r in check_poly ?loc:ploc p rloc p'; Univ.Constraint.add (lu, d, ru) acc) Univ.Constraint.empty l diff --git a/interp/declare.mli b/interp/declare.mli index 9b3194dec5..f368d164e9 100644 --- a/interp/declare.mli +++ b/interp/declare.mli @@ -42,7 +42,7 @@ type internal_flag = (* Defaut definition entries, transparent with no secctx or proj information *) val definition_entry : ?fix_exn:Future.fix_exn -> ?opaque:bool -> ?inline:bool -> ?types:types -> - ?poly:polymorphic -> ?univs:Univ.UContext.t -> + ?univs:Entries.constant_universes_entry -> ?eff:Safe_typing.private_constants -> constr -> Safe_typing.private_constants definition_entry (** [declare_constant id cd] declares a global declaration @@ -56,8 +56,8 @@ val declare_constant : val declare_definition : ?internal:internal_flag -> ?opaque:bool -> ?kind:definition_object_kind -> - ?local:bool -> ?poly:polymorphic -> Id.t -> ?types:constr -> - constr Univ.in_universe_context_set -> Constant.t + ?local:bool -> Id.t -> ?types:constr -> + constr Entries.in_constant_universes_entry -> Constant.t (** Since transparent constants' side effects are globally declared, we * need that *) @@ -80,13 +80,11 @@ val recursive_message : bool (** true = fixpoint *) -> val exists_name : Id.t -> bool - - (** Global universe contexts, names and constraints *) +val declare_univ_binders : Globnames.global_reference -> Universes.universe_binders -> unit val declare_universe_context : polymorphic -> Univ.ContextSet.t -> unit val do_universe : polymorphic -> Id.t Loc.located list -> unit -val do_constraint : polymorphic -> - (Misctypes.glob_level * Univ.constraint_type * Misctypes.glob_level) list -> - unit +val do_constraint : polymorphic -> (Misctypes.glob_level * Univ.constraint_type * Misctypes.glob_level) list -> + unit diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml index 13ed65056d..0197cf9ae2 100644 --- a/interp/dumpglob.ml +++ b/interp/dumpglob.ml @@ -72,7 +72,7 @@ open Decl_kinds let type_of_logical_kind = function | IsDefinition def -> (match def with - | Definition -> "def" + | Definition | Let -> "def" | Coercion -> "coe" | SubClass -> "subclass" | CanonicalStructure -> "canonstruc" diff --git a/interp/impargs.ml b/interp/impargs.ml index f70154e613..3105214d5e 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -10,7 +10,6 @@ open CErrors open Util open Names open Globnames -open Term open Constr open Reduction open Declarations diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index a5302b54da..519f2480ba 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -94,8 +94,8 @@ let free_vars_of_constr_expr c ?(bound=Id.Set.empty) l = let rec aux bdvars l c = match CAst.(c.v) with | CRef (Ident (loc,id),_) -> found loc id bdvars l | CNotation ("{ _ : _ | _ }", ({ CAst.v = CRef (Ident (_, id),_) } :: _, [], [])) when not (Id.Set.mem id bdvars) -> - Topconstr.fold_constr_expr_with_binders (fun a l -> Id.Set.add a l) aux (Id.Set.add id bdvars) l c - | _ -> Topconstr.fold_constr_expr_with_binders (fun a l -> Id.Set.add a l) aux bdvars l c + Constrexpr_ops.fold_constr_expr_with_binders (fun a l -> Id.Set.add a l) aux (Id.Set.add id bdvars) l c + | _ -> Constrexpr_ops.fold_constr_expr_with_binders (fun a l -> Id.Set.add a l) aux bdvars l c in aux bound l c let ids_of_names l = diff --git a/interp/interp.mllib b/interp/interp.mllib index e3500cfeac..bb22cf468d 100644 --- a/interp/interp.mllib +++ b/interp/interp.mllib @@ -1,13 +1,13 @@ Tactypes Stdarg Genintern -Constrexpr_ops Notation_ops -Ppextend Notation -Dumpglob Syntax_def Smartlocate +Constrexpr_ops +Ppextend +Dumpglob Topconstr Reserve Impargs diff --git a/interp/modintern.ml b/interp/modintern.ml index 08657936ee..3eb91d8cd7 100644 --- a/interp/modintern.ml +++ b/interp/modintern.ml @@ -62,7 +62,7 @@ let transl_with_decl env = function WithMod (fqid,lookup_module qid) | CWith_Definition ((_,fqid),c) -> let c, ectx = interp_constr env (Evd.from_env env) c in - let ctx = Evd.evar_context_universe_context ectx in + let ctx = UState.context ectx in WithDef (fqid,(c,ctx)) let loc_of_module l = l.CAst.loc diff --git a/interp/notation.ml b/interp/notation.ml index f36294f732..94ce2a6c8d 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -526,15 +526,38 @@ let interp_notation ?loc ntn local_scopes = user_err ?loc (str "Unknown interpretation for notation \"" ++ str ntn ++ str "\".") -let uninterp_notations c = - List.map_append (fun key -> keymap_find key !notations_key_table) - (glob_constr_keys c) - -let uninterp_cases_pattern_notations c = - keymap_find (cases_pattern_key c) !notations_key_table - -let uninterp_ind_pattern_notations ind = - keymap_find (RefKey (canonical_gr (IndRef ind))) !notations_key_table +let sort_notations scopes l = + let extract_scope l = function + | Scope sc -> List.partitioni (fun _i x -> + match x with + | NotationRule (Some sc',_),_,_ -> String.equal sc sc' + | _ -> false) l + | SingleNotation ntn -> List.partitioni (fun _i x -> + match x with + | NotationRule (None,ntn'),_,_ -> String.equal ntn ntn' + | _ -> false) l in + let rec aux l scopes = + if l == [] then [] (* shortcut *) else + match scopes with + | sc :: scopes -> let ntn_in_sc,l = extract_scope l sc in ntn_in_sc @ aux l scopes + | [] -> l in + aux l scopes + +let uninterp_notations scopes c = + let scopes = make_current_scopes scopes in + let keys = glob_constr_keys c in + let maps = List.map_append (fun key -> keymap_find key !notations_key_table) keys in + sort_notations scopes maps + +let uninterp_cases_pattern_notations scopes c = + let scopes = make_current_scopes scopes in + let maps = keymap_find (cases_pattern_key c) !notations_key_table in + sort_notations scopes maps + +let uninterp_ind_pattern_notations scopes ind = + let scopes = make_current_scopes scopes in + let maps = keymap_find (RefKey (canonical_gr (IndRef ind))) !notations_key_table in + sort_notations scopes maps let availability_of_notation (ntn_scope,ntn) scopes = let f scope = diff --git a/interp/notation.mli b/interp/notation.mli index 2066d346fe..7d055571c8 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -124,9 +124,9 @@ val interp_notation : ?loc:Loc.t -> notation -> local_scopes -> type notation_rule = interp_rule * interpretation * int option (** Return the possible notations for a given term *) -val uninterp_notations : 'a glob_constr_g -> notation_rule list -val uninterp_cases_pattern_notations : 'a cases_pattern_g -> notation_rule list -val uninterp_ind_pattern_notations : inductive -> notation_rule list +val uninterp_notations : local_scopes -> 'a glob_constr_g -> notation_rule list +val uninterp_cases_pattern_notations : local_scopes -> 'a cases_pattern_g -> notation_rule list +val uninterp_ind_pattern_notations : local_scopes -> inductive -> notation_rule list (** Test if a notation is available in the scopes context [scopes]; if available, the result is not None; the first diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index 0344dda970..20492e38c8 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -980,6 +980,19 @@ let match_termlist match_fun alp metas sigma rest x y iter termin lassoc = else bind_termlist_env alp sigma x l +let match_cast match_fun sigma c1 c2 = + match c1, c2 with + | CastConv t1, CastConv t2 + | CastVM t1, CastVM t2 + | CastNative t1, CastNative t2 -> + match_fun sigma t1 t2 + | CastCoerce, CastCoerce -> + sigma + | CastConv _, _ + | CastVM _, _ + | CastNative _, _ + | CastCoerce, _ -> raise No_match + let does_not_come_from_already_eta_expanded_var glob = (* This is hack to avoid looping on a rule with rhs of the form *) (* "?f (fun ?x => ?g)" since otherwise, matching "F H" expands in *) @@ -1125,11 +1138,8 @@ let rec match_ inner u alp metas sigma a1 a2 = let alp,sigma = Array.fold_right2 (fun id1 id2 alsig -> match_names metas alsig (Name id1) (Name id2)) idl1 idl2 (alp,sigma) in Array.fold_left2 (match_in u alp metas) sigma bl1 bl2 - | GCast(c1,CastConv t1), NCast (c2,CastConv t2) - | GCast(c1,CastVM t1), NCast (c2,CastVM t2) -> - match_in u alp metas (match_in u alp metas sigma c1 c2) t1 t2 - | GCast(c1, CastCoerce), NCast(c2, CastCoerce) -> - match_in u alp metas sigma c1 c2 + | GCast(t1, c1), NCast(t2, c2) -> + match_cast (match_in u alp metas) (match_in u alp metas sigma t1 t2) c1 c2 | GSort (GType _), NSort (GType _) when not u -> sigma | GSort s1, NSort s2 when Miscops.glob_sort_eq s1 s2 -> sigma | GPatVar _, NHole _ -> (*Don't hide Metas, they bind in ltac*) raise No_match @@ -1157,8 +1167,9 @@ let rec match_ inner u alp metas sigma a1 a2 = match_names metas (alp,sigma) (Name id') na in match_in u alp metas sigma (mkGApp a1 (DAst.make @@ GVar id')) b2 - | (GRec _ | GEvar _), _ - | _,_ -> raise No_match + | (GRef _ | GVar _ | GEvar _ | GPatVar _ | GApp _ | GLambda _ | GProd _ + | GLetIn _ | GCases _ | GLetTuple _ | GIf _ | GRec _ | GSort _ | GHole _ + | GCast _), _ -> raise No_match and match_in u = match_ true u diff --git a/interp/reserve.ml b/interp/reserve.ml index 6fd1d0b581..22c5a2f5e5 100644 --- a/interp/reserve.ml +++ b/interp/reserve.ml @@ -102,7 +102,7 @@ let declare_reserved_type idl t = let find_reserved_type id = Id.Map.find (root_of_id id) !reserve_table let constr_key c = - try RefKey (canonical_gr (global_of_constr (fst (Term.decompose_app c)))) + try RefKey (canonical_gr (global_of_constr (fst (Constr.decompose_app c)))) with Not_found -> Oth let revert_reserved_type t = diff --git a/interp/topconstr.ml b/interp/topconstr.ml index c64d3aa266..ecfb766ff4 100644 --- a/interp/topconstr.ml +++ b/interp/topconstr.ml @@ -6,294 +6,16 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i*) -open Pp -open CErrors -open Util -open Names -open Nameops -open Libnames -open Misctypes -open Constrexpr open Constrexpr_ops -(*i*) - -let asymmetric_patterns = ref (false) -let _ = Goptions.declare_bool_option { - Goptions.optdepr = false; - Goptions.optname = "no parameters in constructors"; - Goptions.optkey = ["Asymmetric";"Patterns"]; - Goptions.optread = (fun () -> !asymmetric_patterns); - Goptions.optwrite = (fun a -> asymmetric_patterns:=a); -} - -(**********************************************************************) -(* Miscellaneous *) - -let error_invalid_pattern_notation ?loc () = - user_err ?loc (str "Invalid notation for pattern.") - -(* Legacy functions *) -let down_located f (_l, x) = f x -let located_fold_left f x (_l, y) = f x y - -(**********************************************************************) -(* Functions on constr_expr *) - -let is_constructor id = - try Globnames.isConstructRef - (Smartlocate.global_of_extended_global - (Nametab.locate_extended (qualid_of_ident id))) - with Not_found -> false - -let rec cases_pattern_fold_names f a pt = match CAst.(pt.v) with - | CPatRecord l -> - List.fold_left (fun acc (r, cp) -> cases_pattern_fold_names f acc cp) a l - | CPatAlias (pat,id) -> f id a - | CPatOr (patl) -> - List.fold_left (cases_pattern_fold_names f) a patl - | CPatCstr (_,patl1,patl2) -> - List.fold_left (cases_pattern_fold_names f) - (Option.fold_left (List.fold_left (cases_pattern_fold_names f)) a patl1) patl2 - | CPatNotation (_,(patl,patll),patl') -> - List.fold_left (cases_pattern_fold_names f) - (List.fold_left (cases_pattern_fold_names f) a (patl@List.flatten patll)) patl' - | CPatDelimiters (_,pat) -> cases_pattern_fold_names f a pat - | CPatAtom (Some (Ident (_,id))) when not (is_constructor id) -> f id a - | CPatPrim _ | CPatAtom _ -> a - | CPatCast ({CAst.loc},_) -> - CErrors.user_err ?loc ~hdr:"cases_pattern_fold_names" - (Pp.strbrk "Casts are not supported here.") - -let ids_of_pattern = - cases_pattern_fold_names Id.Set.add Id.Set.empty - -let ids_of_pattern_list = - List.fold_left - (located_fold_left - (List.fold_left (cases_pattern_fold_names Id.Set.add))) - Id.Set.empty - -let ids_of_cases_indtype p = - cases_pattern_fold_names Id.Set.add Id.Set.empty p - -let ids_of_cases_tomatch tms = - List.fold_right - (fun (_, ona, indnal) l -> - Option.fold_right (fun t ids -> cases_pattern_fold_names Id.Set.add ids t) - indnal - (Option.fold_right (down_located (Name.fold_right Id.Set.add)) ona l)) - tms Id.Set.empty - -let rec fold_constr_expr_binders g f n acc b = function - | (nal,bk,t)::l -> - let nal = snd (List.split nal) in - let n' = List.fold_right (Name.fold_right g) nal n in - f n (fold_constr_expr_binders g f n' acc b l) t - | [] -> - f n acc b - -let rec fold_local_binders g f n acc b = function - | CLocalAssum (nal,bk,t)::l -> - let nal = snd (List.split nal) in - let n' = List.fold_right (Name.fold_right g) nal n in - f n (fold_local_binders g f n' acc b l) t - | CLocalDef ((_,na),c,t)::l -> - Option.fold_left (f n) (f n (fold_local_binders g f (Name.fold_right g na n) acc b l) c) t - | CLocalPattern (_,(pat,t))::l -> - let acc = fold_local_binders g f (cases_pattern_fold_names g n pat) acc b l in - Option.fold_left (f n) acc t - | [] -> - f n acc b - -let fold_constr_expr_with_binders g f n acc = CAst.with_val (function - | CAppExpl ((_,_,_),l) -> List.fold_left (f n) acc l - | CApp ((_,t),l) -> List.fold_left (f n) (f n acc t) (List.map fst l) - | CProdN (l,b) | CLambdaN (l,b) -> fold_constr_expr_binders g f n acc b l - | CLetIn (na,a,t,b) -> - f (Name.fold_right g (snd na) n) (Option.fold_left (f n) (f n acc a) t) b - | CCast (a,(CastConv b|CastVM b|CastNative b)) -> f n (f n acc a) b - | CCast (a,CastCoerce) -> f n acc a - | CNotation (_,(l,ll,bll)) -> - (* The following is an approximation: we don't know exactly if - an ident is binding nor to which subterms bindings apply *) - let acc = List.fold_left (f n) acc (l@List.flatten ll) in - List.fold_left (fun acc bl -> fold_local_binders g f n acc (CAst.make @@ CHole (None,IntroAnonymous,None)) bl) acc bll - | CGeneralization (_,_,c) -> f n acc c - | CDelimiters (_,a) -> f n acc a - | CHole _ | CEvar _ | CPatVar _ | CSort _ | CPrim _ | CRef _ -> - acc - | CRecord l -> List.fold_left (fun acc (id, c) -> f n acc c) acc l - | CCases (sty,rtnpo,al,bl) -> - let ids = ids_of_cases_tomatch al in - let acc = Option.fold_left (f (Id.Set.fold g ids n)) acc rtnpo in - let acc = List.fold_left (f n) acc (List.map (fun (fst,_,_) -> fst) al) in - List.fold_right (fun (loc,(patl,rhs)) acc -> - let ids = ids_of_pattern_list patl in - f (Id.Set.fold g ids n) acc rhs) bl acc - | CLetTuple (nal,(ona,po),b,c) -> - let n' = List.fold_right (down_located (Name.fold_right g)) nal n in - f (Option.fold_right (down_located (Name.fold_right g)) ona n') (f n acc b) c - | CIf (c,(ona,po),b1,b2) -> - let acc = f n (f n (f n acc b1) b2) c in - Option.fold_left - (f (Option.fold_right (down_located (Name.fold_right g)) ona n)) acc po - | CFix (_,l) -> - let n' = List.fold_right (fun ((_,id),_,_,_,_) -> g id) l n in - List.fold_right (fun (_,(_,o),lb,t,c) acc -> - fold_local_binders g f n' - (fold_local_binders g f n acc t lb) c lb) l acc - | CCoFix (_,_) -> - Feedback.msg_warning (strbrk "Capture check in multiple binders not done"); acc - ) - -let free_vars_of_constr_expr c = - let rec aux bdvars l = function - | { CAst.v = CRef (Ident (_,id),_) } -> if Id.List.mem id bdvars then l else Id.Set.add id l - | c -> fold_constr_expr_with_binders (fun a l -> a::l) aux bdvars l c - in aux [] Id.Set.empty c - -let occur_var_constr_expr id c = Id.Set.mem id (free_vars_of_constr_expr c) - -(* Interpret the index of a recursion order annotation *) - -let split_at_annot bl na = - let names = List.map snd (names_of_local_assums bl) in - match na with - | None -> - begin match names with - | [] -> user_err (Pp.str "A fixpoint needs at least one parameter.") - | _ -> ([], bl) - end - | Some (loc, id) -> - let rec aux acc = function - | CLocalAssum (bls, k, t) as x :: rest -> - let test (_, na) = match na with - | Name id' -> Id.equal id id' - | Anonymous -> false - in - let l, r = List.split_when test bls in - begin match r with - | [] -> aux (x :: acc) rest - | _ -> - let ans = match l with - | [] -> acc - | _ -> CLocalAssum (l, k, t) :: acc - in - (List.rev ans, CLocalAssum (r, k, t) :: rest) - end - | CLocalDef ((_,na),_,_) as x :: rest -> - if Name.equal (Name id) na then - user_err ?loc - (Id.print id ++ str" must be a proper parameter and not a local definition.") - else - aux (x :: acc) rest - | CLocalPattern (_,_) :: rest -> - Loc.raise ?loc (Stream.Error "pattern with quote not allowed after fix") - | [] -> - user_err ?loc - (str "No parameter named " ++ Id.print id ++ str".") - in aux [] bl - -(* Used in correctness and interface *) - -let map_binder g e nal = List.fold_right (down_located (Name.fold_right g)) nal e - -let map_binders f g e bl = - (* TODO: avoid variable capture in [t] by some [na] in [List.tl nal] *) - let h (e,bl) (nal,bk,t) = (map_binder g e nal,(nal,bk,f e t)::bl) in - let (e,rbl) = List.fold_left h (e,[]) bl in - (e, List.rev rbl) - -let map_local_binders f g e bl = - (* TODO: avoid variable capture in [t] by some [na] in [List.tl nal] *) - let h (e,bl) = function - CLocalAssum(nal,k,ty) -> - (map_binder g e nal, CLocalAssum(nal,k,f e ty)::bl) - | CLocalDef((loc,na),c,ty) -> - (Name.fold_right g na e, CLocalDef((loc,na),f e c,Option.map (f e) ty)::bl) - | CLocalPattern (loc,(pat,t)) -> - let ids = ids_of_pattern pat in - (Id.Set.fold g ids e, CLocalPattern (loc,(pat,Option.map (f e) t))::bl) in - let (e,rbl) = List.fold_left h (e,[]) bl in - (e, List.rev rbl) - -let map_constr_expr_with_binders g f e = CAst.map (function - | CAppExpl (r,l) -> CAppExpl (r,List.map (f e) l) - | CApp ((p,a),l) -> - CApp ((p,f e a),List.map (fun (a,i) -> (f e a,i)) l) - | CProdN (bl,b) -> - let (e,bl) = map_binders f g e bl in CProdN (bl,f e b) - | CLambdaN (bl,b) -> - let (e,bl) = map_binders f g e bl in CLambdaN (bl,f e b) - | CLetIn (na,a,t,b) -> - CLetIn (na,f e a,Option.map (f e) t,f (Name.fold_right g (snd na) e) b) - | CCast (a,c) -> CCast (f e a, Miscops.map_cast_type (f e) c) - | CNotation (n,(l,ll,bll)) -> - (* This is an approximation because we don't know what binds what *) - CNotation (n,(List.map (f e) l,List.map (List.map (f e)) ll, - List.map (fun bl -> snd (map_local_binders f g e bl)) bll)) - | CGeneralization (b,a,c) -> CGeneralization (b,a,f e c) - | CDelimiters (s,a) -> CDelimiters (s,f e a) - | CHole _ | CEvar _ | CPatVar _ | CSort _ - | CPrim _ | CRef _ as x -> x - | CRecord l -> CRecord (List.map (fun (id, c) -> (id, f e c)) l) - | CCases (sty,rtnpo,a,bl) -> - let bl = List.map (fun (loc,(patl,rhs)) -> - let ids = ids_of_pattern_list patl in - (loc,(patl,f (Id.Set.fold g ids e) rhs))) bl in - let ids = ids_of_cases_tomatch a in - let po = Option.map (f (Id.Set.fold g ids e)) rtnpo in - CCases (sty, po, List.map (fun (tm,x,y) -> f e tm,x,y) a,bl) - | CLetTuple (nal,(ona,po),b,c) -> - let e' = List.fold_right (down_located (Name.fold_right g)) nal e in - let e'' = Option.fold_right (down_located (Name.fold_right g)) ona e in - CLetTuple (nal,(ona,Option.map (f e'') po),f e b,f e' c) - | CIf (c,(ona,po),b1,b2) -> - let e' = Option.fold_right (down_located (Name.fold_right g)) ona e in - CIf (f e c,(ona,Option.map (f e') po),f e b1,f e b2) - | CFix (id,dl) -> - CFix (id,List.map (fun (id,n,bl,t,d) -> - let (e',bl') = map_local_binders f g e bl in - let t' = f e' t in - (* Note: fix names should be inserted before the arguments... *) - let e'' = List.fold_left (fun e ((_,id),_,_,_,_) -> g id e) e' dl in - let d' = f e'' d in - (id,n,bl',t',d')) dl) - | CCoFix (id,dl) -> - CCoFix (id,List.map (fun (id,bl,t,d) -> - let (e',bl') = map_local_binders f g e bl in - let t' = f e' t in - let e'' = List.fold_left (fun e ((_,id),_,_,_) -> g id e) e' dl in - let d' = f e'' d in - (id,bl',t',d')) dl) - ) - -(* Used in constrintern *) -let rec replace_vars_constr_expr l = function - | { CAst.loc; v = CRef (Ident (loc_id,id),us) } as x -> - (try CAst.make ?loc @@ CRef (Ident (loc_id,Id.Map.find id l),us) with Not_found -> x) - | c -> map_constr_expr_with_binders Id.Map.remove - replace_vars_constr_expr l c - -(* Returns the ranges of locs of the notation that are not occupied by args *) -(* and which are then occupied by proper symbols of the notation (or spaces) *) - -let locs_of_notation ?loc locs ntn = - let unloc loc = Option.cata Loc.unloc (0,0) loc in - let (bl, el) = unloc loc in - let locs = List.map unloc locs in - let rec aux pos = function - | [] -> if Int.equal pos el then [] else [(pos,el)] - | (ba,ea)::l -> if Int.equal pos ba then aux ea l else (pos,ba)::aux ea l - in aux bl (List.sort (fun l1 l2 -> fst l1 - fst l2) locs) - -let ntn_loc ?loc (args,argslist,binderslist) = - locs_of_notation ?loc - (List.map constr_loc (args@List.flatten argslist)@ - List.map local_binders_loc binderslist) - -let patntn_loc ?loc (args,argslist) = - locs_of_notation ?loc - (List.map cases_pattern_expr_loc (args@List.flatten argslist)) +let asymmetric_patterns = asymmetric_patterns +let error_invalid_pattern_notation = error_invalid_pattern_notation +let split_at_annot = split_at_annot +let ntn_loc = ntn_loc +let patntn_loc = patntn_loc +let map_constr_expr_with_binders = map_constr_expr_with_binders +let fold_constr_expr_with_binders = fold_constr_expr_with_binders +let ids_of_cases_indtype = ids_of_cases_indtype +let occur_var_constr_expr = occur_var_constr_expr +let free_vars_of_constr_expr = free_vars_of_constr_expr +let replace_vars_constr_expr = replace_vars_constr_expr diff --git a/interp/topconstr.mli b/interp/topconstr.mli index 922f879558..9fc02461e0 100644 --- a/interp/topconstr.mli +++ b/interp/topconstr.mli @@ -10,40 +10,43 @@ open Loc open Names open Constrexpr -(** Topconstr *) - +(** Topconstr: This whole module is deprecated in favor of Constrexpr_ops *) val asymmetric_patterns : bool ref +[@@ocaml.deprecated "use Constrexpr_ops.asymmetric_patterns"] (** Utilities on constr_expr *) +val split_at_annot : local_binder_expr list -> Id.t located option -> local_binder_expr list * local_binder_expr list +[@@ocaml.deprecated "use Constrexpr_ops.split_at_annot"] + +val ntn_loc : ?loc:Loc.t -> constr_notation_substitution -> string -> (int * int) list +[@@ocaml.deprecated "use Constrexpr_ops.ntn_loc"] +val patntn_loc : ?loc:Loc.t -> cases_pattern_notation_substitution -> string -> (int * int) list +[@@ocaml.deprecated "use Constrexpr_ops.patntn_loc"] + +(** For cases pattern parsing errors *) +val error_invalid_pattern_notation : ?loc:Loc.t -> unit -> 'a +[@@ocaml.deprecated "use Constrexpr_ops.error_invalid_pattern_notation"] -val replace_vars_constr_expr : - Id.t Id.Map.t -> constr_expr -> constr_expr +(*************************************************************************) +val replace_vars_constr_expr : Id.t Id.Map.t -> constr_expr -> constr_expr +[@@ocaml.deprecated "use Constrexpr_ops.free_vars_of_constr_expr"] val free_vars_of_constr_expr : constr_expr -> Id.Set.t +[@@ocaml.deprecated "use Constrexpr_ops.free_vars_of_constr_expr"] + val occur_var_constr_expr : Id.t -> constr_expr -> bool +[@@ocaml.deprecated "use Constrexpr_ops.occur_var_constr_expr"] (** Specific function for interning "in indtype" syntax of "match" *) val ids_of_cases_indtype : cases_pattern_expr -> Id.Set.t - -val split_at_annot : local_binder_expr list -> Id.t located option -> local_binder_expr list * local_binder_expr list +[@@ocaml.deprecated "use Constrexpr_ops.ids_of_cases_indtype"] (** Used in typeclasses *) - val fold_constr_expr_with_binders : (Id.t -> 'a -> 'a) -> ('a -> 'b -> constr_expr -> 'b) -> 'a -> 'b -> constr_expr -> 'b - -(** Used in correctness and interface; absence of var capture not guaranteed - in pattern-matching clauses and in binders of the form [x,y:T(x)] *) +[@@ocaml.deprecated "use Constrexpr_ops.fold_constr_expr_with_binders"] val map_constr_expr_with_binders : (Id.t -> 'a -> 'a) -> ('a -> constr_expr -> constr_expr) -> 'a -> constr_expr -> constr_expr - -val ntn_loc : - ?loc:Loc.t -> constr_notation_substitution -> string -> (int * int) list -val patntn_loc : - ?loc:Loc.t -> cases_pattern_notation_substitution -> string -> (int * int) list - -(** For cases pattern parsing errors *) - -val error_invalid_pattern_notation : ?loc:Loc.t -> unit -> 'a +[@@ocaml.deprecated "use Constrexpr_ops.map_constr_expr_with_binders"] diff --git a/intf/decl_kinds.ml b/intf/decl_kinds.ml index a977588332..b0c1f66613 100644 --- a/intf/decl_kinds.ml +++ b/intf/decl_kinds.ml @@ -8,6 +8,8 @@ (** Informal mathematical status of declarations *) +type discharge = DoDischarge | NoDischarge + type locality = Discharge | Local | Global type binding_kind = Explicit | Implicit @@ -40,6 +42,7 @@ type definition_object_kind = | IdentityCoercion | Instance | Method + | Let type assumption_object_kind = Definitional | Logical | Conjectural @@ -72,7 +75,8 @@ type logical_kind = (** Recursive power of type declarations *) -type recursivity_kind = +type recursivity_kind = Declarations.recursivity_kind = | Finite (** = inductive *) | CoFinite (** = coinductive *) | BiFinite (** = non-recursive, like in "Record" definitions *) +[@@ocaml.deprecated "Please use [Declarations.recursivity_kind"] diff --git a/intf/evar_kinds.ml b/intf/evar_kinds.ml index 36c421c6ca..428d6b6785 100644 --- a/intf/evar_kinds.ml +++ b/intf/evar_kinds.ml @@ -32,4 +32,4 @@ type t = | ImpossibleCase | MatchingVar of matching_var_kind | VarInstance of Id.t - | SubEvar of Constr.existential_key + | SubEvar of Evar.t diff --git a/intf/misctypes.ml b/intf/misctypes.ml index 87484ccd50..33e961419d 100644 --- a/intf/misctypes.ml +++ b/intf/misctypes.ml @@ -48,13 +48,19 @@ type 'a glob_sort_gen = | GProp (** representation of [Prop] literal *) | GSet (** representation of [Set] literal *) | GType of 'a (** representation of [Type] literal *) -type sort_info = Name.t Loc.located list -type level_info = Name.t Loc.located option -type glob_sort = sort_info glob_sort_gen +type 'a universe_kind = + | UAnonymous + | UUnknown + | UNamed of 'a + +type level_info = Libnames.reference universe_kind type glob_level = level_info glob_sort_gen type glob_constraint = glob_level * Univ.constraint_type * glob_level +type sort_info = (Libnames.reference * int) option list +type glob_sort = sort_info glob_sort_gen + (** A synonym of [Evar.t], also defined in Term *) type existential_key = Evar.t diff --git a/intf/vernacexpr.ml b/intf/vernacexpr.ml index 9aef4b1312..c7a9db1cbc 100644 --- a/intf/vernacexpr.ml +++ b/intf/vernacexpr.ml @@ -40,6 +40,8 @@ type goal_reference = | NthGoal of int | GoalId of Id.t +type univ_name_list = Name.t Loc.located list + type printable = | PrintTables | PrintFullContext @@ -54,7 +56,7 @@ type printable = | PrintMLLoadPath | PrintMLModules | PrintDebugGC - | PrintName of reference or_by_notation + | PrintName of reference or_by_notation * univ_name_list option | PrintGraph | PrintClasses | PrintTypeClasses @@ -70,7 +72,7 @@ type printable = | PrintScopes | PrintScope of string | PrintVisibility of string option - | PrintAbout of reference or_by_notation * goal_selector option + | PrintAbout of reference or_by_notation * univ_name_list option * goal_selector option | PrintImplicit of reference or_by_notation | PrintAssumptions of bool * bool * reference or_by_notation | PrintStrategy of reference or_by_notation option @@ -143,16 +145,12 @@ type coercion_flag = bool (* true = AddCoercion false = NoCoercion *) type instance_flag = bool option (* Some true = Backward instance; Some false = Forward instance, None = NoInstance *) type export_flag = bool (* true = Export; false = Import *) -type inductive_flag = Decl_kinds.recursivity_kind +type inductive_flag = Declarations.recursivity_kind type onlyparsing_flag = Flags.compat_version option (* Some v = Parse only; None = Print also. If v<>Current, it contains the name of the coq version which this notation is trying to be compatible with *) type locality_flag = bool (* true = Local *) -type obsolete_locality = bool -(* Some grammar entries use obsolete_locality. This bool is to be backward - * compatible. If the grammar is fixed removing deprecated syntax, this - * bool should go away too *) type option_value = Goptions.option_value = | BoolValue of bool @@ -325,31 +323,27 @@ type vernac_expr = | VernacFail of vernac_expr (* Syntax *) - | VernacSyntaxExtension of - bool * obsolete_locality * (lstring * syntax_modifier list) - | VernacOpenCloseScope of obsolete_locality * (bool * scope_name) + | VernacSyntaxExtension of bool * (lstring * syntax_modifier list) + | VernacOpenCloseScope of bool * scope_name | VernacDelimiters of scope_name * string option | VernacBindScope of scope_name * class_rawexpr list - | VernacInfix of obsolete_locality * (lstring * syntax_modifier list) * + | VernacInfix of (lstring * syntax_modifier list) * constr_expr * scope_name option | VernacNotation of - obsolete_locality * constr_expr * (lstring * syntax_modifier list) * + constr_expr * (lstring * syntax_modifier list) * scope_name option | VernacNotationAddFormat of string * string * string (* Gallina *) - | VernacDefinition of - (locality option * definition_object_kind) * ident_decl * definition_expr + | VernacDefinition of (discharge * 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) * + | VernacAssumption of (discharge * assumption_object_kind) * 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 - | VernacCoFixpoint of - locality option * (cofixpoint_expr * decl_notation list) list + | VernacFixpoint of discharge * (fixpoint_expr * decl_notation list) list + | VernacCoFixpoint of discharge * (cofixpoint_expr * decl_notation list) list | VernacScheme of (lident option * scheme) list | VernacCombinedScheme of lident * lident list | VernacUniverse of lident list @@ -362,10 +356,9 @@ type vernac_expr = reference option * export_flag option * reference list | VernacImport of export_flag * reference list | VernacCanonical of reference or_by_notation - | VernacCoercion of obsolete_locality * reference or_by_notation * - class_rawexpr * class_rawexpr - | VernacIdentityCoercion of obsolete_locality * lident * + | VernacCoercion of reference or_by_notation * class_rawexpr * class_rawexpr + | VernacIdentityCoercion of lident * class_rawexpr * class_rawexpr | VernacNameSectionHypSet of lident * section_subset_expr (* Type classes *) @@ -416,9 +409,9 @@ type vernac_expr = (* Commands *) | VernacCreateHintDb of string * bool | VernacRemoveHints of string list * reference list - | VernacHints of obsolete_locality * string list * hints_expr + | VernacHints of string list * hints_expr | VernacSyntacticDefinition of Id.t located * (Id.t list * constr_expr) * - obsolete_locality * onlyparsing_flag + onlyparsing_flag | VernacDeclareImplicits of reference or_by_notation * (explicitation * bool * bool) list list | VernacArguments of reference or_by_notation * @@ -489,18 +482,39 @@ and vernac_argument_status = { implicit_status : vernac_implicit_status; } -(* A vernac classifier has to tell if a command: - vernac_when: has to be executed now (alters the parser) or later - vernac_type: if it is starts, ends, continues a proof or +(* A vernac classifier provides information about the exectuion of a + command: + + - vernac_when: encodes if the vernac may alter the parser [thus + forcing immediate execution], or if indeed it is pure and parsing + can continue without its execution. + + - vernac_type: if it is starts, ends, continues a proof or alters the global state or is a control command like BackTo or is - a query like Check *) + a query like Check. + + The classification works on the assumption that we have 3 states: + parsing, execution (global enviroment, etc...), and proof + state. For example, commands that only alter the proof state are + considered safe to delegate to a worker. + +*) type vernac_type = + (* Start of a proof *) | VtStartProof of vernac_start + (* Command altering the global state, bad for parallel + processing. *) | VtSideff of vernac_sideff_type + (* End of a proof *) | VtQed of vernac_qed_type + (* A proof step *) | VtProofStep of proof_step + (* To be removed *) | VtProofMode of string + (* Queries are commands assumed to be "pure", that is to say, they + don't modify the interpretation state. *) | VtQuery of vernac_part_of_script * Feedback.route_id + (* To be removed *) | VtMeta | VtUnknown and vernac_qed_type = VtKeep | VtKeepAsAxiom | VtDrop (* Qed/Admitted, Abort *) diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index e1b086b753..31ded9129a 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -234,7 +234,7 @@ let unfold_red kn = * instantiations (cbv or lazy) are. *) -type table_key = Constant.t puniverses tableKey +type table_key = Constant.t Univ.puniverses tableKey let eq_pconstant_key (c,u) (c',u') = eq_constant_key c c' && Univ.Instance.equal u u' @@ -480,7 +480,8 @@ let rec lft_fconstr n ft = | FCoFix(cfx,e) -> {norm=Cstr; term=FCoFix(cfx,subs_shft(n,e))} | FLIFT(k,m) -> lft_fconstr (n+k) m | FLOCKED -> assert false - | _ -> {norm=ft.norm; term=FLIFT(n,ft)} + | FFlex _ | FAtom _ | FCast _ | FApp _ | FProj _ | FCaseT _ | FProd _ + | FLetIn _ | FEvar _ | FCLOS _ -> {norm=ft.norm; term=FLIFT(n,ft)} let lift_fconstr k f = if Int.equal k 0 then f else lft_fconstr k f let lift_fconstr_vect k v = @@ -958,7 +959,10 @@ let rec knr info m stk = (match evar_value info.i_cache ev with Some c -> knit info env c stk | None -> (m,stk)) - | _ -> (m,stk) + | FLOCKED | FRel _ | FAtom _ | FCast _ | FFlex _ | FInd _ | FApp _ | FProj _ + | FFix _ | FCoFix _ | FCaseT _ | FLambda _ | FProd _ | FLetIn _ | FLIFT _ + | FCLOS _ -> (m, stk) + (* Computes the weak head normal form of a term *) and kni info m stk = @@ -1034,7 +1038,8 @@ and norm_head info m = mkEvar(i, Array.map (fun a -> kl info (mk_clos env a)) args) | FProj (p,c) -> mkProj (p, kl info c) - | t -> term_of_fconstr m + | FLOCKED | FRel _ | FAtom _ | FCast _ | FFlex _ | FInd _ | FConstruct _ + | FApp _ | FCaseT _ | FLIFT _ | FCLOS _ -> term_of_fconstr m (* Initialization and then normalization *) diff --git a/kernel/cClosure.mli b/kernel/cClosure.mli index 28136e1fc0..119b70e301 100644 --- a/kernel/cClosure.mli +++ b/kernel/cClosure.mli @@ -92,7 +92,7 @@ val unfold_side_red : reds val unfold_red : evaluable_global_reference -> reds (***********************************************************************) -type table_key = Constant.t puniverses tableKey +type table_key = Constant.t Univ.puniverses tableKey type 'a infos_cache type 'a infos = { @@ -122,8 +122,8 @@ type fterm = | FAtom of constr (** Metas and Sorts *) | FCast of fconstr * cast_kind * fconstr | FFlex of table_key - | FInd of inductive puniverses - | FConstruct of constructor puniverses + | FInd of inductive Univ.puniverses + | FConstruct of constructor Univ.puniverses | FApp of fconstr * fconstr array | FProj of projection * fconstr | FFix of fixpoint * fconstr subs diff --git a/kernel/constr.ml b/kernel/constr.ml index cec00c04b3..5930cfadc6 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -233,7 +233,6 @@ let mkMeta n = Meta n (* Constructs a Variable named id *) let mkVar id = Var id - (************************************************************************) (* kind_of_term = constructions as seen by the user *) (************************************************************************) @@ -250,6 +249,168 @@ let of_kind = function | Cast (c, knd, t) -> mkCast (c, knd, t) | k -> k +(**********************************************************************) +(* Non primitive term destructors *) +(**********************************************************************) + +(* Destructor operations : partial functions + Raise [DestKO] if the const has not the expected form *) + +exception DestKO + +let isMeta c = match kind c with Meta _ -> true | _ -> false + +(* Destructs a type *) +let isSort c = match kind c with + | Sort _ -> true + | _ -> false + +let rec isprop c = match kind c with + | Sort (Sorts.Prop _) -> true + | Cast (c,_,_) -> isprop c + | _ -> false + +let rec is_Prop c = match kind c with + | Sort (Sorts.Prop Sorts.Null) -> true + | Cast (c,_,_) -> is_Prop c + | _ -> false + +let rec is_Set c = match kind c with + | Sort (Sorts.Prop Sorts.Pos) -> true + | Cast (c,_,_) -> is_Set c + | _ -> false + +let rec is_Type c = match kind c with + | Sort (Sorts.Type _) -> true + | Cast (c,_,_) -> is_Type c + | _ -> false + +let is_small = Sorts.is_small +let iskind c = isprop c || is_Type c + +(* Tests if an evar *) +let isEvar c = match kind c with Evar _ -> true | _ -> false +let isEvar_or_Meta c = match kind c with + | Evar _ | Meta _ -> true + | _ -> false + +let isCast c = match kind c with Cast _ -> true | _ -> false +(* Tests if a de Bruijn index *) +let isRel c = match kind c with Rel _ -> true | _ -> false +let isRelN n c = + match kind c with Rel n' -> Int.equal n n' | _ -> false +(* Tests if a variable *) +let isVar c = match kind c with Var _ -> true | _ -> false +let isVarId id c = match kind c with Var id' -> Id.equal id id' | _ -> false +(* Tests if an inductive *) +let isInd c = match kind c with Ind _ -> true | _ -> false +let isProd c = match kind c with | Prod _ -> true | _ -> false +let isLambda c = match kind c with | Lambda _ -> true | _ -> false +let isLetIn c = match kind c with LetIn _ -> true | _ -> false +let isApp c = match kind c with App _ -> true | _ -> false +let isConst c = match kind c with Const _ -> true | _ -> false +let isConstruct c = match kind c with Construct _ -> true | _ -> false +let isCase c = match kind c with Case _ -> true | _ -> false +let isProj c = match kind c with Proj _ -> true | _ -> false +let isFix c = match kind c with Fix _ -> true | _ -> false +let isCoFix c = match kind c with CoFix _ -> true | _ -> false + +(* Destructs a de Bruijn index *) +let destRel c = match kind c with + | Rel n -> n + | _ -> raise DestKO + +(* Destructs an existential variable *) +let destMeta c = match kind c with + | Meta n -> n + | _ -> raise DestKO + +(* Destructs a variable *) +let destVar c = match kind c with + | Var id -> id + | _ -> raise DestKO + +let destSort c = match kind c with + | Sort s -> s + | _ -> raise DestKO + +(* Destructs a casted term *) +let destCast c = match kind c with + | Cast (t1,k,t2) -> (t1,k,t2) + | _ -> raise DestKO + +(* Destructs the product (x:t1)t2 *) +let destProd c = match kind c with + | Prod (x,t1,t2) -> (x,t1,t2) + | _ -> raise DestKO + +(* Destructs the abstraction [x:t1]t2 *) +let destLambda c = match kind c with + | Lambda (x,t1,t2) -> (x,t1,t2) + | _ -> raise DestKO + +(* Destructs the let [x:=b:t1]t2 *) +let destLetIn c = match kind c with + | LetIn (x,b,t1,t2) -> (x,b,t1,t2) + | _ -> raise DestKO + +(* Destructs an application *) +let destApp c = match kind c with + | App (f,a) -> (f, a) + | _ -> raise DestKO + +(* Destructs a constant *) +let destConst c = match kind c with + | Const kn -> kn + | _ -> raise DestKO + +(* Destructs an existential variable *) +let destEvar c = match kind c with + | Evar (kn, a as r) -> r + | _ -> raise DestKO + +(* Destructs a (co)inductive type named kn *) +let destInd c = match kind c with + | Ind (kn, a as r) -> r + | _ -> raise DestKO + +(* Destructs a constructor *) +let destConstruct c = match kind c with + | Construct (kn, a as r) -> r + | _ -> raise DestKO + +(* Destructs a term <p>Case c of lc1 | lc2 .. | lcn end *) +let destCase c = match kind c with + | Case (ci,p,c,v) -> (ci,p,c,v) + | _ -> raise DestKO + +let destProj c = match kind c with + | Proj (p, c) -> (p, c) + | _ -> raise DestKO + +let destFix c = match kind c with + | Fix fix -> fix + | _ -> raise DestKO + +let destCoFix c = match kind c with + | CoFix cofix -> cofix + | _ -> raise DestKO + + +(******************************************************************) +(* Flattening and unflattening of embedded applications and casts *) +(******************************************************************) + +let decompose_app c = + match kind c with + | App (f,cl) -> (f, Array.to_list cl) + | _ -> (c,[]) + +let decompose_appvect c = + match kind c with + | App (f,cl) -> (f, cl) + | _ -> (c,[||]) + (****************************************************************************) (* Functions to recur through subterms *) (****************************************************************************) @@ -513,6 +674,7 @@ let compare_head_gen_leq_with kind1 kind2 eq_universes leq_sorts eq leq t1 t2 = | Prod (_,t1,c1), Prod (_,t2,c2) -> eq t1 t2 && leq c1 c2 | Lambda (_,t1,c1), Lambda (_,t2,c2) -> eq t1 t2 && eq c1 c2 | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> eq b1 b2 && eq t1 t2 && leq c1 c2 + (* Why do we suddenly make a special case for Cast here? *) | App (Cast(c1, _, _),l1), _ -> leq (mkApp (c1,l1)) t2 | _, App (Cast (c2, _, _),l2) -> leq t1 (mkApp (c2,l2)) | App (c1,l1), App (c2,l2) -> @@ -530,7 +692,9 @@ let compare_head_gen_leq_with kind1 kind2 eq_universes leq_sorts eq leq t1 t2 = && Array.equal_norefl eq tl1 tl2 && Array.equal_norefl eq bl1 bl2 | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) -> Int.equal ln1 ln2 && Array.equal_norefl eq tl1 tl2 && Array.equal_norefl eq bl1 bl2 - | _ -> false + | (Rel _ | Meta _ | Var _ | Sort _ | Prod _ | Lambda _ | LetIn _ | App _ + | Proj _ | Evar _ | Const _ | Ind _ | Construct _ | Case _ | Fix _ + | CoFix _), _ -> false (* [compare_head_gen_leq u s eq leq c1 c2] compare [c1] and [c2] using [eq] to compare the immediate subterms of [c1] of [c2] for conversion if needed, [leq] for cumulativity, @@ -650,9 +814,6 @@ let always_true _ _ = true let rec eq_constr_nounivs m n = (m == n) || compare_head_gen (fun _ -> always_true) always_true eq_constr_nounivs m n -(** We only use this function over blocks! *) -let tag t = Obj.tag (Obj.repr t) - let constr_ord_int f t1 t2 = let (=?) f g i1 i2 j1 j2= let c = f i1 i2 in @@ -664,35 +825,50 @@ let constr_ord_int f t1 t2 = ((Array.compare Int.compare) =? Int.compare) a1 a2 i1 i2 in match kind t1, kind t2 with + | Cast (c1,_,_), _ -> f c1 t2 + | _, Cast (c2,_,_) -> f t1 c2 + (* Why this special case? *) + | App (Cast(c1,_,_),l1), _ -> f (mkApp (c1,l1)) t2 + | _, App (Cast(c2, _,_),l2) -> f t1 (mkApp (c2,l2)) | Rel n1, Rel n2 -> Int.compare n1 n2 - | Meta m1, Meta m2 -> Int.compare m1 m2 + | Rel _, _ -> -1 | _, Rel _ -> 1 | Var id1, Var id2 -> Id.compare id1 id2 + | Var _, _ -> -1 | _, Var _ -> 1 + | Meta m1, Meta m2 -> Int.compare m1 m2 + | Meta _, _ -> -1 | _, Meta _ -> 1 + | Evar (e1,l1), Evar (e2,l2) -> + (Evar.compare =? (Array.compare f)) e1 e2 l1 l2 + | Evar _, _ -> -1 | _, Evar _ -> 1 | Sort s1, Sort s2 -> Sorts.compare s1 s2 - | Cast (c1,_,_), _ -> f c1 t2 - | _, Cast (c2,_,_) -> f t1 c2 + | Sort _, _ -> -1 | _, Sort _ -> 1 | Prod (_,t1,c1), Prod (_,t2,c2) | Lambda (_,t1,c1), Lambda (_,t2,c2) -> (f =? f) t1 t2 c1 c2 + | Prod _, _ -> -1 | _, Prod _ -> 1 + | Lambda _, _ -> -1 | _, Lambda _ -> 1 | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> ((f =? f) ==? f) b1 b2 t1 t2 c1 c2 - | App (Cast(c1,_,_),l1), _ -> f (mkApp (c1,l1)) t2 - | _, App (Cast(c2, _,_),l2) -> f t1 (mkApp (c2,l2)) + | LetIn _, _ -> -1 | _, LetIn _ -> 1 | App (c1,l1), App (c2,l2) -> (f =? (Array.compare f)) c1 c2 l1 l2 - | Proj (p1,c1), Proj (p2,c2) -> (Projection.compare =? f) p1 p2 c1 c2 - | Evar (e1,l1), Evar (e2,l2) -> - (Evar.compare =? (Array.compare f)) e1 e2 l1 l2 + | App _, _ -> -1 | _, App _ -> 1 | Const (c1,u1), Const (c2,u2) -> Constant.CanOrd.compare c1 c2 + | Const _, _ -> -1 | _, Const _ -> 1 | Ind (ind1, u1), Ind (ind2, u2) -> ind_ord ind1 ind2 + | Ind _, _ -> -1 | _, Ind _ -> 1 | Construct (ct1,u1), Construct (ct2,u2) -> constructor_ord ct1 ct2 + | Construct _, _ -> -1 | _, Construct _ -> 1 | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> ((f =? f) ==? (Array.compare f)) p1 p2 c1 c2 bl1 bl2 + | Case _, _ -> -1 | _, Case _ -> 1 | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) -> ((fix_cmp =? (Array.compare f)) ==? (Array.compare f)) ln1 ln2 tl1 tl2 bl1 bl2 + | Fix _, _ -> -1 | _, Fix _ -> 1 | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) -> ((Int.compare =? (Array.compare f)) ==? (Array.compare f)) ln1 ln2 tl1 tl2 bl1 bl2 - | t1, t2 -> Int.compare (tag t1) (tag t2) + | CoFix _, _ -> -1 | _, CoFix _ -> 1 + | Proj (p1,c1), Proj (p2,c2) -> (Projection.compare =? f) p1 p2 c1 c2 let rec compare m n= constr_ord_int compare m n @@ -776,7 +952,9 @@ let hasheq t1 t2 = && array_eqeq lna1 lna2 && array_eqeq tl1 tl2 && array_eqeq bl1 bl2 - | _ -> false + | (Rel _ | Meta _ | Var _ | Sort _ | Cast _ | Prod _ | Lambda _ | LetIn _ + | App _ | Proj _ | Evar _ | Const _ | Ind _ | Construct _ | Case _ + | Fix _ | CoFix _), _ -> false (** Note that the following Make has the side effect of creating once and for all the table we'll use for hash-consing all constr *) diff --git a/kernel/constr.mli b/kernel/constr.mli index 474ab38843..21c477578c 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -13,20 +13,22 @@ open Names (** {6 Value under universe substitution } *) type 'a puniverses = 'a Univ.puniverses +[@@ocaml.deprecated "use Univ.puniverses"] (** {6 Simply type aliases } *) -type pconstant = Constant.t puniverses -type pinductive = inductive puniverses -type pconstructor = constructor puniverses +type pconstant = Constant.t Univ.puniverses +type pinductive = inductive Univ.puniverses +type pconstructor = constructor Univ.puniverses (** {6 Existential variables } *) type existential_key = Evar.t +[@@ocaml.deprecated "use Evar.t"] (** {6 Existential variables } *) type metavariable = int (** {6 Case annotation } *) -type case_style = LetStyle | IfStyle | LetPatternStyle | MatchStyle +type case_style = LetStyle | IfStyle | LetPatternStyle | MatchStyle | RegularStyle (** infer printing form from number of constructor *) type case_printing = { ind_tags : bool list; (** tell whether letin or lambda in the arity of the inductive type *) @@ -80,7 +82,7 @@ val mkVar : Id.t -> constr val mkMeta : metavariable -> constr (** Constructs an existential variable *) -type existential = existential_key * constr array +type existential = Evar.t * constr array val mkEvar : existential -> constr (** Construct a sort *) @@ -111,7 +113,7 @@ val mkLetIn : Name.t * constr * types * constr -> constr {%latex:$(f~t_1\dots f_n)$%}. *) val mkApp : constr * constr array -> constr -val map_puniverses : ('a -> 'b) -> 'a puniverses -> 'b puniverses +val map_puniverses : ('a -> 'b) -> 'a Univ.puniverses -> 'b Univ.puniverses (** Constructs a Constant.t *) val mkConst : Constant.t -> constr @@ -180,7 +182,7 @@ val mkCoFix : cofixpoint -> constr (** [constr array] is an instance matching definitional [named_context] in the same order (i.e. last argument first) *) -type 'constr pexistential = existential_key * 'constr array +type 'constr pexistential = Evar.t * 'constr array type ('constr, 'types) prec_declaration = Name.t array * 'types array * 'constr array type ('constr, 'types) pfixpoint = @@ -225,6 +227,110 @@ type ('constr, 'types, 'sort, 'univs) kind_of_term = val kind : constr -> (constr, types, Sorts.t, Univ.Instance.t) kind_of_term val of_kind : (constr, types, Sorts.t, Univ.Instance.t) kind_of_term -> constr +(** {6 Simple case analysis} *) +val isRel : constr -> bool +val isRelN : int -> constr -> bool +val isVar : constr -> bool +val isVarId : Id.t -> constr -> bool +val isInd : constr -> bool +val isEvar : constr -> bool +val isMeta : constr -> bool +val isEvar_or_Meta : constr -> bool +val isSort : constr -> bool +val isCast : constr -> bool +val isApp : constr -> bool +val isLambda : constr -> bool +val isLetIn : constr -> bool +val isProd : constr -> bool +val isConst : constr -> bool +val isConstruct : constr -> bool +val isFix : constr -> bool +val isCoFix : constr -> bool +val isCase : constr -> bool +val isProj : constr -> bool + +val is_Prop : constr -> bool +val is_Set : constr -> bool +val isprop : constr -> bool +val is_Type : constr -> bool +val iskind : constr -> bool +val is_small : Sorts.t -> bool + +(** {6 Term destructors } *) +(** Destructor operations are partial functions and + @raise DestKO if the term has not the expected form. *) + +exception DestKO + +(** Destructs a de Bruijn index *) +val destRel : constr -> int + +(** Destructs an existential variable *) +val destMeta : constr -> metavariable + +(** Destructs a variable *) +val destVar : constr -> Id.t + +(** Destructs a sort. [is_Prop] recognizes the sort {% \textsf{%}Prop{% }%}, whether + [isprop] recognizes both {% \textsf{%}Prop{% }%} and {% \textsf{%}Set{% }%}. *) +val destSort : constr -> Sorts.t + +(** Destructs a casted term *) +val destCast : constr -> constr * cast_kind * constr + +(** Destructs the product {% $ %}(x:t_1)t_2{% $ %} *) +val destProd : types -> Name.t * types * types + +(** Destructs the abstraction {% $ %}[x:t_1]t_2{% $ %} *) +val destLambda : constr -> Name.t * types * constr + +(** Destructs the let {% $ %}[x:=b:t_1]t_2{% $ %} *) +val destLetIn : constr -> Name.t * constr * types * constr + +(** Destructs an application *) +val destApp : constr -> constr * constr array + +(** Decompose any term as an applicative term; the list of args can be empty *) +val decompose_app : constr -> constr * constr list + +(** Same as [decompose_app], but returns an array. *) +val decompose_appvect : constr -> constr * constr array + +(** Destructs a constant *) +val destConst : constr -> Constant.t Univ.puniverses + +(** Destructs an existential variable *) +val destEvar : constr -> existential + +(** Destructs a (co)inductive type *) +val destInd : constr -> inductive Univ.puniverses + +(** Destructs a constructor *) +val destConstruct : constr -> constructor Univ.puniverses + +(** Destructs a [match c as x in I args return P with ... | +Ci(...yij...) => ti | ... end] (or [let (..y1i..) := c as x in I args +return P in t1], or [if c then t1 else t2]) +@return [(info,c,fun args x => P,[|...|fun yij => ti| ...|])] +where [info] is pretty-printing information *) +val destCase : constr -> case_info * constr * constr * constr array + +(** Destructs a projection *) +val destProj : constr -> projection * constr + +(** Destructs the {% $ %}i{% $ %}th function of the block + [Fixpoint f{_ 1} ctx{_ 1} = b{_ 1} + with f{_ 2} ctx{_ 2} = b{_ 2} + ... + with f{_ n} ctx{_ n} = b{_ n}], + where the length of the {% $ %}j{% $ %}th context is {% $ %}ij{% $ %}. +*) +val destFix : constr -> fixpoint + +val destCoFix : constr -> cofixpoint + +(** {6 Equality} *) + (** [equal a b] is true if [a] equals [b] modulo alpha, casts, and application grouping *) val equal : constr -> constr -> bool @@ -344,7 +450,7 @@ val compare_head_gen_leq : (bool -> Univ.Instance.t -> Univ.Instance.t -> bool) (constr -> constr -> bool) -> (constr -> constr -> bool) -> constr -> constr -> bool - + (** {6 Hashconsing} *) val hash : constr -> int diff --git a/kernel/declarations.ml b/kernel/declarations.ml index b95796fd8f..7f4b85fd05 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -63,7 +63,7 @@ type constant_def = | OpaqueDef of Opaqueproof.opaque (** or an opaque global definition *) type constant_universes = - | Monomorphic_const of Univ.UContext.t + | Monomorphic_const of Univ.ContextSet.t | Polymorphic_const of Univ.AUContext.t (** The [typing_flags] are instructions to the type-checker which @@ -168,9 +168,14 @@ type one_inductive_body = { } type abstract_inductive_universes = - | Monomorphic_ind of Univ.UContext.t + | Monomorphic_ind of Univ.ContextSet.t | Polymorphic_ind of Univ.AUContext.t - | Cumulative_ind of Univ.ACumulativityInfo.t + | Cumulative_ind of Univ.ACumulativityInfo.t + +type recursivity_kind = + | Finite (** = inductive *) + | CoFinite (** = coinductive *) + | BiFinite (** = non-recursive, like in "Record" definitions *) type mutual_inductive_body = { @@ -178,7 +183,7 @@ type mutual_inductive_body = { mind_record : record_body option; (** The record information *) - mind_finite : Decl_kinds.recursivity_kind; (** Whether the type is inductive or coinductive *) + mind_finite : recursivity_kind; (** Whether the type is inductive or coinductive *) mind_ntypes : int; (** Number of types in the block *) diff --git a/kernel/declareops.ml b/kernel/declareops.ml index f5c26b33d6..d8768a0fc5 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -126,7 +126,7 @@ let hcons_const_def = function let hcons_const_universes cbu = match cbu with | Monomorphic_const ctx -> - Monomorphic_const (Univ.hcons_universe_context ctx) + Monomorphic_const (Univ.hcons_universe_context_set ctx) | Polymorphic_const ctx -> Polymorphic_const (Univ.hcons_abstract_universe_context ctx) @@ -274,7 +274,7 @@ let hcons_mind_packet oib = let hcons_mind_universes miu = match miu with - | Monomorphic_ind ctx -> Monomorphic_ind (Univ.hcons_universe_context ctx) + | Monomorphic_ind ctx -> Monomorphic_ind (Univ.hcons_universe_context_set ctx) | Polymorphic_ind ctx -> Polymorphic_ind (Univ.hcons_abstract_universe_context ctx) | Cumulative_ind cui -> Cumulative_ind (Univ.hcons_abstract_cumulativity_info cui) diff --git a/kernel/entries.ml b/kernel/entries.ml index 185dba409a..ca79de404d 100644 --- a/kernel/entries.ml +++ b/kernel/entries.ml @@ -35,9 +35,9 @@ then, in i{^ th} block, [mind_entry_params] is [xn:Xn;...;x1:X1]; *) type inductive_universes = - | Monomorphic_ind_entry of Univ.UContext.t + | Monomorphic_ind_entry of Univ.ContextSet.t | Polymorphic_ind_entry of Univ.UContext.t - | Cumulative_ind_entry of Univ.CumulativityInfo.t + | Cumulative_ind_entry of Univ.CumulativityInfo.t type one_inductive_entry = { mind_entry_typename : Id.t; @@ -51,7 +51,7 @@ type mutual_inductive_entry = { (** Some (Some id): primitive record with id the binder name of the record in projections. Some None: non-primitive record *) - mind_entry_finite : Decl_kinds.recursivity_kind; + mind_entry_finite : Declarations.recursivity_kind; mind_entry_params : (Id.t * local_entry) list; mind_entry_inds : one_inductive_entry list; mind_entry_universes : inductive_universes; @@ -65,9 +65,11 @@ type 'a proof_output = constr Univ.in_universe_context_set * 'a type 'a const_entry_body = 'a proof_output Future.computation type constant_universes_entry = - | Monomorphic_const_entry of Univ.UContext.t + | Monomorphic_const_entry of Univ.ContextSet.t | Polymorphic_const_entry of Univ.UContext.t +type 'a in_constant_universes_entry = 'a * constant_universes_entry + type 'a definition_entry = { const_entry_body : 'a const_entry_body; (* List of section variables *) @@ -82,7 +84,7 @@ type 'a definition_entry = { type inline = int option (* inlining level, None for no inlining *) type parameter_entry = - Context.Named.t option * bool * types Univ.in_universe_context * inline + Context.Named.t option * types in_constant_universes_entry * inline type projection_entry = { proj_entry_ind : MutInd.t; diff --git a/kernel/environ.mli b/kernel/environ.mli index f2066b0659..7cc541258d 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -7,8 +7,8 @@ (************************************************************************) open Names -open Univ open Constr +open Univ open Declarations (** Unsafe environments. We define here a datatype for environments. @@ -152,9 +152,9 @@ exception NotEvaluableConst of const_evaluation_result val constant_value : env -> Constant.t puniverses -> constr constrained val constant_type : env -> Constant.t puniverses -> types constrained -val constant_opt_value : env -> Constant.t puniverses -> (constr * Univ.constraints) option +val constant_opt_value : env -> Constant.t puniverses -> (constr * Univ.Constraint.t) option val constant_value_and_type : env -> Constant.t puniverses -> - constr option * types * Univ.constraints + constr option * types * Univ.Constraint.t (** The universe context associated to the constant, empty if not polymorphic *) val constant_context : env -> Constant.t -> Univ.AUContext.t @@ -203,10 +203,10 @@ val lookup_modtype : ModPath.t -> env -> module_type_body (** Add universe constraints to the environment. @raises UniverseInconsistency *) -val add_constraints : Univ.constraints -> env -> env +val add_constraints : Univ.Constraint.t -> env -> env (** Check constraints are satifiable in the environment. *) -val check_constraints : Univ.constraints -> env -> bool +val check_constraints : Univ.Constraint.t -> env -> bool val push_context : ?strict:bool -> Univ.UContext.t -> env -> env val push_context_set : ?strict:bool -> Univ.ContextSet.t -> env -> env val push_constraints_to_env : 'a Univ.constrained -> env -> env diff --git a/kernel/evar.ml b/kernel/evar.ml index e63665f519..dcd2e12a0c 100644 --- a/kernel/evar.ml +++ b/kernel/evar.ml @@ -13,6 +13,7 @@ let unsafe_of_int x = x let compare = Int.compare let equal = Int.equal let hash = Int.hash +let print x = Pp.(str "?X" ++ int x) module Set = Int.Set module Map = Int.Map diff --git a/kernel/evar.mli b/kernel/evar.mli index eee6680fb8..6a058207f6 100644 --- a/kernel/evar.mli +++ b/kernel/evar.mli @@ -30,5 +30,8 @@ val compare : t -> t -> int val hash : t -> int (** Hash over existential variables. *) +val print : t -> Pp.t +(** Printing representation *) + module Set : Set.S with type elt = t module Map : CMap.ExtS with type key = t and module Set := Set diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index f4e611c191..8e9b606a58 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -56,7 +56,7 @@ let weaker_noccur_between env x nvars t = else None let is_constructor_head t = - Term.isRel(fst(Term.decompose_app t)) + isRel(fst(decompose_app t)) (************************************************************************) (* Various well-formedness check for inductive declarations *) @@ -135,7 +135,7 @@ let infos_and_sort env t = | Prod (name,c1,c2) -> let varj = infer_type env c1 in let env1 = Environ.push_rel (LocalAssum (name,varj.utj_val)) env in - let max = Universe.sup max (Term.univ_of_sort varj.utj_type) in + let max = Universe.sup max (Sorts.univ_of_sort varj.utj_type) in aux env1 c2 max | _ when is_constructor_head t -> max | _ -> (* don't fail if not positive, it is tested later *) max @@ -184,7 +184,7 @@ let cumulate_arity_large_levels env sign = match d with | LocalAssum (_,t) -> let tj = infer_type env t in - let u = Term.univ_of_sort tj.utj_type in + let u = Sorts.univ_of_sort tj.utj_type in (Universe.sup u lev, push_rel d env) | LocalDef _ -> lev, push_rel d env) @@ -265,13 +265,12 @@ let typecheck_inductive env mie = (* Check unicity of names *) mind_check_names mie; (* Params are typed-checked here *) - let univctx = + let env' = match mie.mind_entry_universes with - | Monomorphic_ind_entry ctx -> ctx - | Polymorphic_ind_entry ctx -> ctx - | Cumulative_ind_entry cumi -> Univ.CumulativityInfo.univ_context cumi + | Monomorphic_ind_entry ctx -> push_context_set ctx env + | Polymorphic_ind_entry ctx -> push_context ctx env + | Cumulative_ind_entry cumi -> push_context (Univ.CumulativityInfo.univ_context cumi) env in - let env' = push_context univctx env in let (env_params,paramsctxt) = infer_local_decls env' mie.mind_entry_params in (* We first type arity of each inductive definition *) (* This allows building the environment of arities and to share *) @@ -351,7 +350,7 @@ let typecheck_inductive env mie = | None -> clev in let full_polymorphic () = - let defu = Term.univ_of_sort def_level in + let defu = Sorts.univ_of_sort def_level in let is_natural = type_in_type env || (UGraph.check_leq (universes env') infu defu) in @@ -555,7 +554,7 @@ let check_positivity_one ~chkpos recursive (env,_,ntypes,_ as ienv) paramsctxt ( constructor [cn] has a type of the shape [… -> c … -> P], where, more generally, the arrows may be dependent). *) let rec check_pos (env, n, ntypes, ra_env as ienv) nmr c = - let x,largs = Term.decompose_app (whd_all env c) in + let x,largs = decompose_app (whd_all env c) in match kind x with | Prod (na,b,d) -> let () = assert (List.is_empty largs) in @@ -663,7 +662,7 @@ let check_positivity_one ~chkpos recursive (env,_,ntypes,_ as ienv) paramsctxt ( inductive type. *) and check_constructors ienv check_head nmr c = let rec check_constr_rec (env,n,ntypes,ra_env as ienv) nmr lrec c = - let x,largs = Term.decompose_app (whd_all env c) in + let x,largs = decompose_app (whd_all env c) in match kind x with | Prod (na,b,d) -> @@ -916,11 +915,11 @@ let build_inductive env prv iu env_ar paramsctxt kn isrecord isfinite inds nmr r let ar = {template_param_levels = paramlevs; template_level = lev} in TemplateArity ar, all_sorts | RegularArity (info,ar,defs) -> - let s = sort_of_univ defs in + let s = Sorts.sort_of_univ defs in let kelim = allowed_sorts info s in let ar = RegularArity { mind_user_arity = Vars.subst_univs_level_constr substunivs ar; - mind_sort = sort_of_univ (Univ.subst_univs_level_universe substunivs defs); } in + mind_sort = Sorts.sort_of_univ (Univ.subst_univs_level_universe substunivs defs); } in ar, kelim in (* Assigning VM tags to constructors *) let nconst, nblock = ref 0, ref 0 in diff --git a/kernel/inductive.ml b/kernel/inductive.ml index cb03a4d6bd..62aa9a2d7b 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -29,20 +29,20 @@ let lookup_mind_specif env (kn,tyi) = (mib, mib.mind_packets.(tyi)) let find_rectype env c = - let (t, l) = Term.decompose_app (whd_all env c) in + let (t, l) = decompose_app (whd_all env c) in match kind t with | Ind ind -> (ind, l) | _ -> raise Not_found let find_inductive env c = - let (t, l) = Term.decompose_app (whd_all env c) in + let (t, l) = decompose_app (whd_all env c) in match kind t with | Ind ind when (fst (lookup_mind_specif env (out_punivs ind))).mind_finite <> Decl_kinds.CoFinite -> (ind, l) | _ -> raise Not_found let find_coinductive env c = - let (t, l) = Term.decompose_app (whd_all env c) in + let (t, l) = decompose_app (whd_all env c) in match kind t with | Ind ind when (fst (lookup_mind_specif env (out_punivs ind))).mind_finite == Decl_kinds.CoFinite -> (ind, l) @@ -354,7 +354,7 @@ let build_branches_type (ind,u) (_,mip as specif) params p = let typi = full_constructor_instantiate (ind,u,specif,params) cty in let (cstrsign,ccl) = Term.decompose_prod_assum typi in let nargs = Context.Rel.length cstrsign in - let (_,allargs) = Term.decompose_app ccl in + let (_,allargs) = decompose_app ccl in let (lparams,vargs) = List.chop (inductive_params specif) allargs in let cargs = let cstr = ith_constructor_of_inductive ind (i+1) in @@ -566,8 +566,8 @@ let check_inductive_codomain env p = let env = push_rel_context absctx env in let arctx, s = dest_prod_assum env ar in let env = push_rel_context arctx env in - let i,l' = Term.decompose_app (whd_all env s) in - Term.isInd i + let i,l' = decompose_app (whd_all env s) in + isInd i (* The following functions are almost duplicated from indtypes.ml, except that they carry here a poorer environment (containing less information). *) @@ -621,7 +621,7 @@ close to check_positive in indtypes.ml, but does no positivity check and does no compute the number of recursive arguments. *) let get_recargs_approx env tree ind args = let rec build_recargs (env, ra_env as ienv) tree c = - let x,largs = Term.decompose_app (whd_all env c) in + let x,largs = decompose_app (whd_all env c) in match kind x with | Prod (na,b,d) -> assert (List.is_empty largs); @@ -680,7 +680,7 @@ let get_recargs_approx env tree ind args = and build_recargs_constructors ienv trees c = let rec recargs_constr_rec (env,ra_env as ienv) trees lrec c = - let x,largs = Term.decompose_app (whd_all env c) in + let x,largs = decompose_app (whd_all env c) in match kind x with | Prod (na,b,d) -> @@ -709,7 +709,7 @@ let restrict_spec env spec p = let env = push_rel_context absctx env in let arctx, s = dest_prod_assum env ar in let env = push_rel_context arctx env in - let i,args = Term.decompose_app (whd_all env s) in + let i,args = decompose_app (whd_all env s) in match kind i with | Ind i -> begin match spec with @@ -730,7 +730,7 @@ let restrict_spec env spec p = let rec subterm_specif renv stack t = (* maybe reduction is not always necessary! *) - let f,l = Term.decompose_app (whd_all renv.env t) in + let f,l = decompose_app (whd_all renv.env t) in match kind f with | Rel k -> subterm_var k renv | Case (ci,p,c,lbr) -> @@ -809,8 +809,11 @@ let rec subterm_specif renv stack t = | Dead_code -> Dead_code | Not_subterm -> Not_subterm) + | Var _ | Sort _ | Cast _ | Prod _ | LetIn _ | App _ | Const _ | Ind _ + | Construct _ | CoFix _ -> Not_subterm + + (* Other terms are not subterms *) - | _ -> Not_subterm and lazy_subterm_specif renv stack t = lazy (subterm_specif renv stack t) @@ -863,7 +866,7 @@ let filter_stack_domain env ci p stack = 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 = Term.decompose_app (whd_all env a) in + let ty, args = decompose_app (whd_all env a) in let elt = match kind ty with | Ind ind -> let spec' = stack_element_specif elt in @@ -894,7 +897,7 @@ let check_one_fix renv recpos trees def = (* if [t] does not make recursive calls, it is guarded: *) if noccur_with_meta renv.rel_min nfi t then () else - let (f,l) = Term.decompose_app (whd_betaiotazeta renv.env t) in + let (f,l) = decompose_app (whd_betaiotazeta renv.env t) in match kind f with | Rel p -> (* Test if [p] is a fixpoint (recursive call) *) @@ -1120,7 +1123,7 @@ let rec codomain_is_coind env c = let check_one_cofix env nbfix def deftype = let rec check_rec_call env alreadygrd n tree vlra t = if not (noccur_with_meta n nbfix t) then - let c,args = Term.decompose_app (whd_all env t) in + let c,args = decompose_app (whd_all env t) in match kind c with | Rel p when n <= p && p < n+nbfix -> (* recursive call: must be guarded and no nested recursive @@ -1193,8 +1196,8 @@ let check_one_cofix env nbfix def deftype = | Meta _ -> () | Evar _ -> List.iter (check_rec_call env alreadygrd n tree vlra) args - - | _ -> raise (CoFixGuardError (env,NotGuardedForm t)) in + | Rel _ | Var _ | Sort _ | Cast _ | Prod _ | LetIn _ | App _ | Const _ + | Ind _ | Fix _ | Proj _ -> raise (CoFixGuardError (env,NotGuardedForm t)) in let ((mind, _),_) = codomain_is_coind env deftype in let vlra = lookup_subterms env mind in diff --git a/kernel/inductive.mli b/kernel/inductive.mli index 601422a104..8aaeee831b 100644 --- a/kernel/inductive.mli +++ b/kernel/inductive.mli @@ -7,8 +7,8 @@ (************************************************************************) open Names -open Univ open Constr +open Univ open Declarations open Environ @@ -37,7 +37,7 @@ val ind_subst : MutInd.t -> mutual_inductive_body -> Instance.t -> constr list val inductive_paramdecls : mutual_inductive_body puniverses -> Context.Rel.t val instantiate_inductive_constraints : - mutual_inductive_body -> Instance.t -> constraints + mutual_inductive_body -> Instance.t -> Constraint.t val constrained_type_of_inductive : env -> mind_specif puniverses -> types constrained val constrained_type_of_inductive_knowing_parameters : diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index 8568bf14b8..f7e755f005 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -79,18 +79,20 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv = environment, because they do not appear in the type of the definition. Any inconsistency will be raised at a later stage when joining the environment. *) - let env' = Environ.push_context ~strict:true ctx env' in - let c',cst = match cb.const_body with - | Undef _ | OpaqueDef _ -> - let j = Typeops.infer env' c in - let typ = cb.const_type in - let cst' = Reduction.infer_conv_leq env' (Environ.universes env') - j.uj_type typ in - j.uj_val, cst' - | Def cs -> - let c' = Mod_subst.force_constr cs in - c, Reduction.infer_conv env' (Environ.universes env') c c' - in c', Monomorphic_const ctx, Univ.ContextSet.add_constraints cst (Univ.ContextSet.of_context ctx) + let env' = Environ.push_context ~strict:true ctx env' in + let c',cst = match cb.const_body with + | Undef _ | OpaqueDef _ -> + let j = Typeops.infer env' c in + let typ = cb.const_type in + let cst' = Reduction.infer_conv_leq env' (Environ.universes env') + j.uj_type typ in + j.uj_val, cst' + | Def cs -> + let c' = Mod_subst.force_constr cs in + c, Reduction.infer_conv env' (Environ.universes env') c c' + in + let ctx = Univ.ContextSet.of_context ctx in + c', Monomorphic_const ctx, Univ.ContextSet.add_constraints cst ctx | Polymorphic_const uctx -> let subst, ctx = Univ.abstract_universes ctx in let c = Vars.subst_univs_level_constr subst c in diff --git a/kernel/modops.ml b/kernel/modops.ml index b1df1a1877..11e6be6598 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -266,9 +266,9 @@ let subst_structure subst = subst_structure subst do_delta_codom (* lclrk : retroknowledge_action list, rkaction : retroknowledge action *) let add_retroknowledge mp = let perform rkaction env = match rkaction with - |Retroknowledge.RKRegister (f, e) when (Term.isConst e || Term.isInd e) -> + | Retroknowledge.RKRegister (f, e) when (isConst e || isInd e) -> Environ.register env f e - |_ -> + | _ -> CErrors.anomaly ~label:"Modops.add_retroknowledge" (Pp.str "had to import an unsupported kind of term.") in diff --git a/kernel/names.ml b/kernel/names.ml index cb27104d15..b02c0b8409 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -179,6 +179,8 @@ struct | [] -> "<>" | sl -> String.concat "." (List.rev_map Id.to_string sl) + let print dp = str (to_string dp) + let initial = [default_module_name] module Hdir = Hashcons.Hlist(Id) diff --git a/kernel/names.mli b/kernel/names.mli index ba0637c8a0..709ebeb7fd 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -159,6 +159,7 @@ sig val hcons : t -> t (** Hashconsing of directory paths. *) + val print : t -> Pp.t end (** {6 Names of structure elements } *) diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml index e9c0e171ac..4e7d6b218c 100644 --- a/kernel/nativelib.ml +++ b/kernel/nativelib.ml @@ -87,7 +87,7 @@ let call_compiler ?profile:(profile=false) ml_filename = [] in let flambda_args = - if Coq_config.caml_version_nums >= [4;3;0] then + if Coq_config.caml_version_nums >= [4;3;0] && Dynlink.is_native then (* We play safe for now, and use the native compiler with -Oclassic, however it is likely that `native_compute` users can benefit from tweaking here. diff --git a/kernel/reduction.ml b/kernel/reduction.ml index bf998933e3..b0f4a1e5f1 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -57,7 +57,9 @@ let compare_stack_shape stk1 stk2 = Int.equal bal 0 (* && c1.ci_ind = c2.ci_ind *) && compare_rec 0 s1 s2 | (Zfix(_,a1)::s1, Zfix(_,a2)::s2) -> Int.equal bal 0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2 - | (_,_) -> false in + | [], _ :: _ + | (Zproj _ | ZcaseT _ | Zfix _) :: _, _ -> false + in compare_rec 0 stk1 stk2 type lft_constr_stack_elt = @@ -122,14 +124,17 @@ let nf_betaiota env t = let whd_betaiotazeta env x = match kind x with - | (Sort _|Var _|Meta _|Evar _|Const _|Ind _|Construct _| + | (Sort _|Var _|Meta _|Evar _|Const _|Ind _|Construct _| Prod _|Lambda _|Fix _|CoFix _) -> x | App (c, _) -> begin match kind c with | Ind _ | Construct _ | Evar _ | Meta _ | Const _ -> x - | _ -> whd_val (create_clos_infos betaiotazeta env) (inject x) + | Sort _ | Rel _ | Var _ | Cast _ | Prod _ | Lambda _ | LetIn _ | App _ + | Case _ | Fix _ | CoFix _ | Proj _ -> + whd_val (create_clos_infos betaiotazeta env) (inject x) end - | _ -> whd_val (create_clos_infos betaiotazeta env) (inject x) + | Rel _ | Cast _ | LetIn _ | Case _ | Proj _ -> + whd_val (create_clos_infos betaiotazeta env) (inject x) let whd_all env t = match kind t with @@ -138,9 +143,12 @@ let whd_all env t = | App (c, _) -> begin match kind c with | Ind _ | Construct _ | Evar _ | Meta _ -> t - | _ -> whd_val (create_clos_infos all env) (inject t) + | Sort _ | Rel _ | Var _ | Cast _ | Prod _ | Lambda _ | LetIn _ | App _ + | Const _ |Case _ | Fix _ | CoFix _ | Proj _ -> + whd_val (create_clos_infos all env) (inject t) end - | _ -> whd_val (create_clos_infos all env) (inject t) + | Rel _ | Cast _ | LetIn _ | Case _ | Proj _ | Const _ | Var _ -> + whd_val (create_clos_infos all env) (inject t) let whd_allnolet env t = match kind t with @@ -149,9 +157,12 @@ let whd_allnolet env t = | App (c, _) -> begin match kind c with | Ind _ | Construct _ | Evar _ | Meta _ | LetIn _ -> t - | _ -> whd_val (create_clos_infos allnolet env) (inject t) + | Sort _ | Rel _ | Var _ | Cast _ | Prod _ | Lambda _ | App _ + | Const _ | Case _ | Fix _ | CoFix _ | Proj _ -> + whd_val (create_clos_infos allnolet env) (inject t) end - | _ -> whd_val (create_clos_infos allnolet env) (inject t) + | Rel _ | Cast _ | Case _ | Proj _ | Const _ | Var _ -> + whd_val (create_clos_infos allnolet env) (inject t) (********************************************************************) (* Conversion *) @@ -201,7 +212,7 @@ type 'a universe_state = 'a * 'a universe_compare type ('a,'b) generic_conversion_function = env -> 'b universe_state -> 'a -> 'a -> 'b -type 'a infer_conversion_function = env -> UGraph.t -> 'a -> 'a -> Univ.constraints +type 'a infer_conversion_function = env -> UGraph.t -> 'a -> 'a -> Univ.Constraint.t let sort_cmp_universes env pb s0 s1 (u, check) = (check.compare env pb s0 s1 u, check) @@ -578,10 +589,10 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = (* Should not happen because both (hd1,v1) and (hd2,v2) are in whnf *) | ( (FLetIn _, _) | (FCaseT _,_) | (FApp _,_) | (FCLOS _,_) | (FLIFT _,_) | (_, FLetIn _) | (_,FCaseT _) | (_,FApp _) | (_,FCLOS _) | (_,FLIFT _) - | (FLOCKED,_) | (_,FLOCKED) ) -> assert false + | (FLOCKED,_) | (_,FLOCKED) ) | (FCast _, _) | (_, FCast _) -> assert false - (* In all other cases, terms are not convertible *) - | _ -> raise NotConvertible + | (FRel _ | FAtom _ | FInd _ | FFix _ | FCoFix _ + | FProd _ | FEvar _), _ -> raise NotConvertible and convert_stacks l2r infos lft1 lft2 stk1 stk2 cuniv = compare_stacks diff --git a/kernel/reduction.mli b/kernel/reduction.mli index 05a906e28b..573e4c8bde 100644 --- a/kernel/reduction.mli +++ b/kernel/reduction.mli @@ -49,7 +49,7 @@ type 'a universe_state = 'a * 'a universe_compare type ('a,'b) generic_conversion_function = env -> 'b universe_state -> 'a -> 'a -> 'b -type 'a infer_conversion_function = env -> UGraph.t -> 'a -> 'a -> Univ.constraints +type 'a infer_conversion_function = env -> UGraph.t -> 'a -> 'a -> Univ.Constraint.t val sort_cmp_universes : env -> conv_pb -> Sorts.t -> Sorts.t -> 'a * 'a universe_compare -> 'a * 'a universe_compare diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 0e416b3e53..0e41bfc3c4 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -249,14 +249,14 @@ let universes_of_private eff = in match cb.const_universes with | Monomorphic_const ctx -> - (Univ.ContextSet.of_context ctx) :: acc + ctx :: acc | Polymorphic_const _ -> acc ) acc l | Entries.SEsubproof (c, cb, e) -> match cb.const_universes with | Monomorphic_const ctx -> - (Univ.ContextSet.of_context ctx) :: acc + ctx :: acc | Polymorphic_const _ -> acc ) [] (Term_typing.uniq_seff eff) @@ -389,7 +389,6 @@ let push_named_def (id,de) senv = | Monomorphic_const_entry _ -> false | Polymorphic_const_entry _ -> true in - let univs = Univ.ContextSet.of_context univs in let c, univs = match c with | Def c -> Mod_subst.force_constr c, univs | OpaqueDef o -> @@ -425,9 +424,8 @@ let labels_of_mib mib = let globalize_constant_universes env cb = match cb.const_universes with - | Monomorphic_const ctx -> - let cstrs = Univ.ContextSet.of_context ctx in - Now (false, cstrs) :: + | Monomorphic_const cstrs -> + Now (false, cstrs) :: (match cb.const_body with | (Undef _ | Def _) -> [] | OpaqueDef lc -> @@ -443,7 +441,7 @@ let globalize_constant_universes env cb = let globalize_mind_universes mb = match mb.mind_universes with | Monomorphic_ind ctx -> - [Now (false, Univ.ContextSet.of_context ctx)] + [Now (false, ctx)] | Polymorphic_ind _ -> [Now (true, Univ.ContextSet.empty)] | Cumulative_ind _ -> [Now (true, Univ.ContextSet.empty)] diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 0bfe074860..a30bb37e64 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -139,7 +139,7 @@ val push_context : bool -> Univ.UContext.t -> safe_transformer0 val add_constraints : - Univ.constraints -> safe_transformer0 + Univ.Constraint.t -> safe_transformer0 (* (\** Generator of universes *\) *) (* val next_universe : int safe_transformer *) diff --git a/kernel/subtyping.mli b/kernel/subtyping.mli index b24c20aa02..67df3759ec 100644 --- a/kernel/subtyping.mli +++ b/kernel/subtyping.mli @@ -10,4 +10,4 @@ open Univ open Declarations open Environ -val check_subtypes : env -> module_type_body -> module_type_body -> constraints +val check_subtypes : env -> module_type_body -> module_type_body -> Constraint.t diff --git a/kernel/term.ml b/kernel/term.ml index 1c970867a9..aa88059524 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -11,6 +11,7 @@ open Pp open CErrors open Names open Vars +open Constr (**********************************************************************) (** Redeclaration of types from module Constr *) @@ -30,7 +31,7 @@ type constr = Constr.t type types = Constr.t (** Same as [constr], for documentation purposes. *) -type existential_key = Constr.existential_key +type existential_key = Evar.t type existential = Constr.existential type metavariable = Constr.metavariable @@ -165,167 +166,52 @@ let hcons_types = Constr.hcons (* Non primitive term destructors *) (**********************************************************************) -(* Destructor operations : partial functions - Raise [DestKO] if the const has not the expected form *) - -exception DestKO - +exception DestKO = DestKO (* Destructs a de Bruijn index *) -let destRel c = match kind_of_term c with - | Rel n -> n - | _ -> raise DestKO - -(* Destructs an existential variable *) -let destMeta c = match kind_of_term c with - | Meta n -> n - | _ -> raise DestKO - -let isMeta c = match kind_of_term c with Meta _ -> true | _ -> false - -(* Destructs a variable *) -let destVar c = match kind_of_term c with - | Var id -> id - | _ -> raise DestKO - -(* Destructs a type *) -let isSort c = match kind_of_term c with - | Sort _ -> true - | _ -> false - -let destSort c = match kind_of_term c with - | Sort s -> s - | _ -> raise DestKO - -let rec isprop c = match kind_of_term c with - | Sort (Prop _) -> true - | Cast (c,_,_) -> isprop c - | _ -> false - -let rec is_Prop c = match kind_of_term c with - | Sort (Prop Null) -> true - | Cast (c,_,_) -> is_Prop c - | _ -> false - -let rec is_Set c = match kind_of_term c with - | Sort (Prop Pos) -> true - | Cast (c,_,_) -> is_Set c - | _ -> false - -let rec is_Type c = match kind_of_term c with - | Sort (Type _) -> true - | Cast (c,_,_) -> is_Type c - | _ -> false - -let is_small = Sorts.is_small - -let iskind c = isprop c || is_Type c - -(* Tests if an evar *) -let isEvar c = match kind_of_term c with Evar _ -> true | _ -> false - -let isEvar_or_Meta c = match kind_of_term c with - | Evar _ | Meta _ -> true - | _ -> false - -(* Destructs a casted term *) -let destCast c = match kind_of_term c with - | Cast (t1,k,t2) -> (t1,k,t2) - | _ -> raise DestKO - -let isCast c = match kind_of_term c with Cast _ -> true | _ -> false - - -(* Tests if a de Bruijn index *) -let isRel c = match kind_of_term c with Rel _ -> true | _ -> false -let isRelN n c = - match kind_of_term c with Rel n' -> Int.equal n n' | _ -> false - -(* Tests if a variable *) -let isVar c = match kind_of_term c with Var _ -> true | _ -> false -let isVarId id c = - match kind_of_term c with Var id' -> Id.equal id id' | _ -> false - -(* Tests if an inductive *) -let isInd c = match kind_of_term c with Ind _ -> true | _ -> false - -(* Destructs the product (x:t1)t2 *) -let destProd c = match kind_of_term c with - | Prod (x,t1,t2) -> (x,t1,t2) - | _ -> raise DestKO - -let isProd c = match kind_of_term c with | Prod _ -> true | _ -> false - -(* Destructs the abstraction [x:t1]t2 *) -let destLambda c = match kind_of_term c with - | Lambda (x,t1,t2) -> (x,t1,t2) - | _ -> raise DestKO - -let isLambda c = match kind_of_term c with | Lambda _ -> true | _ -> false - -(* Destructs the let [x:=b:t1]t2 *) -let destLetIn c = match kind_of_term c with - | LetIn (x,b,t1,t2) -> (x,b,t1,t2) - | _ -> raise DestKO - -let isLetIn c = match kind_of_term c with LetIn _ -> true | _ -> false - -(* Destructs an application *) -let destApp c = match kind_of_term c with - | App (f,a) -> (f, a) - | _ -> raise DestKO - +let destRel = destRel +let destMeta = destRel +let isMeta = isMeta +let destVar = destVar +let isSort = isSort +let destSort = destSort +let isprop = isprop +let is_Prop = is_Prop +let is_Set = is_Set +let is_Type = is_Type +let is_small = is_small +let iskind = iskind +let isEvar = isEvar +let isEvar_or_Meta = isEvar_or_Meta +let destCast = destCast +let isCast = isCast +let isRel = isRel +let isRelN = isRelN +let isVar = isVar +let isVarId = isVarId +let isInd = isInd +let destProd = destProd +let isProd = isProd +let destLambda = destLambda +let isLambda = isLambda +let destLetIn = destLetIn +let isLetIn = isLetIn +let destApp = destApp let destApplication = destApp - -let isApp c = match kind_of_term c with App _ -> true | _ -> false - -(* Destructs a constant *) -let destConst c = match kind_of_term c with - | Const kn -> kn - | _ -> raise DestKO - -let isConst c = match kind_of_term c with Const _ -> true | _ -> false - -(* Destructs an existential variable *) -let destEvar c = match kind_of_term c with - | Evar (kn, a as r) -> r - | _ -> raise DestKO - -(* Destructs a (co)inductive type named kn *) -let destInd c = match kind_of_term c with - | Ind (kn, a as r) -> r - | _ -> raise DestKO - -(* Destructs a constructor *) -let destConstruct c = match kind_of_term c with - | Construct (kn, a as r) -> r - | _ -> raise DestKO - -let isConstruct c = match kind_of_term c with Construct _ -> true | _ -> false - -(* Destructs a term <p>Case c of lc1 | lc2 .. | lcn end *) -let destCase c = match kind_of_term c with - | Case (ci,p,c,v) -> (ci,p,c,v) - | _ -> raise DestKO - -let isCase c = match kind_of_term c with Case _ -> true | _ -> false - -let isProj c = match kind_of_term c with Proj _ -> true | _ -> false - -let destProj c = match kind_of_term c with - | Proj (p, c) -> (p, c) - | _ -> raise DestKO - -let destFix c = match kind_of_term c with - | Fix fix -> fix - | _ -> raise DestKO - -let isFix c = match kind_of_term c with Fix _ -> true | _ -> false - -let destCoFix c = match kind_of_term c with - | CoFix cofix -> cofix - | _ -> raise DestKO - -let isCoFix c = match kind_of_term c with CoFix _ -> true | _ -> false +let isApp = isApp +let destConst = destConst +let isConst = isConst +let destEvar = destEvar +let destInd = destInd +let destConstruct = destConstruct +let isConstruct = isConstruct +let destCase = destCase +let isCase = isCase +let isProj = isProj +let destProj = destProj +let destFix = destFix +let isFix = isFix +let destCoFix = destCoFix +let isCoFix = isCoFix (******************************************************************) (* Flattening and unflattening of embedded applications and casts *) diff --git a/kernel/term.mli b/kernel/term.mli index 33c6b0b08d..f5cb72f4e8 100644 --- a/kernel/term.mli +++ b/kernel/term.mli @@ -16,90 +16,133 @@ open Constr *) +exception DestKO +[@@ocaml.deprecated "Alias for [Constr.DestKO]"] + (** {5 Simple term case analysis. } *) val isRel : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isRel]"] val isRelN : int -> constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isRelN]"] val isVar : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isVar]"] val isVarId : Id.t -> constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isVarId]"] val isInd : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isInd]"] val isEvar : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isEvar]"] val isMeta : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isMeta]"] val isEvar_or_Meta : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isEvar_or_Meta]"] val isSort : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isSort]"] val isCast : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isCast]"] val isApp : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isApp]"] val isLambda : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isLambda]"] val isLetIn : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isletIn]"] val isProd : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isProp]"] val isConst : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isConst]"] val isConstruct : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isConstruct]"] val isFix : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isFix]"] val isCoFix : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isCoFix]"] val isCase : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isCase]"] val isProj : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isProj]"] val is_Prop : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.is_Prop]"] val is_Set : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.is_Set]"] val isprop : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.isprop]"] val is_Type : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.is_Type]"] val iskind : constr -> bool +[@@ocaml.deprecated "Alias for [Constr.is_kind]"] val is_small : Sorts.t -> bool +[@@ocaml.deprecated "Alias for [Constr.is_small]"] (** {5 Term destructors } *) (** Destructor operations are partial functions and @raise DestKO if the term has not the expected form. *) -exception DestKO - (** Destructs a de Bruijn index *) val destRel : constr -> int +[@@ocaml.deprecated "Alias for [Constr.destRel]"] (** Destructs an existential variable *) val destMeta : constr -> metavariable +[@@ocaml.deprecated "Alias for [Constr.destMeta]"] (** Destructs a variable *) val destVar : constr -> Id.t +[@@ocaml.deprecated "Alias for [Constr.destVar]"] (** Destructs a sort. [is_Prop] recognizes the sort {% \textsf{%}Prop{% }%}, whether [isprop] recognizes both {% \textsf{%}Prop{% }%} and {% \textsf{%}Set{% }%}. *) val destSort : constr -> Sorts.t +[@@ocaml.deprecated "Alias for [Constr.destSort]"] (** Destructs a casted term *) val destCast : constr -> constr * cast_kind * constr +[@@ocaml.deprecated "Alias for [Constr.destCast]"] (** Destructs the product {% $ %}(x:t_1)t_2{% $ %} *) val destProd : types -> Name.t * types * types +[@@ocaml.deprecated "Alias for [Constr.destProd]"] (** Destructs the abstraction {% $ %}[x:t_1]t_2{% $ %} *) val destLambda : constr -> Name.t * types * constr +[@@ocaml.deprecated "Alias for [Constr.destLambda]"] (** Destructs the let {% $ %}[x:=b:t_1]t_2{% $ %} *) val destLetIn : constr -> Name.t * constr * types * constr +[@@ocaml.deprecated "Alias for [Constr.destLetIn]"] (** Destructs an application *) val destApp : constr -> constr * constr array +[@@ocaml.deprecated "Alias for [Constr.destApp]"] (** Obsolete synonym of destApp *) val destApplication : constr -> constr * constr array +[@@ocaml.deprecated "Alias for [Constr.destApplication]"] (** Decompose any term as an applicative term; the list of args can be empty *) val decompose_app : constr -> constr * constr list +[@@ocaml.deprecated "Alias for [Constr.decompose_app]"] (** Same as [decompose_app], but returns an array. *) val decompose_appvect : constr -> constr * constr array +[@@ocaml.deprecated "Alias for [Constr.decompose_appvect]"] (** Destructs a constant *) -val destConst : constr -> Constant.t puniverses +val destConst : constr -> Constant.t Univ.puniverses +[@@ocaml.deprecated "Alias for [Constr.destConst]"] (** Destructs an existential variable *) val destEvar : constr -> existential +[@@ocaml.deprecated "Alias for [Constr.destEvar]"] (** Destructs a (co)inductive type *) -val destInd : constr -> inductive puniverses +val destInd : constr -> inductive Univ.puniverses +[@@ocaml.deprecated "Alias for [Constr.destInd]"] (** Destructs a constructor *) -val destConstruct : constr -> constructor puniverses +val destConstruct : constr -> constructor Univ.puniverses +[@@ocaml.deprecated "Alias for [Constr.destConstruct]"] (** Destructs a [match c as x in I args return P with ... | Ci(...yij...) => ti | ... end] (or [let (..y1i..) := c as x in I args @@ -107,9 +150,11 @@ return P in t1], or [if c then t1 else t2]) @return [(info,c,fun args x => P,[|...|fun yij => ti| ...|])] where [info] is pretty-printing information *) val destCase : constr -> case_info * constr * constr * constr array +[@@ocaml.deprecated "Alias for [Constr.destCase]"] (** Destructs a projection *) val destProj : constr -> projection * constr +[@@ocaml.deprecated "Alias for [Constr.destProj]"] (** Destructs the {% $ %}i{% $ %}th function of the block [Fixpoint f{_ 1} ctx{_ 1} = b{_ 1} @@ -119,8 +164,10 @@ val destProj : constr -> projection * constr where the length of the {% $ %}j{% $ %}th context is {% $ %}ij{% $ %}. *) val destFix : constr -> fixpoint +[@@ocaml.deprecated "Alias for [Constr.destFix]"] val destCoFix : constr -> cofixpoint +[@@ocaml.deprecated "Alias for [Constr.destCoFix]"] (** {5 Derived constructors} *) @@ -360,11 +407,11 @@ val mkInd : inductive -> constr [@@ocaml.deprecated "Alias for Constr"] val mkConstruct : constructor -> constr [@@ocaml.deprecated "Alias for Constr"] -val mkConstU : Constant.t puniverses -> constr +val mkConstU : Constant.t Univ.puniverses -> constr [@@ocaml.deprecated "Alias for Constr"] -val mkIndU : inductive puniverses -> constr +val mkIndU : inductive Univ.puniverses -> constr [@@ocaml.deprecated "Alias for Constr"] -val mkConstructU : constructor puniverses -> constr +val mkConstructU : constructor Univ.puniverses -> constr [@@ocaml.deprecated "Alias for Constr"] val mkConstructUi : (pinductive * int) -> constr [@@ocaml.deprecated "Alias for Constr"] @@ -414,9 +461,12 @@ val map_constr_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr [@@ocaml.deprecated "Alias for [Constr.map_with_binders]"] -val map_puniverses : ('a -> 'b) -> 'a puniverses -> 'b puniverses +val map_puniverses : ('a -> 'b) -> 'a Univ.puniverses -> 'b Univ.puniverses +[@@ocaml.deprecated "Alias for [Constr.map_puniverses]"] val univ_of_sort : Sorts.t -> Univ.Universe.t +[@@ocaml.deprecated "Alias for [Sorts.univ_of_sort]"] val sort_of_univ : Univ.Universe.t -> Sorts.t +[@@ocaml.deprecated "Alias for [Sorts.sort_of_univ]"] val iter_constr : (constr -> unit) -> constr -> unit [@@ocaml.deprecated "Alias for [Constr.iter]"] @@ -447,7 +497,7 @@ type sorts = Sorts.t = type sorts_family = Sorts.family = InProp | InSet | InType [@@ocaml.deprecated "Alias for Sorts.family"] -type 'a puniverses = 'a Constr.puniverses +type 'a puniverses = 'a Univ.puniverses [@@ocaml.deprecated "Alias for Constr.puniverses"] (** Simply type aliases *) @@ -457,8 +507,8 @@ type pinductive = Constr.pinductive [@@ocaml.deprecated "Alias for Constr.pinductive"] type pconstructor = Constr.pconstructor [@@ocaml.deprecated "Alias for Constr.pconstructor"] -type existential_key = Constr.existential_key -[@@ocaml.deprecated "Alias for Constr.existential_key"] +type existential_key = Evar.t +[@@ocaml.deprecated "Alias for Evar.t"] type existential = Constr.existential [@@ocaml.deprecated "Alias for Constr.existential"] type metavariable = Constr.metavariable diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 4617f2d5fa..70dd6438d4 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -125,11 +125,10 @@ let inline_side_effects env body ctx side_eff = | _ -> assert false in match cb.const_universes with - | Monomorphic_const cnstctx -> + | Monomorphic_const univs -> (** Abstract over the term at the top of the proof *) let ty = cb.const_type in let subst = Cmap_env.add c (Inr var) subst in - let univs = Univ.ContextSet.of_context cnstctx in let ctx = Univ.ContextSet.union ctx univs in (subst, var + 1, ctx, (cname c, b, ty, opaque) :: args) | Polymorphic_const auctx -> @@ -228,19 +227,25 @@ let feedback_completion_typecheck = Option.iter (fun state_id -> feedback ~id:state_id Feedback.Complete) -let abstract_constant_universes abstract uctx = - if not abstract then +let abstract_constant_universes abstract = function + | Monomorphic_const_entry uctx -> Univ.empty_level_subst, Monomorphic_const uctx - else - let sbst, auctx = Univ.abstract_universes uctx in - sbst, Polymorphic_const auctx + | Polymorphic_const_entry uctx -> + if not abstract then + Univ.empty_level_subst, Monomorphic_const (Univ.ContextSet.of_context uctx) + else + let sbst, auctx = Univ.abstract_universes uctx in + sbst, Polymorphic_const auctx let infer_declaration (type a) ~(trust : a trust) env kn (dcl : a constant_entry) = match dcl with - | ParameterEntry (ctx,poly,(t,uctx),nl) -> - let env = push_context ~strict:(not poly) uctx env in + | ParameterEntry (ctx,(t,uctx),nl) -> + let env = match uctx with + | Monomorphic_const_entry uctx -> push_context_set ~strict:true uctx env + | Polymorphic_const_entry uctx -> push_context ~strict:false uctx env + in let j = infer env t in - let abstract = poly && not (Option.is_empty kn) in + let abstract = not (Option.is_empty kn) in let usubst, univs = abstract_constant_universes abstract uctx in @@ -262,7 +267,7 @@ let infer_declaration (type a) ~(trust : a trust) env kn (dcl : a constant_entry | DefinitionEntry ({ const_entry_type = Some typ; const_entry_opaque = true; const_entry_universes = Monomorphic_const_entry univs } as c) -> - let env = push_context ~strict:true univs env in + let env = push_context_set ~strict:true univs env in let { const_entry_body = body; const_entry_feedback = feedback_id } = c in let tyj = infer_type env typ in let proofterm = @@ -301,21 +306,22 @@ let infer_declaration (type a) ~(trust : a trust) env kn (dcl : a constant_entry let { const_entry_type = typ; const_entry_opaque = opaque } = c in let { const_entry_body = body; const_entry_feedback = feedback_id } = c in let (body, ctx), side_eff = Future.join body in - let poly, univs = match c.const_entry_universes with + let poly, univsctx = match c.const_entry_universes with | Monomorphic_const_entry univs -> false, univs - | Polymorphic_const_entry univs -> true, univs + | Polymorphic_const_entry univs -> true, Univ.ContextSet.of_context univs in - let univsctx = Univ.ContextSet.of_context univs in let ctx = Univ.ContextSet.union univsctx ctx in let body, ctx, _ = match trust with | Pure -> body, ctx, [] | SideEffects _ -> inline_side_effects env body ctx side_eff in let env = push_context_set ~strict:(not poly) ctx env in - let abstract = poly && not (Option.is_empty kn) in - let usubst, univs = - abstract_constant_universes abstract (Univ.ContextSet.to_context ctx) - in + let abstract = not (Option.is_empty kn) in + let ctx = if poly + then Polymorphic_const_entry (Univ.ContextSet.to_context ctx) + else Monomorphic_const_entry ctx + in + let usubst, univs = abstract_constant_universes abstract ctx in let j = infer env body in let typ = match typ with | None -> @@ -556,7 +562,7 @@ let export_side_effects mb env ce = let env = Environ.add_constant kn cb env in match cb.const_universes with | Monomorphic_const ctx -> - Environ.push_context ~strict:true ctx env + Environ.push_context_set ~strict:true ctx env | Polymorphic_const _ -> env end | kn, cb, `Opaque(_, ctx), _ -> @@ -564,7 +570,7 @@ let export_side_effects mb env ce = let env = Environ.add_constant kn cb env in match cb.const_universes with | Monomorphic_const cstctx -> - let env = Environ.push_context ~strict:true cstctx env in + let env = Environ.push_context_set ~strict:true cstctx env in Environ.push_context_set ~strict:true ctx env | Polymorphic_const _ -> env end diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli index 9b35bfc6e8..55da4197e2 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -19,7 +19,7 @@ type _ trust = | SideEffects : structure_body -> side_effects trust val translate_local_def : 'a trust -> env -> Id.t -> 'a definition_entry -> - constant_def * types * Univ.UContext.t + constant_def * types * Univ.ContextSet.t val translate_local_assum : env -> types -> types diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml index 3a1f2ae00b..781c6bfbcd 100644 --- a/kernel/type_errors.ml +++ b/kernel/type_errors.ml @@ -59,7 +59,7 @@ type ('constr, 'types) ptype_error = | IllFormedRecBody of 'constr pguard_error * Name.t array * int * env * ('constr, 'types) punsafe_judgment array | IllTypedRecBody of int * Name.t array * ('constr, 'types) punsafe_judgment array * 'types array - | UnsatisfiedConstraints of Univ.constraints + | UnsatisfiedConstraints of Univ.Constraint.t type type_error = (constr, types) ptype_error diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli index e4fa65686e..72861f6e48 100644 --- a/kernel/type_errors.mli +++ b/kernel/type_errors.mli @@ -60,7 +60,7 @@ type ('constr, 'types) ptype_error = | IllFormedRecBody of 'constr pguard_error * Name.t array * int * env * ('constr, 'types) punsafe_judgment array | IllTypedRecBody of int * Name.t array * ('constr, 'types) punsafe_judgment array * 'types array - | UnsatisfiedConstraints of Univ.constraints + | UnsatisfiedConstraints of Univ.Constraint.t type type_error = (constr, types) ptype_error @@ -105,4 +105,4 @@ val error_ill_typed_rec_body : val error_elim_explain : Sorts.family -> Sorts.family -> arity_error -val error_unsatisfied_constraints : env -> Univ.constraints -> 'a +val error_unsatisfied_constraints : env -> Univ.Constraint.t -> 'a diff --git a/kernel/typeops.mli b/kernel/typeops.mli index 3aaad5877b..5584b6ab46 100644 --- a/kernel/typeops.mli +++ b/kernel/typeops.mli @@ -7,8 +7,8 @@ (************************************************************************) open Names -open Univ open Constr +open Univ open Environ open Entries diff --git a/kernel/uGraph.mli b/kernel/uGraph.mli index b95388ed03..f71d83d853 100644 --- a/kernel/uGraph.mli +++ b/kernel/uGraph.mli @@ -35,10 +35,10 @@ val check_eq_instances : Instance.t check_function constraints are not satisfiable. *) val enforce_constraint : univ_constraint -> t -> t -val merge_constraints : constraints -> t -> t +val merge_constraints : Constraint.t -> t -> t val check_constraint : t -> univ_constraint -> bool -val check_constraints : constraints -> t -> bool +val check_constraints : Constraint.t -> t -> bool (** Adds a universe to the graph, ensuring it is >= or > Set. @raises AlreadyDeclared if the level is already declared in the graph. *) @@ -57,7 +57,7 @@ val empty_universes : t val sort_universes : t -> t -val constraints_of_universes : t -> constraints +val constraints_of_universes : t -> Constraint.t val check_subtype : AUContext.t check_function (** [check_subtype univ ctx1 ctx2] checks whether [ctx2] is an instance of diff --git a/kernel/univ.ml b/kernel/univ.ml index 7fe4f82748..8cf9028fb1 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -192,6 +192,10 @@ module Level = struct let make m n = make (Level (n, Names.DirPath.hcons m)) + let name u = + match data u with + | Level (n, d) -> Some (d, n) + | _ -> None end (** Level maps *) @@ -337,19 +341,16 @@ struct returning [SuperSame] if they refer to the same level at potentially different increments or [SuperDiff] if they are different. The booleans indicate if the left expression is "smaller" than the right one in both cases. *) - let super (u,n as x) (v,n' as y) = + let super (u,n) (v,n') = let cmp = Level.compare u v in if Int.equal cmp 0 then SuperSame (n < n') else - match x, y with - | (l,0), (l',0) -> - let open RawLevel in - (match Level.data l, Level.data l' with - | Prop, Prop -> SuperSame false - | Prop, _ -> SuperSame true - | _, Prop -> SuperSame false - | _, _ -> SuperDiff cmp) - | _, _ -> SuperDiff cmp + let open RawLevel in + match Level.data u, n, Level.data v, n' with + | Prop, _, Prop, _ -> SuperSame (n < n') + | Prop, 0, _, _ -> SuperSame true + | _, _, Prop, 0 -> SuperSame false + | _, _, _, _ -> SuperDiff cmp let to_string (v, n) = if Int.equal n 0 then Level.to_string v @@ -499,6 +500,7 @@ struct let smartmap = List.smartmap + let map = List.map end type universe = Universe.t @@ -1053,6 +1055,7 @@ struct let constraints (univs, cst) = cst let levels (univs, cst) = univs + let size (univs,_) = LSet.cardinal univs end type universe_context_set = ContextSet.t diff --git a/kernel/univ.mli b/kernel/univ.mli index 8d46a8beef..4593944395 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -45,6 +45,8 @@ sig val var : int -> t val var_index : t -> int option + + val name : t -> (Names.DirPath.t * int) option end type universe_level = Level.t @@ -121,6 +123,8 @@ sig val exists : (Level.t * int -> bool) -> t -> bool val for_all : (Level.t * int -> bool) -> t -> bool + + val map : (Level.t * int -> 'a) -> t -> 'a list end type universe = Universe.t @@ -165,20 +169,20 @@ module Constraint : sig end type constraints = Constraint.t +[@@ocaml.deprecated "Use Constraint.t"] -val empty_constraint : constraints -val union_constraint : constraints -> constraints -> constraints -val eq_constraint : constraints -> constraints -> bool +val empty_constraint : Constraint.t +val union_constraint : Constraint.t -> Constraint.t -> Constraint.t +val eq_constraint : Constraint.t -> Constraint.t -> bool -(** A value with universe constraints. *) -type 'a constrained = 'a * constraints +(** A value with universe Constraint.t. *) +type 'a constrained = 'a * Constraint.t (** Constrained *) -val constraints_of : 'a constrained -> constraints - -(** Enforcing constraints. *) +val constraints_of : 'a constrained -> Constraint.t -type 'a constraint_function = 'a -> 'a -> constraints -> constraints +(** Enforcing Constraint.t. *) +type 'a constraint_function = 'a -> 'a -> Constraint.t -> Constraint.t val enforce_eq : Universe.t constraint_function val enforce_leq : Universe.t constraint_function @@ -195,7 +199,7 @@ val enforce_leq_level : Level.t constraint_function universes in the path are canonical. Note that each step does not necessarily correspond to an actual constraint, but reflect how the system stores the graph and may result from combination of several - constraints... + Constraint.t... *) type explanation = (constraint_type * Universe.t) list type univ_inconsistency = constraint_type * Universe.t * Universe.t * explanation option @@ -290,8 +294,8 @@ val in_punivs : 'a -> 'a puniverses val eq_puniverses : ('a -> 'a -> bool) -> 'a puniverses -> 'a puniverses -> bool -(** A vector of universe levels with universe constraints, - representiong local universe variables and associated constraints *) +(** A vector of universe levels with universe Constraint.t, + representiong local universe variables and associated Constraint.t *) module UContext : sig @@ -303,14 +307,14 @@ sig val is_empty : t -> bool val instance : t -> Instance.t - val constraints : t -> constraints + val constraints : t -> Constraint.t - val dest : t -> Instance.t * constraints + val dest : t -> Instance.t * Constraint.t (** Keeps the order of the instances *) val union : t -> t -> t - (* the number of universes in the context *) + (** the number of universes in the context *) val size : t -> int end @@ -324,7 +328,7 @@ sig val repr : t -> UContext.t (** [repr ctx] is [(Var(0), ... Var(n-1) |= cstr] where [n] is the length of - the context and [cstr] the abstracted constraints. *) + the context and [cstr] the abstracted Constraint.t. *) val empty : t val is_empty : t -> bool @@ -338,7 +342,7 @@ sig val union : t -> t -> t val instantiate : Instance.t -> t -> Constraint.t - (** Generate the set of instantiated constraints **) + (** Generate the set of instantiated Constraint.t **) end @@ -346,14 +350,14 @@ type abstract_universe_context = AUContext.t [@@ocaml.deprecated "Use AUContext.t"] (** Universe info for inductive types: A context of universe levels - with universe constraints, representing local universe variables - and constraints, together with a context of universe levels with - universe constraints, representing conditions for subtyping used + with universe Constraint.t, representing local universe variables + and Constraint.t, together with a context of universe levels with + universe Constraint.t, representing conditions for subtyping used for inductive types. This data structure maintains the invariant that the context for - subtyping constraints is exactly twice as big as the context for - universe constraints. *) + subtyping Constraint.t is exactly twice as big as the context for + universe Constraint.t. *) module CumulativityInfo : sig type t @@ -366,7 +370,7 @@ sig val univ_context : t -> UContext.t val subtyp_context : t -> UContext.t - (** This function takes a universe context representing constraints + (** This function takes a universe context representing Constraint.t of an inductive and a Instance.t of fresh universe names for the subtyping (with the same length as the context in the given universe context) and produces a UInfoInd.t that with the @@ -413,7 +417,7 @@ sig val diff : t -> t -> t val add_universe : Level.t -> t -> t - val add_constraints : constraints -> t -> t + val add_constraints : Constraint.t -> t -> t val add_instance : Instance.t -> t -> t (** Arbitrary choice of linear order of the variables *) @@ -421,11 +425,14 @@ sig val to_context : t -> UContext.t val of_context : UContext.t -> t - val constraints : t -> constraints + val constraints : t -> Constraint.t val levels : t -> LSet.t + + (** the number of universes in the context *) + val size : t -> int end -(** A set of universes with universe constraints. +(** A set of universes with universe Constraint.t. We linearize the set to a list after typechecking. Beware, representation could change. *) @@ -442,7 +449,7 @@ val is_empty_level_subst : universe_level_subst -> bool (** Substitution of universes. *) val subst_univs_level_level : universe_level_subst -> Level.t -> Level.t val subst_univs_level_universe : universe_level_subst -> Universe.t -> Universe.t -val subst_univs_level_constraints : universe_level_subst -> constraints -> constraints +val subst_univs_level_constraints : universe_level_subst -> Constraint.t -> Constraint.t val subst_univs_level_abstract_universe_context : universe_level_subst -> AUContext.t -> AUContext.t val subst_univs_level_instance : universe_level_subst -> Instance.t -> Instance.t @@ -454,7 +461,7 @@ val is_empty_subst : universe_subst -> bool val make_subst : universe_subst -> universe_subst_fn val subst_univs_universe : universe_subst_fn -> Universe.t -> Universe.t -val subst_univs_constraints : universe_subst_fn -> constraints -> constraints +val subst_univs_constraints : universe_subst_fn -> Constraint.t -> Constraint.t (** Substitution of instances *) val subst_instance_instance : Instance.t -> Instance.t -> Instance.t @@ -472,7 +479,7 @@ val make_abstract_instance : AUContext.t -> Instance.t (** {6 Pretty-printing of universes. } *) val pr_constraint_type : constraint_type -> Pp.t -val pr_constraints : (Level.t -> Pp.t) -> constraints -> Pp.t +val pr_constraints : (Level.t -> Pp.t) -> Constraint.t -> Pp.t val pr_universe_context : (Level.t -> Pp.t) -> UContext.t -> Pp.t val pr_cumulativity_info : (Level.t -> Pp.t) -> CumulativityInfo.t -> Pp.t val pr_abstract_universe_context : (Level.t -> Pp.t) -> AUContext.t -> Pp.t @@ -487,7 +494,7 @@ val pr_universe_subst : universe_subst -> Pp.t (** {6 Hash-consing } *) val hcons_univ : Universe.t -> Universe.t -val hcons_constraints : constraints -> constraints +val hcons_constraints : Constraint.t -> Constraint.t val hcons_universe_set : LSet.t -> LSet.t val hcons_universe_context : UContext.t -> UContext.t val hcons_abstract_universe_context : AUContext.t -> AUContext.t @@ -508,6 +515,6 @@ val eq_levels : Level.t -> Level.t -> bool val equal_universes : Universe.t -> Universe.t -> bool [@@ocaml.deprecated "Use Universe.equal"] -(** Universes of constraints *) -val universes_of_constraints : constraints -> LSet.t +(** Universes of Constraint.t *) +val universes_of_constraints : Constraint.t -> LSet.t [@@ocaml.deprecated "Use Constraint.universes_of"] diff --git a/kernel/vconv.ml b/kernel/vconv.ml index 0e452621c8..578a893718 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -93,7 +93,7 @@ and conv_atom env pb k a1 stk1 a2 stk2 cu = let mib = Environ.lookup_mind mi env in let ulen = match mib.Declarations.mind_universes with - | Declarations.Monomorphic_ind ctx -> Univ.UContext.size ctx + | Declarations.Monomorphic_ind ctx -> Univ.ContextSet.size ctx | Declarations.Polymorphic_ind auctx -> Univ.AUContext.size auctx | Declarations.Cumulative_ind cumi -> Univ.AUContext.size (Univ.ACumulativityInfo.univ_context cumi) diff --git a/lib/cMap.ml b/lib/cMap.ml index 0ecb40209c..b4c4aedd0e 100644 --- a/lib/cMap.ml +++ b/lib/cMap.ml @@ -26,7 +26,7 @@ sig include CSig.MapS module Set : CSig.SetS with type elt = key val get : key -> 'a t -> 'a - val update : key -> 'a -> 'a t -> 'a t + val set : key -> 'a -> 'a t -> 'a t val modify : key -> (key -> 'a -> 'a) -> 'a t -> 'a t val domain : 'a t -> Set.t val bind : (key -> 'a) -> Set.t -> 'a t @@ -50,7 +50,7 @@ end module MapExt (M : Map.OrderedType) : sig type 'a map = 'a Map.Make(M).t - val update : M.t -> 'a -> 'a map -> 'a map + val set : M.t -> 'a -> 'a map -> 'a map val modify : M.t -> (M.t -> 'a -> 'a) -> 'a map -> 'a map val domain : 'a map -> Set.Make(M).t val bind : (M.t -> 'a) -> Set.Make(M).t -> 'a map @@ -93,19 +93,19 @@ struct let set_prj : set -> _set = Obj.magic let set_inj : _set -> set = Obj.magic - let rec update k v (s : 'a map) : 'a map = match map_prj s with + let rec set k v (s : 'a map) : 'a map = match map_prj s with | MEmpty -> raise Not_found | MNode (l, k', v', r, h) -> let c = M.compare k k' in if c < 0 then - let l' = update k v l in + let l' = set k v l in if l == l' then s else map_inj (MNode (l', k', v', r, h)) else if c = 0 then if v' == v then s else map_inj (MNode (l, k', v, r, h)) else - let r' = update k v r in + let r' = set k v r in if r == r' then s else map_inj (MNode (l, k', v', r', h)) diff --git a/lib/cMap.mli b/lib/cMap.mli index f65036139b..5e65bd200a 100644 --- a/lib/cMap.mli +++ b/lib/cMap.mli @@ -34,7 +34,7 @@ sig val get : key -> 'a t -> 'a (** Same as {!find} but fails an assertion instead of raising [Not_found] *) - val update : key -> 'a -> 'a t -> 'a t + val set : key -> 'a -> 'a t -> 'a t (** Same as [add], but expects the key to be present, and thus faster. @raise Not_found when the key is unbound in the map. *) diff --git a/lib/cSig.mli b/lib/cSig.mli index 6910cbbf03..32e9d2af0c 100644 --- a/lib/cSig.mli +++ b/lib/cSig.mli @@ -56,6 +56,12 @@ sig val is_empty: 'a t -> bool val mem: key -> 'a t -> bool val add: key -> 'a -> 'a t -> 'a t + (* when Coq requires OCaml 4.06 or later, can add: + + val update : key -> ('a option -> 'a option) -> 'a t -> 'a t + + allowing Coq to use OCaml's "update" + *) val singleton: key -> 'a -> 'a t val remove: key -> 'a t -> 'a t val merge: diff --git a/lib/cUnix.ml b/lib/cUnix.ml index 867f86a746..34fb660db4 100644 --- a/lib/cUnix.ml +++ b/lib/cUnix.ml @@ -14,6 +14,11 @@ type load_path = physical_path list let physical_path_of_string s = s let string_of_physical_path p = p +let escaped_string_of_physical_path p = + (* We assume a reasonable-enough path (typically utf8) and prevents + the presence of space; other escapings might be useful... *) + if String.contains p ' ' then "\"" ^ p ^ "\"" else p + let path_to_list p = let sep = Str.regexp (if Sys.os_type = "Win32" then ";" else ":") in Str.split sep p diff --git a/lib/cUnix.mli b/lib/cUnix.mli index a394814041..d08dc4c403 100644 --- a/lib/cUnix.mli +++ b/lib/cUnix.mli @@ -14,9 +14,12 @@ type load_path = physical_path list val physical_path_of_string : string -> physical_path val string_of_physical_path : physical_path -> string +(** Escape what has to be escaped (e.g. surround with quotes if with spaces) *) +val escaped_string_of_physical_path : physical_path -> string + val canonical_path_name : string -> string -(** remove all initial "./" in a path *) +(** Remove all initial "./" in a path *) val remove_path_dot : string -> string (** If a path [p] starts with the current directory $PWD then @@ -61,6 +64,6 @@ val sys_command : string -> string list -> Unix.process_status val waitpid_non_intr : int -> Unix.process_status -(** checks if two file names refer to the same (existing) file *) +(** Check if two file names refer to the same (existing) file *) val same_file : string -> string -> bool diff --git a/lib/control.ml b/lib/control.ml index f5d7df204e..d936d7557b 100644 --- a/lib/control.ml +++ b/lib/control.ml @@ -26,7 +26,7 @@ let check_for_interrupt () = end (** This function does not work on windows, sigh... *) -let unix_timeout n f e = +let unix_timeout n f x e = let timeout_handler _ = raise e in let psh = Sys.signal Sys.sigalrm (Sys.Signal_handle timeout_handler) in let _ = Unix.alarm n in @@ -35,7 +35,7 @@ let unix_timeout n f e = Sys.set_signal Sys.sigalrm psh in try - let res = f () in + let res = f x in restore_timeout (); res with e -> @@ -43,7 +43,7 @@ let unix_timeout n f e = restore_timeout (); Exninfo.iraise e -let windows_timeout n f e = +let windows_timeout n f x e = let killed = ref false in let exited = ref false in let thread init = @@ -60,7 +60,7 @@ let windows_timeout n f e = let init = Unix.gettimeofday () in let _id = Thread.create thread init in try - let res = f () in + let res = f x in let () = killed := true in let cur = Unix.gettimeofday () in (** The thread did not interrupt, but the computation took longer than @@ -80,12 +80,10 @@ let windows_timeout n f e = let e = Backtrace.add_backtrace e in Exninfo.iraise e -type timeout = { timeout : 'a. int -> (unit -> 'a) -> exn -> 'a } +type timeout = { timeout : 'a 'b. int -> ('a -> 'b) -> 'a -> exn -> 'b } let timeout_fun = match Sys.os_type with -| "Unix" | "Cygwin" -> ref { timeout = unix_timeout } -| _ -> ref { timeout = windows_timeout } +| "Unix" | "Cygwin" -> { timeout = unix_timeout } +| _ -> { timeout = windows_timeout } -let set_timeout f = timeout_fun := f - -let timeout n f e = !timeout_fun.timeout n f e +let timeout n f e = timeout_fun.timeout n f e diff --git a/lib/control.mli b/lib/control.mli index 337cdf67b0..f6c63ffb34 100644 --- a/lib/control.mli +++ b/lib/control.mli @@ -16,11 +16,6 @@ val check_for_interrupt : unit -> unit (** Use this function as a potential yield function. If {!interrupt} has been set, il will raise [Sys.Break]. *) -val timeout : int -> (unit -> 'a) -> exn -> 'a -(** [timeout n f e] tries to compute [f], and if it fails to do so before [n] - seconds, it raises [e] instead. *) - -type timeout = { timeout : 'a. int -> (unit -> 'a) -> exn -> 'a } - -val set_timeout : timeout -> unit -(** Set a particular timeout function. *) +val timeout : int -> ('a -> 'b) -> 'a -> exn -> 'b +(** [timeout n f x e] tries to compute [f x], and if it fails to do so + before [n] seconds, it raises [e] instead. *) diff --git a/lib/dyn.ml b/lib/dyn.ml index 83e673d2c0..64535d35f6 100644 --- a/lib/dyn.ml +++ b/lib/dyn.ml @@ -55,6 +55,8 @@ sig include PreS module Easy : sig + + val make_dyn_tag : string -> ('a -> t) * (t -> 'a) * 'a tag val make_dyn : string -> ('a -> t) * (t -> 'a) val inj : 'a -> 'a tag -> t val prj : t -> 'a tag -> 'a option @@ -129,8 +131,9 @@ end include Self module Easy = struct + (* now tags are opaque, we can do the trick *) -let make_dyn (s : string) = +let make_dyn_tag (s : string) = (fun (type a) (tag : a tag) -> let infun : (a -> t) = fun x -> Dyn (tag, x) in let outfun : (t -> a) = fun (Dyn (t, x)) -> @@ -138,9 +141,12 @@ let make_dyn (s : string) = | None -> assert false | Some CSig.Refl -> x in - (infun, outfun)) + infun, outfun, tag) (create s) +let make_dyn (s : string) = + let inf, outf, _ = make_dyn_tag s in inf, outf + let inj x tag = Dyn(tag,x) let prj : type a. t -> a tag -> a option = fun (Dyn(tag',x)) tag -> diff --git a/lib/dyn.mli b/lib/dyn.mli index e0e1a9d140..2206394e2d 100644 --- a/lib/dyn.mli +++ b/lib/dyn.mli @@ -53,6 +53,7 @@ val dump : unit -> (int * string) list module Easy : sig (* To create a dynamic type on the fly *) + val make_dyn_tag : string -> ('a -> t) * (t -> 'a) * 'a tag val make_dyn : string -> ('a -> t) * (t -> 'a) (* For types declared with the [create] function above *) diff --git a/lib/flags.ml b/lib/flags.ml index 323b5492dd..ddc8f84825 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -6,13 +6,17 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -let with_option o f x = - let old = !o in o:=true; - try let r = f x in if !o = true then o := old; r - with reraise -> - let reraise = Backtrace.add_backtrace reraise in - let () = o := old in - Exninfo.iraise reraise +let with_modified_ref r nf f x = + let old_ref = !r in r := nf !r; + try let res = f x in r := old_ref; res + with reraise -> + let reraise = Backtrace.add_backtrace reraise in + r := old_ref; + Exninfo.iraise reraise + +let with_option o f x = with_modified_ref o (fun _ -> true) f x +let without_option o f x = with_modified_ref o (fun _ -> false) f x +let with_extra_values o l f x = with_modified_ref o (fun ol -> ol@l) f x let with_options ol f x = let vl = List.map (!) ol in @@ -25,22 +29,6 @@ let with_options ol f x = let () = List.iter2 (:=) ol vl in Exninfo.iraise reraise -let without_option o f x = - let old = !o in o:=false; - try let r = f x in if !o = false then o := old; r - with reraise -> - let reraise = Backtrace.add_backtrace reraise in - let () = o := old in - Exninfo.iraise reraise - -let with_extra_values o l f x = - let old = !o in o:=old@l; - try let r = f x in o := old; r - with reraise -> - let reraise = Backtrace.add_backtrace reraise in - let () = o := old in - Exninfo.iraise reraise - let boot = ref false let record_aux_file = ref false diff --git a/lib/flags.mli b/lib/flags.mli index 0ff3e0a81d..c4afb83186 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -110,6 +110,15 @@ val warn : bool ref val make_warn : bool -> unit val if_warn : ('a -> unit) -> 'a -> unit +(** [with_modified_ref r nf f x] Temporarily modify a reference in the + call to [f x] . Be very careful with these functions, it is very + easy to fall in the typical problem with effects: + + with_modified_ref r nf f x y != with_modified_ref r nf (f x) y + +*) +val with_modified_ref : 'c ref -> ('c -> 'c) -> ('a -> 'b) -> 'a -> 'b + (** Temporarily activate an option (to activate option [o] on [f x y z], use [with_option o (f x y) z]) *) val with_option : bool ref -> ('a -> 'b) -> 'a -> 'b diff --git a/lib/hMap.ml b/lib/hMap.ml index c69efdb711..37079af783 100644 --- a/lib/hMap.ml +++ b/lib/hMap.ml @@ -47,7 +47,7 @@ struct try let m = Int.Map.find h s in let m = Set.add x m in - Int.Map.update h m s + Int.Map.set h m s with Not_found -> let m = Set.singleton x in Int.Map.add h m s @@ -65,7 +65,7 @@ struct if Set.is_empty m then Int.Map.remove h s else - Int.Map.update h m s + Int.Map.set h m s with Not_found -> s let height s = Int.Map.height s @@ -135,7 +135,7 @@ struct let s' = Int.Map.find h accu in let si = Set.filter (fun e -> not (Set.mem e s)) s' in if Set.is_empty si then Int.Map.remove h accu - else Int.Map.update h si accu + else Int.Map.set h si accu with Not_found -> accu in Int.Map.fold fold s2 s1 @@ -242,11 +242,19 @@ struct try let m = Int.Map.find h s in let m = Map.add k x m in - Int.Map.update h m s + Int.Map.set h m s with Not_found -> let m = Map.singleton k x in Int.Map.add h m s + (* when Coq requires OCaml 4.06 or later, the module type + CSig.MapS may include the signature of OCaml's "update", + requiring an implementation here, which could be just: + + let update k f s = assert false (* not implemented *) + + *) + let singleton k x = let h = M.hash k in Int.Map.singleton h (Map.singleton k x) @@ -259,7 +267,7 @@ struct if Map.is_empty m then Int.Map.remove h s else - Int.Map.update h m s + Int.Map.set h m s with Not_found -> s let merge f s1 s2 = @@ -359,7 +367,7 @@ struct let h = M.hash k in let m = Int.Map.find h s in let m = Map.modify k f m in - Int.Map.update h m s + Int.Map.set h m s let bind f s = let fb m = Map.bind f m in @@ -367,11 +375,11 @@ struct let domain s = Int.Map.map Map.domain s - let update k x s = + let set k x s = let h = M.hash k in let m = Int.Map.find h s in - let m = Map.update k x m in - Int.Map.update h m s + let m = Map.set k x m in + Int.Map.set h m s let smartmap f s = let fs m = Map.smartmap f m in diff --git a/library/coqlib.ml b/library/coqlib.ml index 141fff0335..4a23909858 100644 --- a/library/coqlib.ml +++ b/library/coqlib.ml @@ -14,7 +14,7 @@ open Libnames open Globnames open Nametab -let coq = Nameops.coq_string (* "Coq" *) +let coq = Libnames.coq_string (* "Coq" *) (************************************************************************) (* Generic functions to find Coq objects *) @@ -32,7 +32,7 @@ let find_reference locstr dir s = of not found errors here *) user_err ~hdr:locstr Pp.(str "cannot find " ++ Libnames.pr_path sp ++ - str "; maybe library " ++ Libnames.pr_dirpath dp ++ + str "; maybe library " ++ DirPath.print dp ++ str " has to be required first.") let coq_reference locstr dir s = find_reference locstr (coq::dir) s @@ -52,14 +52,14 @@ let gen_reference_in_modules locstr dirs s = | [] -> anomaly ~label:locstr (str "cannot find " ++ str s ++ str " in module" ++ str (if List.length dirs > 1 then "s " else " ") ++ - prlist_with_sep pr_comma pr_dirpath dirs ++ str ".") + prlist_with_sep pr_comma DirPath.print dirs ++ str ".") | l -> anomaly ~label:locstr (str "ambiguous name " ++ str s ++ str " can represent " ++ prlist_with_sep pr_comma (fun x -> Libnames.pr_path (Nametab.path_of_global x)) l ++ str " in module" ++ str (if List.length dirs > 1 then "s " else " ") ++ - prlist_with_sep pr_comma pr_dirpath dirs ++ str ".") + prlist_with_sep pr_comma DirPath.print dirs ++ str ".") (* For tactics/commands requiring vernacular libraries *) @@ -79,7 +79,7 @@ let check_required_library d = *) (* or failing ...*) user_err ~hdr:"Coqlib.check_required_library" - (str "Library " ++ pr_dirpath dir ++ str " has to be required first.") + (str "Library " ++ DirPath.print dir ++ str " has to be required first.") (************************************************************************) (* Specific Coq objects *) diff --git a/library/declaremods.ml b/library/declaremods.ml index cda40f49f1..41e00a41c6 100644 --- a/library/declaremods.ml +++ b/library/declaremods.ml @@ -167,29 +167,29 @@ let consistency_checks exists dir dirinfo = try Nametab.locate_dir (qualid_of_dirpath dir) with Not_found -> user_err ~hdr:"consistency_checks" - (pr_dirpath dir ++ str " should already exist!") + (DirPath.print dir ++ str " should already exist!") in assert (eq_global_dir_reference globref dirinfo) else if Nametab.exists_dir dir then user_err ~hdr:"consistency_checks" - (pr_dirpath dir ++ str " already exists") + (DirPath.print dir ++ str " already exists") let compute_visibility exists i = if exists then Nametab.Exactly i else Nametab.Until i (** Iterate some function [iter_objects] on all components of a module *) -let do_module exists iter_objects i dir mp sobjs kobjs = - let prefix = (dir,(mp,DirPath.empty)) in +let do_module exists iter_objects i obj_dir obj_mp sobjs kobjs = + let prefix = { obj_dir ; obj_mp; obj_sec = DirPath.empty } in let dirinfo = DirModule prefix in - consistency_checks exists dir dirinfo; - Nametab.push_dir (compute_visibility exists i) dir dirinfo; - ModSubstObjs.set mp sobjs; + consistency_checks exists obj_dir dirinfo; + Nametab.push_dir (compute_visibility exists i) obj_dir dirinfo; + ModSubstObjs.set obj_mp sobjs; (* If we're not a functor, let's iter on the internal components *) if sobjs_no_functor sobjs then begin let objs = expand_sobjs sobjs in - ModObjs.set mp (prefix,objs,kobjs); + ModObjs.set obj_mp (prefix,objs,kobjs); iter_objects (i+1) prefix objs; iter_objects (i+1) prefix kobjs end @@ -222,20 +222,20 @@ let cache_keep _ = anomaly (Pp.str "This module should not be cached!") let load_keep i ((sp,kn),kobjs) = (* Invariant : seg isn't empty *) - let dir = dir_of_sp sp and mp = mp_of_kn kn in - let prefix = (dir,(mp,DirPath.empty)) in + let obj_dir = dir_of_sp sp and obj_mp = mp_of_kn kn in + let prefix = { obj_dir ; obj_mp; obj_sec = DirPath.empty } in let prefix',sobjs,kobjs0 = - try ModObjs.get mp + try ModObjs.get obj_mp with Not_found -> assert false (* a substobjs should already be loaded *) in assert (eq_op prefix' prefix); assert (List.is_empty kobjs0); - ModObjs.set mp (prefix,sobjs,kobjs); + ModObjs.set obj_mp (prefix,sobjs,kobjs); Lib.load_objects i prefix kobjs let open_keep i ((sp,kn),kobjs) = - let dir = dir_of_sp sp and mp = mp_of_kn kn in - let prefix = (dir,(mp,DirPath.empty)) in + let obj_dir = dir_of_sp sp and obj_mp = mp_of_kn kn in + let prefix = { obj_dir; obj_mp; obj_sec = DirPath.empty } in Lib.open_objects i prefix kobjs let in_modkeep : Lib.lib_objects -> obj = @@ -284,9 +284,9 @@ let (in_modtype : substitutive_objects -> obj), (** {6 Declaration of substitutive objects for Include} *) let do_include do_load do_open i ((sp,kn),aobjs) = - let dir = Libnames.dirpath sp in - let mp = KerName.modpath kn in - let prefix = (dir,(mp,DirPath.empty)) in + let obj_dir = Libnames.dirpath sp in + let obj_mp = KerName.modpath kn in + let prefix = { obj_dir; obj_mp; obj_sec = DirPath.empty } in let o = expand_aobjs aobjs in if do_load then Lib.load_objects i prefix o; if do_open then Lib.open_objects i prefix o @@ -577,7 +577,7 @@ let start_module interp_modast export id args res fs = in openmod_info := { cur_typ = res_entry_o; cur_typs = subtyps }; let prefix = Lib.start_module export id mp fs in - Nametab.push_dir (Nametab.Until 1) (fst prefix) (DirOpenModule prefix); + Nametab.push_dir (Nametab.Until 1) (prefix.obj_dir) (DirOpenModule prefix); mp let end_module () = @@ -684,7 +684,7 @@ let start_modtype interp_modast id args mtys fs = let sub_mty_l = build_subtypes interp_modast env mp arg_entries_r mtys in openmodtype_info := sub_mty_l; let prefix = Lib.start_modtype id mp fs in - Nametab.push_dir (Nametab.Until 1) (fst prefix) (DirOpenModtype prefix); + Nametab.push_dir (Nametab.Until 1) (prefix.obj_dir) (DirOpenModtype prefix); mp let end_modtype () = diff --git a/library/global.ml b/library/global.ml index 43097dc5dc..ce37dfecff 100644 --- a/library/global.ml +++ b/library/global.ml @@ -8,7 +8,6 @@ open Names open Environ -open Decl_kinds (** We introduce here the global environment of the system, and we declare it as a synchronized table. *) @@ -21,6 +20,7 @@ module GlobalSafeEnv : sig val set_safe_env : Safe_typing.safe_environment -> unit val join_safe_environment : ?except:Future.UUIDSet.t -> unit -> unit val is_joined_environment : unit -> bool + val global_env_summary_tag : Safe_typing.safe_environment Summary.Dyn.tag end = struct @@ -31,9 +31,9 @@ let join_safe_environment ?except () = let is_joined_environment () = Safe_typing.is_joined_environment !global_env - -let () = - Summary.declare_summary global_env_summary_name + +let global_env_summary_tag = + Summary.declare_summary_tag global_env_summary_name { Summary.freeze_function = (function | `Yes -> join_safe_environment (); !global_env | `No -> !global_env @@ -52,6 +52,8 @@ let set_safe_env e = global_env := e end +let global_env_summary_tag = GlobalSafeEnv.global_env_summary_tag + let safe_env = GlobalSafeEnv.safe_env let join_safe_environment ?except () = GlobalSafeEnv.join_safe_environment ?except () @@ -231,18 +233,7 @@ let universes_of_global env r = let universes_of_global gr = universes_of_global (env ()) gr -(** Global universe names *) -type universe_names = - (polymorphic * Univ.Level.t) Id.Map.t * Id.t Univ.LMap.t - -let global_universes = - Summary.ref ~name:"Global universe names" - ((Id.Map.empty, Univ.LMap.empty) : universe_names) - -let global_universe_names () = !global_universes -let set_global_universe_names s = global_universes := s - -let is_polymorphic r = +let is_polymorphic r = let env = env() in match r with | VarRef id -> false diff --git a/library/global.mli b/library/global.mli index 51fe531819..324181e79e 100644 --- a/library/global.mli +++ b/library/global.mli @@ -44,7 +44,7 @@ val add_mind : DirPath.t -> Id.t -> Entries.mutual_inductive_entry -> MutInd.t (** Extra universe constraints *) -val add_constraints : Univ.constraints -> unit +val add_constraints : Univ.Constraint.t -> unit val push_context : bool -> Univ.UContext.t -> unit val push_context_set : bool -> Univ.ContextSet.t -> unit @@ -102,13 +102,6 @@ val body_of_constant : Constant.t -> (Constr.constr * Univ.AUContext.t) option val body_of_constant_body : Declarations.constant_body -> (Constr.constr * Univ.AUContext.t) option (** Same as {!body_of_constant} but on {!Declarations.constant_body}. *) -(** Global universe name <-> level mapping *) -type universe_names = - (Decl_kinds.polymorphic * Univ.Level.t) Id.Map.t * Id.t Univ.LMap.t - -val global_universe_names : unit -> universe_names -val set_global_universe_names : universe_names -> unit - (** {6 Compiled libraries } *) val start_library : DirPath.t -> ModPath.t @@ -166,4 +159,4 @@ val current_dirpath : unit -> DirPath.t val with_global : (Environ.env -> DirPath.t -> 'a Univ.in_universe_context_set) -> 'a -val global_env_summary_name : string +val global_env_summary_tag : Safe_typing.safe_environment Summary.Dyn.tag diff --git a/library/heads.ml b/library/heads.ml index 8b8e407f76..ee3bfe1bdd 100644 --- a/library/heads.ml +++ b/library/heads.ml @@ -8,7 +8,6 @@ open Util open Names -open Term open Constr open Vars open Mod_subst diff --git a/library/kindops.ml b/library/kindops.ml index 882f620862..83985ce974 100644 --- a/library/kindops.ml +++ b/library/kindops.ml @@ -23,45 +23,13 @@ let string_of_theorem_kind = function | Proposition -> "Proposition" | Corollary -> "Corollary" -let string_of_definition_kind def = - let (locality, poly, kind) = def in - let error () = CErrors.anomaly (Pp.str "Internal definition kind.") in - match kind with - | Definition -> - begin match locality with - | Discharge -> "Let" - | Local -> "Local Definition" - | Global -> "Definition" - end - | Example -> - begin match locality with - | Discharge -> error () - | Local -> "Local Example" - | Global -> "Example" - end - | Coercion -> - begin match locality with - | Discharge -> error () - | Local -> "Local Coercion" - | Global -> "Coercion" - end - | SubClass -> - begin match locality with - | Discharge -> error () - | Local -> "Local SubClass" - | Global -> "SubClass" - end - | CanonicalStructure -> - begin match locality with - | Discharge -> error () - | Local -> error () - | Global -> "Canonical Structure" - end - | Instance -> - begin match locality with - | Discharge -> error () - | Local -> "Instance" - | Global -> "Global Instance" - end +let string_of_definition_object_kind = function + | Definition -> "Definition" + | Example -> "Example" + | Coercion -> "Coercion" + | SubClass -> "SubClass" + | CanonicalStructure -> "Canonical Structure" + | Instance -> "Instance" + | Let -> "Let" | (StructureComponent|Scheme|CoFixpoint|Fixpoint|IdentityCoercion|Method) -> CErrors.anomaly (Pp.str "Internal definition kind.") diff --git a/library/kindops.mli b/library/kindops.mli index 77979c9159..06f873e857 100644 --- a/library/kindops.mli +++ b/library/kindops.mli @@ -12,4 +12,4 @@ open Decl_kinds val logical_kind_of_goal_kind : goal_object_kind -> logical_kind val string_of_theorem_kind : theorem_kind -> string -val string_of_definition_kind : definition_kind -> string +val string_of_definition_object_kind : definition_object_kind -> string diff --git a/library/lib.ml b/library/lib.ml index 36292d367e..499e2ae21f 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -12,7 +12,6 @@ open Util open Names open Libnames open Globnames -open Nameops open Libobject open Context.Named.Declaration @@ -94,12 +93,16 @@ let segment_of_objects prefix = sections, but on the contrary there are many constructions of section paths based on the library path. *) -let initial_prefix = default_library,(Names.ModPath.initial,Names.DirPath.empty) +let initial_prefix = { + obj_dir = default_library; + obj_mp = ModPath.initial; + obj_sec = DirPath.empty; +} type lib_state = { - comp_name : Names.DirPath.t option; + comp_name : DirPath.t option; lib_stk : library_segment; - path_prefix : Names.DirPath.t * (Names.ModPath.t * Names.DirPath.t); + path_prefix : object_prefix; } let initial_lib_state = { @@ -116,10 +119,9 @@ let library_dp () = (* [path_prefix] is a pair of absolute dirpath and a pair of current module path and relative section path *) -let cwd () = fst !lib_state.path_prefix -let current_prefix () = snd !lib_state.path_prefix -let current_mp () = fst (snd !lib_state.path_prefix) -let current_sections () = snd (snd !lib_state.path_prefix) +let cwd () = !lib_state.path_prefix.obj_dir +let current_mp () = !lib_state.path_prefix.obj_mp +let current_sections () = !lib_state.path_prefix.obj_sec let sections_depth () = List.length (Names.DirPath.repr (current_sections ())) let sections_are_opened () = not (Names.DirPath.is_empty (current_sections ())) @@ -137,7 +139,7 @@ let make_path_except_section id = Libnames.make_path (cwd_except_section ()) id let make_kn id = - let mp,dir = current_prefix () in + let mp, dir = current_mp (), current_sections () in Names.KerName.make mp dir (Names.Label.of_id id) let make_oname id = Libnames.make_oname !lib_state.path_prefix id @@ -153,8 +155,11 @@ let recalc_path_prefix () = lib_state := { !lib_state with path_prefix = recalc !lib_state.lib_stk } let pop_path_prefix () = - let dir,(mp,sec) = !lib_state.path_prefix in - lib_state := { !lib_state with path_prefix = pop_dirpath dir, (mp, pop_dirpath sec)} + let op = !lib_state.path_prefix in + lib_state := { !lib_state + with path_prefix = { op with obj_dir = pop_dirpath op.obj_dir; + obj_sec = pop_dirpath op.obj_sec; + } } let find_entry_p p = let rec find = function @@ -227,7 +232,7 @@ let add_anonymous_entry node = add_entry (make_oname (anonymous_id ())) node let add_leaf id obj = - if Names.ModPath.equal (current_mp ()) Names.ModPath.initial then + if ModPath.equal (current_mp ()) ModPath.initial then user_err Pp.(str "No session module started (use -top dir)"); let oname = make_oname id in cache_object (oname,obj); @@ -279,8 +284,8 @@ let current_mod_id () = let start_mod is_type export id mp fs = - let dir = add_dirpath_suffix (cwd ()) id in - let prefix = dir,(mp,Names.DirPath.empty) in + let dir = add_dirpath_suffix (!lib_state.path_prefix.obj_dir) id in + let prefix = { obj_dir = dir; obj_mp = mp; obj_sec = Names.DirPath.empty } in let exists = if is_type then Nametab.exists_cci (make_path id) else Nametab.exists_module dir @@ -329,10 +334,10 @@ let contents_after sp = let (after,_,_) = split_lib sp in after let start_compilation s mp = if !lib_state.comp_name != None then user_err Pp.(str "compilation unit is already started"); - if not (Names.DirPath.is_empty (current_sections ())) then + if not (Names.DirPath.is_empty (!lib_state.path_prefix.obj_sec)) then user_err Pp.(str "some sections are already opened"); - let prefix = s, (mp, Names.DirPath.empty) in - let () = add_anonymous_entry (CompilingLibrary prefix) in + let prefix = Libnames.{ obj_dir = s; obj_mp = mp; obj_sec = DirPath.empty } in + add_anonymous_entry (CompilingLibrary prefix); lib_state := { !lib_state with comp_name = Some s; path_prefix = prefix } @@ -361,8 +366,8 @@ let end_compilation_checks dir = | None -> anomaly (Pp.str "There should be a module name...") | Some m -> if not (Names.DirPath.equal m dir) then anomaly - (str "The current open module has name" ++ spc () ++ pr_dirpath m ++ - spc () ++ str "and not" ++ spc () ++ pr_dirpath m ++ str "."); + (str "The current open module has name" ++ spc () ++ DirPath.print m ++ + spc () ++ str "and not" ++ spc () ++ DirPath.print m ++ str "."); in oname @@ -523,15 +528,15 @@ let is_in_section ref = (*************) (* Sections. *) let open_section id = - let olddir,(mp,oldsec) = !lib_state.path_prefix in - let dir = add_dirpath_suffix olddir id in - let prefix = dir, (mp, add_dirpath_suffix oldsec id) in - if Nametab.exists_section dir then + let opp = !lib_state.path_prefix in + let obj_dir = add_dirpath_suffix opp.obj_dir id in + let prefix = { obj_dir; obj_mp = opp.obj_mp; obj_sec = add_dirpath_suffix opp.obj_sec id } in + if Nametab.exists_section obj_dir then user_err ~hdr:"open_section" (Id.print id ++ str " already exists."); let fs = Summary.freeze_summaries ~marshallable:`No in add_entry (make_oname id) (OpenedSection (prefix, fs)); (*Pushed for the lifetime of the section: removed by unfrozing the summary*) - Nametab.push_dir (Nametab.Until 1) dir (DirOpenSection prefix); + Nametab.push_dir (Nametab.Until 1) obj_dir (DirOpenSection prefix); lib_state := { !lib_state with path_prefix = prefix }; add_section () @@ -557,7 +562,7 @@ let close_section () = in let (secdecls,mark,before) = split_lib_at_opening oname in lib_state := { !lib_state with lib_stk = before }; - let full_olddir = fst !lib_state.path_prefix in + let full_olddir = !lib_state.path_prefix.obj_dir in pop_path_prefix (); add_entry oname (ClosedSection (List.rev (mark::secdecls))); let newdecls = List.map discharge_item secdecls in @@ -597,10 +602,10 @@ let init () = (* Misc *) let mp_of_global = function - |VarRef id -> current_mp () - |ConstRef cst -> Names.Constant.modpath cst - |IndRef ind -> Names.ind_modpath ind - |ConstructRef constr -> Names.constr_modpath constr + | VarRef id -> !lib_state.path_prefix.obj_mp + | ConstRef cst -> Names.Constant.modpath cst + | IndRef ind -> Names.ind_modpath ind + | ConstructRef constr -> Names.constr_modpath constr let rec dp_of_mp = function |Names.MPfile dp -> dp diff --git a/library/libnames.ml b/library/libnames.ml index efb1348ab2..a471d83966 100644 --- a/library/libnames.ml +++ b/library/libnames.ml @@ -13,7 +13,7 @@ open Names (**********************************************) -let pr_dirpath sl = str (DirPath.to_string sl) +let pr_dirpath sl = DirPath.print sl (*s Operations on dirpaths *) @@ -156,10 +156,15 @@ let qualid_of_dirpath dir = type object_name = full_path * KerName.t -type object_prefix = DirPath.t * (ModPath.t * DirPath.t) +type object_prefix = { + obj_dir : DirPath.t; + obj_mp : ModPath.t; + obj_sec : DirPath.t; +} -let make_oname (dirpath,(mp,dir)) id = - make_path dirpath id, KerName.make mp dir (Label.of_id id) +(* let make_oname (dirpath,(mp,dir)) id = *) +let make_oname { obj_dir; obj_mp; obj_sec } id = + make_path obj_dir id, KerName.make obj_mp obj_sec (Label.of_id id) (* to this type are mapped DirPath.t's in the nametab *) type global_dir_reference = @@ -170,10 +175,10 @@ type global_dir_reference = | DirClosedSection of DirPath.t (* this won't last long I hope! *) -let eq_op (d1, (mp1, p1)) (d2, (mp2, p2)) = - DirPath.equal d1 d2 && - DirPath.equal p1 p2 && - ModPath.equal mp1 mp2 +let eq_op op1 op2 = + DirPath.equal op1.obj_dir op2.obj_dir && + DirPath.equal op1.obj_sec op2.obj_sec && + ModPath.equal op1.obj_mp op2.obj_mp let eq_global_dir_reference r1 r2 = match r1, r2 with | DirOpenModule op1, DirOpenModule op2 -> eq_op op1 op2 @@ -232,6 +237,14 @@ let join_reference ns r = Qualid (loc, make_qualid (dirpath_of_string (Names.Id.to_string id1)) id2) +(* Default paths *) +let default_library = Names.DirPath.initial (* = ["Top"] *) + +(*s Roots of the space of absolute names *) +let coq_string = "Coq" +let coq_root = Id.of_string coq_string +let default_root_prefix = DirPath.empty + (* Deprecated synonyms *) let make_short_qualid = qualid_of_ident diff --git a/library/libnames.mli b/library/libnames.mli index ab25853346..71f5422404 100644 --- a/library/libnames.mli +++ b/library/libnames.mli @@ -11,12 +11,13 @@ open Loc open Names (** {6 Dirpaths } *) -(** FIXME: ought to be in Names.dir_path *) +val dirpath_of_string : string -> DirPath.t val pr_dirpath : DirPath.t -> Pp.t +[@@ocaml.deprecated "Alias for DirPath.print"] -val dirpath_of_string : string -> DirPath.t val string_of_dirpath : DirPath.t -> string +[@@ocaml.deprecated "Alias for DirPath.to_string"] (** Pop the suffix of a [DirPath.t]. Raises a [Failure] for an empty path *) val pop_dirpath : DirPath.t -> DirPath.t @@ -93,7 +94,25 @@ val qualid_of_ident : Id.t -> qualid type object_name = full_path * KerName.t -type object_prefix = DirPath.t * (ModPath.t * DirPath.t) +(** Object prefix morally contains the "prefix" naming of an object to + be stored by [library], where [obj_dir] is the "absolute" path, + [obj_mp] is the current "module" prefix and [obj_sec] is the + "section" prefix. + + Thus, for an object living inside [Module A. Section B.] the + prefix would be: + + [ { obj_dir = "A.B"; obj_mp = "A"; obj_sec = "B" } ] + + Note that both [obj_dir] and [obj_sec] are "paths" that is to say, + as opposed to [obj_mp] which is a single module name. + + *) +type object_prefix = { + obj_dir : DirPath.t; + obj_mp : ModPath.t; + obj_sec : DirPath.t; +} val eq_op : object_prefix -> object_prefix -> bool @@ -127,7 +146,20 @@ val pr_reference : reference -> Pp.t val loc_of_reference : reference -> Loc.t option val join_reference : reference -> reference -> reference -(** Deprecated synonyms *) +(** some preset paths *) +val default_library : DirPath.t + +(** This is the root of the standard library of Coq *) +val coq_root : module_ident (** "Coq" *) +val coq_string : string (** "Coq" *) + +(** This is the default root prefix for developments which doesn't + mention a root *) +val default_root_prefix : DirPath.t +(** Deprecated synonyms *) val make_short_qualid : Id.t -> qualid (** = qualid_of_ident *) +[@@ocaml.deprecated "Alias for qualid_of_ident"] + val qualid_of_sp : full_path -> qualid (** = qualid_of_path *) +[@@ocaml.deprecated "Alias for qualid_of_sp"] diff --git a/library/library.ml b/library/library.ml index 99ef66699f..88470d121b 100644 --- a/library/library.ml +++ b/library/library.ml @@ -12,9 +12,8 @@ open Util open Names open Libnames -open Nameops -open Libobject open Lib +open Libobject (************************************************************************) (*s Low-level interning/externing of libraries to files *) @@ -132,7 +131,7 @@ let try_find_library dir = try find_library dir with Not_found -> user_err ~hdr:"Library.find_library" - (str "Unknown library " ++ pr_dirpath dir) + (str "Unknown library " ++ DirPath.print dir) let register_library_filename dir f = (* Not synchronized: overwrite the previous binding if one existed *) @@ -331,7 +330,7 @@ let error_unmapped_dir qid = let prefix, _ = repr_qualid qid in user_err ~hdr:"load_absolute_library_from" (str "Cannot load " ++ pr_qualid qid ++ str ":" ++ spc () ++ - str "no physical path bound to" ++ spc () ++ pr_dirpath prefix ++ fnl ()) + str "no physical path bound to" ++ spc () ++ DirPath.print prefix ++ fnl ()) let error_lib_not_found qid = user_err ~hdr:"load_absolute_library_from" @@ -465,8 +464,8 @@ let rec intern_library (needed, contents) (dir, f) from = if not (DirPath.equal dir m.library_name) then user_err ~hdr:"load_physical_library" (str "The file " ++ str f ++ str " contains library" ++ spc () ++ - pr_dirpath m.library_name ++ spc () ++ str "and not library" ++ - spc() ++ pr_dirpath dir); + DirPath.print m.library_name ++ spc () ++ str "and not library" ++ + spc() ++ DirPath.print dir); Feedback.feedback (Feedback.FileLoaded(DirPath.to_string dir, f)); m.library_digests, intern_library_deps (needed, contents) dir m f @@ -477,9 +476,9 @@ and intern_library_deps libs dir m from = and intern_mandatory_library caller from libs (dir,d) = let digest, libs = intern_library libs (dir, None) (Some from) in if not (Safe_typing.digest_match ~actual:digest ~required:d) then - user_err (str "Compiled library " ++ pr_dirpath caller ++ + user_err (str "Compiled library " ++ DirPath.print caller ++ str " (in file " ++ str from ++ str ") makes inconsistent assumptions \ - over library " ++ pr_dirpath dir); + over library " ++ DirPath.print dir); libs let rec_intern_library libs (dir, f) = @@ -617,7 +616,7 @@ let check_coq_overwriting p id = let is_empty = match l with [] -> true | _ -> false in if not !Flags.boot && not is_empty && Id.equal (List.last l) coq_root then user_err - (str "Cannot build module " ++ pr_dirpath p ++ str "." ++ Id.print id ++ str "." ++ spc () ++ + (str "Cannot build module " ++ DirPath.print p ++ str "." ++ Id.print id ++ str "." ++ spc () ++ str "it starts with prefix \"Coq\" which is reserved for the Coq library.") let start_library fo = @@ -625,7 +624,7 @@ let start_library fo = try let lp = Loadpath.find_load_path (Filename.dirname fo) in Loadpath.logical lp - with Not_found -> Nameops.default_root_prefix + with Not_found -> Libnames.default_root_prefix in let file = Filename.chop_extension (Filename.basename fo) in let id = Id.of_string file in @@ -665,7 +664,7 @@ let current_reexports () = !libraries_exports_list let error_recursively_dependent_library dir = user_err - (strbrk "Unable to use logical name " ++ pr_dirpath dir ++ + (strbrk "Unable to use logical name " ++ DirPath.print dir ++ strbrk " to save current library because" ++ strbrk " it already depends on a library of this name.") diff --git a/library/library.mllib b/library/library.mllib index d94fc22919..e43bfb5a1f 100644 --- a/library/library.mllib +++ b/library/library.mllib @@ -1,5 +1,3 @@ -Univops -Nameops Libnames Globnames Libobject diff --git a/library/loadpath.ml b/library/loadpath.ml index 757e972b1a..eb6dae84aa 100644 --- a/library/loadpath.ml +++ b/library/loadpath.ml @@ -54,8 +54,8 @@ let warn_overriding_logical_loadpath = CWarnings.create ~name:"overriding-logical-loadpath" ~category:"loadpath" (fun (phys_path, old_path, coq_path) -> str phys_path ++ strbrk " was previously bound to " ++ - pr_dirpath old_path ++ strbrk "; it is remapped to " ++ - pr_dirpath coq_path) + DirPath.print old_path ++ strbrk "; it is remapped to " ++ + DirPath.print coq_path) let add_load_path phys_path coq_path ~implicit = let phys_path = CUnix.canonical_path_name phys_path in @@ -75,7 +75,7 @@ let add_load_path phys_path coq_path ~implicit = else let () = (* Do not warn when overriding the default "-I ." path *) - if not (DirPath.equal old_path Nameops.default_root_prefix) then + if not (DirPath.equal old_path Libnames.default_root_prefix) then warn_overriding_logical_loadpath (phys_path, old_path, coq_path) in true in diff --git a/library/nametab.ml b/library/nametab.ml index 0ec4a37cdb..84225f8639 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -302,6 +302,16 @@ module DirTab = Make(DirPath')(GlobDir) type dirtab = DirTab.t let the_dirtab = ref (DirTab.empty : dirtab) +type universe_id = DirPath.t * int + +module UnivIdEqual = +struct + type t = universe_id + let equal (d, i) (d', i') = DirPath.equal d d' && Int.equal i i' +end +module UnivTab = Make(FullPath)(UnivIdEqual) +type univtab = UnivTab.t +let the_univtab = ref (UnivTab.empty : univtab) (* Reversed name tables ***************************************************) @@ -318,6 +328,21 @@ let the_modrevtab = ref (MPmap.empty : mprevtab) type mptrevtab = full_path MPmap.t let the_modtyperevtab = ref (MPmap.empty : mptrevtab) +module UnivIdOrdered = +struct + type t = universe_id + let hash (d, i) = i + DirPath.hash d + let compare (d, i) (d', i') = + let c = Int.compare i i' in + if Int.equal c 0 then DirPath.compare d d' + else c +end + +module UnivIdMap = HMap.Make(UnivIdOrdered) + +type univrevtab = full_path UnivIdMap.t +let the_univrevtab = ref (UnivIdMap.empty : univrevtab) + (* Push functions *********************************************************) (* This is for permanent constructions (never discharged -- but with @@ -359,9 +384,14 @@ let push_modtype vis sp kn = let push_dir vis dir dir_ref = the_dirtab := DirTab.push vis dir dir_ref !the_dirtab; match dir_ref with - DirModule (_,(mp,_)) -> the_modrevtab := MPmap.add mp dir !the_modrevtab - | _ -> () + | DirModule { obj_mp; _ } -> the_modrevtab := MPmap.add obj_mp dir !the_modrevtab + | _ -> () + +(* This is for global universe names *) +let push_universe vis sp univ = + the_univtab := UnivTab.push vis sp univ !the_univtab; + the_univrevtab := UnivIdMap.add univ sp !the_univrevtab (* Locate functions *******************************************************) @@ -382,21 +412,23 @@ let locate_syndef qid = match locate_extended qid with let locate_modtype qid = MPTab.locate qid !the_modtypetab let full_name_modtype qid = MPTab.user_name qid !the_modtypetab +let locate_universe qid = UnivTab.locate qid !the_univtab + let locate_dir qid = DirTab.locate qid !the_dirtab let locate_module qid = match locate_dir qid with - | DirModule (_,(mp,_)) -> mp + | DirModule { obj_mp ; _} -> obj_mp | _ -> raise Not_found let full_name_module qid = match locate_dir qid with - | DirModule (dir,_) -> dir + | DirModule { obj_dir ; _} -> obj_dir | _ -> raise Not_found let locate_section qid = match locate_dir qid with - | DirOpenSection (dir, _) + | DirOpenSection { obj_dir; _ } -> obj_dir | DirClosedSection dir -> dir | _ -> raise Not_found @@ -447,6 +479,8 @@ let exists_module = exists_dir let exists_modtype sp = MPTab.exists sp !the_modtypetab +let exists_universe kn = UnivTab.exists kn !the_univtab + (* Reverse locate functions ***********************************************) let path_of_global ref = @@ -469,6 +503,9 @@ let dirpath_of_module mp = let path_of_modtype mp = MPmap.find mp !the_modtyperevtab +let path_of_universe mp = + UnivIdMap.find mp !the_univrevtab + (* Shortest qualid functions **********************************************) let shortest_qualid_of_global ctx ref = @@ -490,6 +527,10 @@ let shortest_qualid_of_modtype kn = let sp = MPmap.find kn !the_modtyperevtab in MPTab.shortest_qualid Id.Set.empty sp !the_modtypetab +let shortest_qualid_of_universe kn = + let sp = UnivIdMap.find kn !the_univrevtab in + UnivTab.shortest_qualid Id.Set.empty sp !the_univtab + let pr_global_env env ref = try pr_qualid (shortest_qualid_of_global env ref) with Not_found as e -> @@ -508,24 +549,28 @@ let global_inductive r = (********************************************************************) (* Registration of tables as a global table and rollback *) -type frozen = ccitab * dirtab * mptab - * globrevtab * mprevtab * mptrevtab +type frozen = ccitab * dirtab * mptab * univtab + * globrevtab * mprevtab * mptrevtab * univrevtab let freeze _ : frozen = !the_ccitab, !the_dirtab, !the_modtypetab, + !the_univtab, !the_globrevtab, !the_modrevtab, - !the_modtyperevtab + !the_modtyperevtab, + !the_univrevtab -let unfreeze (ccit,dirt,mtyt,globr,modr,mtyr) = +let unfreeze (ccit,dirt,mtyt,univt,globr,modr,mtyr,univr) = the_ccitab := ccit; the_dirtab := dirt; the_modtypetab := mtyt; + the_univtab := univt; the_globrevtab := globr; the_modrevtab := modr; - the_modtyperevtab := mtyr + the_modtyperevtab := mtyr; + the_univrevtab := univr let _ = Summary.declare_summary "names" diff --git a/library/nametab.mli b/library/nametab.mli index c02447a7ce..77fafa100f 100644 --- a/library/nametab.mli +++ b/library/nametab.mli @@ -78,6 +78,12 @@ val push_modtype : visibility -> full_path -> ModPath.t -> unit val push_dir : visibility -> DirPath.t -> global_dir_reference -> unit val push_syndef : visibility -> full_path -> syndef_name -> unit +type universe_id = DirPath.t * int + +module UnivIdMap : CMap.ExtS with type key = universe_id + +val push_universe : visibility -> full_path -> universe_id -> unit + (** {6 The following functions perform globalization of qualified names } *) (** These functions globalize a (partially) qualified name or fail with @@ -91,6 +97,7 @@ val locate_modtype : qualid -> ModPath.t val locate_dir : qualid -> global_dir_reference val locate_module : qualid -> ModPath.t val locate_section : qualid -> DirPath.t +val locate_universe : qualid -> universe_id (** These functions globalize user-level references into global references, like [locate] and co, but raise a nice error message @@ -119,6 +126,7 @@ val exists_modtype : full_path -> bool val exists_dir : DirPath.t -> bool val exists_section : DirPath.t -> bool (** deprecated synonym of [exists_dir] *) val exists_module : DirPath.t -> bool (** deprecated synonym of [exists_dir] *) +val exists_universe : full_path -> bool (** {6 These functions locate qualids into full user names } *) @@ -138,6 +146,10 @@ val path_of_global : global_reference -> full_path val dirpath_of_module : ModPath.t -> DirPath.t val path_of_modtype : ModPath.t -> full_path +(** A universe_id might not be registered with a corresponding user name. + @raise Not_found if the universe was not introduced by the user. *) +val path_of_universe : universe_id -> full_path + (** Returns in particular the dirpath or the basename of the full path associated to global reference *) @@ -158,6 +170,7 @@ val shortest_qualid_of_global : Id.Set.t -> global_reference -> qualid val shortest_qualid_of_syndef : Id.Set.t -> syndef_name -> qualid val shortest_qualid_of_modtype : ModPath.t -> qualid val shortest_qualid_of_module : ModPath.t -> qualid +val shortest_qualid_of_universe : universe_id -> qualid (** Deprecated synonyms *) diff --git a/library/summary.ml b/library/summary.ml index 9f49d1f839..6df17476bd 100644 --- a/library/summary.ml +++ b/library/summary.ml @@ -13,17 +13,22 @@ open Util module Dyn = Dyn.Make () type marshallable = [ `Yes | `No | `Shallow ] + type 'a summary_declaration = { freeze_function : marshallable -> 'a; unfreeze_function : 'a -> unit; init_function : unit -> unit } -let summaries = ref Int.Map.empty +let sum_mod = ref None +let sum_map = ref String.Map.empty let mangle id = id ^ "-SUMMARY" +let unmangle id = String.(sub id 0 (length id - 8)) + +let ml_modules = "ML-MODULES" -let internal_declare_summary hash sumname sdecl = - let (infun, outfun) = Dyn.Easy.make_dyn (mangle sumname) in +let internal_declare_summary fadd sumname sdecl = + let infun, outfun, tag = Dyn.Easy.make_dyn_tag (mangle sumname) in let dyn_freeze b = infun (sdecl.freeze_function b) and dyn_unfreeze sum = sdecl.unfreeze_function (outfun sum) and dyn_init = sdecl.init_function in @@ -32,140 +37,116 @@ let internal_declare_summary hash sumname sdecl = unfreeze_function = dyn_unfreeze; init_function = dyn_init } in - summaries := Int.Map.add hash (sumname, ddecl) !summaries + fadd sumname ddecl; + tag -let all_declared_summaries = ref Int.Set.empty +let declare_ml_modules_summary decl = + let ml_add _ ddecl = sum_mod := Some ddecl in + internal_declare_summary ml_add ml_modules decl -let summary_names = ref [] -let name_of_summary name = - try List.assoc name !summary_names - with Not_found -> "summary name not found" +let declare_ml_modules_summary decl = + ignore(declare_ml_modules_summary decl) -let declare_summary sumname decl = - let hash = String.hash sumname in - let () = if Int.Map.mem hash !summaries then - let (name, _) = Int.Map.find hash !summaries in - anomaly ~label:"Summary.declare_summary" - (str "Colliding summary names: " ++ str sumname ++ str " vs. " ++ str name ++ str ".") +let declare_summary_tag sumname decl = + let fadd name ddecl = sum_map := String.Map.add name ddecl !sum_map in + let () = if String.Map.mem sumname !sum_map then + anomaly ~label:"Summary.declare_summary" + (str "Colliding summary names: " ++ str sumname ++ str " vs. " ++ str sumname ++ str ".") in - all_declared_summaries := Int.Set.add hash !all_declared_summaries; - summary_names := (hash, sumname) :: !summary_names; - internal_declare_summary hash sumname decl + internal_declare_summary fadd sumname decl + +let declare_summary sumname decl = + ignore(declare_summary_tag sumname decl) type frozen = { - summaries : (int * Dyn.t) list; + summaries : Dyn.t String.Map.t; (** Ordered list w.r.t. the first component. *) ml_module : Dyn.t option; (** Special handling of the ml_module summary. *) } -let empty_frozen = { summaries = []; ml_module = None; } - -let ml_modules = "ML-MODULES" -let ml_modules_summary = String.hash ml_modules +let empty_frozen = { summaries = String.Map.empty; ml_module = None } let freeze_summaries ~marshallable : frozen = - let fold id (_, decl) accu = - (* to debug missing Lazy.force - if marshallable <> `No then begin - let id, _ = Int.Map.find id !summaries in - prerr_endline ("begin marshalling " ^ id); - ignore(Marshal.to_string (decl.freeze_function marshallable) []); - prerr_endline ("end marshalling " ^ id); - end; - /debug *) - let state = decl.freeze_function marshallable in - if Int.equal id ml_modules_summary then { accu with ml_module = Some state } - else { accu with summaries = (id, state) :: accu.summaries } + let smap decl = decl.freeze_function marshallable in + { summaries = String.Map.map smap !sum_map; + ml_module = Option.map (fun decl -> decl.freeze_function marshallable) !sum_mod; + } + +let unfreeze_single name state = + let decl = + try String.Map.find name !sum_map + with + | Not_found -> + CErrors.anomaly Pp.(str "trying to unfreeze unregistered summary " ++ str name) in - Int.Map.fold_right fold !summaries empty_frozen - -let unfreeze_summaries fs = + try decl.unfreeze_function state + with e when CErrors.noncritical e -> + let e = CErrors.push e in + Feedback.msg_warning + Pp.(seq [str "Error unfreezing summary "; str name; fnl (); CErrors.iprint e]); + iraise e + +let unfreeze_summaries ?(partial=false) { summaries; ml_module } = (* The unfreezing of [ml_modules_summary] has to be anticipated since it - * may modify the content of [summaries] ny loading new ML modules *) - let (_, decl) = - try Int.Map.find ml_modules_summary !summaries - with Not_found -> anomaly (str "Undeclared summary " ++ str ml_modules ++ str ".") - in - let () = match fs.ml_module with + * may modify the content of [summaries] by loading new ML modules *) + begin match !sum_mod with | None -> anomaly (str "Undeclared summary " ++ str ml_modules ++ str ".") - | Some state -> decl.unfreeze_function state - in - let fold id (_, decl) states = - if Int.equal id ml_modules_summary then states - else match states with - | [] -> - let () = decl.init_function () in - [] - | (nid, state) :: rstates -> - if Int.equal id nid then - let () = decl.unfreeze_function state in rstates - else - let () = decl.init_function () in states + | Some decl -> Option.iter (fun state -> decl.unfreeze_function state) ml_module + end; + (** We must be independent on the order of the map! *) + let ufz name decl = + try decl.unfreeze_function String.Map.(find name summaries) + with Not_found -> + if not partial then begin + Feedback.msg_warning Pp.(str "Summary was captured out of module scope for entry " ++ str name); + decl.init_function () + end; in - let fold id decl state = - try fold id decl state - with e when CErrors.noncritical e -> - let e = CErrors.push e in - Feedback.msg_error - Pp.(seq [str "Error unfreezing summary %s\n%s\n%!"; - str (name_of_summary id); - CErrors.iprint e]); - iraise e - in - (** We rely on the order of the frozen list, and the order of folding *) - ignore (Int.Map.fold_left fold !summaries fs.summaries) + (* String.Map.iter unfreeze_single !sum_map *) + String.Map.iter ufz !sum_map let init_summaries () = - Int.Map.iter (fun _ (_, decl) -> decl.init_function ()) !summaries + String.Map.iter (fun _ decl -> decl.init_function ()) !sum_map (** For global tables registered statically before the end of coqtop launch, the following empty [init_function] could be used. *) let nop () = () -(** Selective freeze *) +(** Summary projection *) +let project_from_summary { summaries } tag = + let id = unmangle (Dyn.repr tag) in + let state = String.Map.find id summaries in + Option.get (Dyn.Easy.prj state tag) + +let modify_summary st tag v = + let id = unmangle (Dyn.repr tag) in + let summaries = String.Map.set id (Dyn.Easy.inj v tag) st.summaries in + {st with summaries} -type frozen_bits = (int * Dyn.t) list +let remove_from_summary st tag = + let id = unmangle (Dyn.repr tag) in + let summaries = String.Map.remove id st.summaries in + {st with summaries} + +(** Selective freeze *) -let ids_of_string_list complement ids = - if not complement then List.map String.hash ids - else - let fold accu id = - let id = String.hash id in - Int.Set.remove id accu - in - let ids = List.fold_left fold !all_declared_summaries ids in - Int.Set.elements ids +type frozen_bits = Dyn.t String.Map.t let freeze_summary ~marshallable ?(complement=false) ids = - let ids = ids_of_string_list complement ids in - List.map (fun id -> - let (_, summary) = Int.Map.find id !summaries in - id, summary.freeze_function marshallable) - ids - -let unfreeze_summary datas = - List.iter - (fun (id, data) -> - let (name, summary) = Int.Map.find id !summaries in - try summary.unfreeze_function data - with e -> - let e = CErrors.push e in - prerr_endline ("Exception unfreezing " ^ name); - iraise e) - datas + let sub_map = String.Map.filter (fun id _ -> complement <> List.(mem id ids)) !sum_map in + String.Map.map (fun decl -> decl.freeze_function marshallable) sub_map + +let unfreeze_summary = String.Map.iter unfreeze_single let surgery_summary { summaries; ml_module } bits = - let summaries = List.map (fun (id, _ as orig) -> - try id, List.assoc id bits - with Not_found -> orig) - summaries in + let summaries = + String.Map.fold (fun hash state sum -> String.Map.set hash state sum ) summaries bits in { summaries; ml_module } let project_summary { summaries; ml_module } ?(complement=false) ids = - let ids = ids_of_string_list complement ids in - List.filter (fun (id, _) -> List.mem id ids) summaries + String.Map.filter (fun name _ -> complement <> List.(mem name ids)) summaries let pointer_equal l1 l2 = let ptr_equal d1 d2 = @@ -174,19 +155,22 @@ let pointer_equal l1 l2 = match Dyn.eq t1 t2 with | None -> false | Some Refl -> x1 == x2 - in + in + let l1, l2 = String.Map.bindings l1, String.Map.bindings l2 in CList.for_all2eq (fun (id1,v1) (id2,v2) -> id1 = id2 && ptr_equal v1 v2) l1 l2 (** All-in-one reference declaration + registration *) -let ref ?(freeze=fun _ r -> r) ~name x = +let ref_tag ?(freeze=fun _ r -> r) ~name x = let r = ref x in - declare_summary name + let tag = declare_summary_tag name { freeze_function = (fun b -> freeze b !r); unfreeze_function = ((:=) r); - init_function = (fun () -> r := x) }; - r + init_function = (fun () -> r := x) } in + r, tag + +let ref ?freeze ~name x = fst @@ ref_tag ?freeze ~name x module Local = struct @@ -198,8 +182,7 @@ let (!) r = let key, name = !r in try CEphemeron.get key with CEphemeron.InvalidKey -> - let _, { init_function } = - Int.Map.find (String.hash (mangle name)) !summaries in + let { init_function } = String.Map.find name !sum_map in init_function (); CEphemeron.get (fst !r) diff --git a/library/summary.mli b/library/summary.mli index d093d95f29..09447199e5 100644 --- a/library/summary.mli +++ b/library/summary.mli @@ -36,6 +36,12 @@ type 'a summary_declaration = { val declare_summary : string -> 'a summary_declaration -> unit +(** We provide safe projection from the summary to the types stored in + it.*) +module Dyn : Dyn.S + +val declare_summary_tag : string -> 'a summary_declaration -> 'a Dyn.tag + (** All-in-one reference declaration + summary registration. It behaves just as OCaml's standard [ref] function, except that a [declare_summary] is done, with [name] as string. @@ -43,6 +49,7 @@ val declare_summary : string -> 'a summary_declaration -> unit The [freeze_function] can be overridden *) val ref : ?freeze:(marshallable -> 'a -> 'a) -> name:string -> 'a -> 'a ref +val ref_tag : ?freeze:(marshallable -> 'a -> 'a) -> name:string -> 'a -> 'a ref * 'a Dyn.tag (* As [ref] but the value is local to a process, i.e. not sent to, say, proof * workers. It is useful to implement a local cache for example. *) @@ -55,10 +62,11 @@ module Local : sig end -(** Special name for the summary of ML modules. This summary entry is - special because its unfreeze may load ML code and hence add summary - entries. Thus is has to be recognizable, and handled appropriately *) -val ml_modules : string +(** Special summary for ML modules. This summary entry is special + because its unfreeze may load ML code and hence add summary + entries. Thus is has to be recognizable, and handled properly. + *) +val declare_ml_modules_summary : 'a summary_declaration -> unit (** For global tables registered statically before the end of coqtop launch, the following empty [init_function] could be used. *) @@ -72,19 +80,34 @@ type frozen val empty_frozen : frozen val freeze_summaries : marshallable:marshallable -> frozen -val unfreeze_summaries : frozen -> unit +val unfreeze_summaries : ?partial:bool -> frozen -> unit val init_summaries : unit -> unit -(** The type [frozen_bits] is a snapshot of some of the registered tables *) +(** Typed projection of the summary. Experimental API, use with CARE *) + +val modify_summary : frozen -> 'a Dyn.tag -> 'a -> frozen +val project_from_summary : frozen -> 'a Dyn.tag -> 'a +val remove_from_summary : frozen -> 'a Dyn.tag -> frozen + +(** The type [frozen_bits] is a snapshot of some of the registered + tables. It is DEPRECATED in favor of the typed projection + version. *) + type frozen_bits +[@@ocaml.deprecated "Please use the typed version of summary projection"] -val freeze_summary : - marshallable:marshallable -> ?complement:bool -> string list -> frozen_bits +[@@@ocaml.warning "-3"] +val freeze_summary : marshallable:marshallable -> ?complement:bool -> string list -> frozen_bits +[@@ocaml.deprecated "Please use the typed version of summary projection"] val unfreeze_summary : frozen_bits -> unit +[@@ocaml.deprecated "Please use the typed version of summary projection"] val surgery_summary : frozen -> frozen_bits -> frozen +[@@ocaml.deprecated "Please use the typed version of summary projection"] val project_summary : frozen -> ?complement:bool -> string list -> frozen_bits +[@@ocaml.deprecated "Please use the typed version of summary projection"] val pointer_equal : frozen_bits -> frozen_bits -> bool +[@@ocaml.deprecated "Please use the typed version of summary projection"] +[@@@ocaml.warning "+3"] (** {6 Debug} *) - val dump : unit -> (int * string) list diff --git a/library/univops.ml b/library/univops.ml deleted file mode 100644 index 9dc138eb8d..0000000000 --- a/library/univops.ml +++ /dev/null @@ -1,40 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -open Constr -open Univ - -let universes_of_constr c = - let rec aux s c = - match kind c with - | Const (_, u) | Ind (_, u) | Construct (_, u) -> - LSet.fold LSet.add (Instance.levels u) s - | Sort u when not (Sorts.is_small u) -> - let u = Term.univ_of_sort u in - LSet.fold LSet.add (Universe.levels u) s - | _ -> Constr.fold aux s c - in aux LSet.empty c - -let restrict_universe_context (univs,csts) s = - (* Universes that are not necessary to typecheck the term. - E.g. univs introduced by tactics and not used in the proof term. *) - let diff = LSet.diff univs s in - let rec aux diff candid univs ness = - let (diff', candid', univs', ness') = - Constraint.fold - (fun (l, d, r as c) (diff, candid, univs, csts) -> - if not (LSet.mem l diff) then - (LSet.remove r diff, candid, univs, Constraint.add c csts) - else if not (LSet.mem r diff) then - (LSet.remove l diff, candid, univs, Constraint.add c csts) - else (diff, Constraint.add c candid, univs, csts)) - candid (diff, Constraint.empty, univs, ness) - in - if ness' == ness then (LSet.diff univs diff', ness) - else aux diff' candid' univs' ness' - in aux diff csts univs Constraint.empty diff --git a/man/coqchk.1 b/man/coqchk.1 index 76a7cfc5d2..f9241c0d47 100644 --- a/man/coqchk.1 +++ b/man/coqchk.1 @@ -23,7 +23,7 @@ library was not found, corrupted content, type-checking failure, etc. .IR modules \& is a list of modules to be checked. Modules can be referred to by a -short or qualified name. +short or qualified logical name, or by their filename. .SH OPTIONS @@ -34,13 +34,17 @@ add directory in the include path .TP -.BI \-R \ dir\ coqdir -recursively map physical +.BI \-Q \ dir\ coqdir +map physical .I dir to logical .I coqdir .TP +.BI \-R \ dir\ coqdir +synonymous for -Q + +.TP .BI \-silent makes coqchk less verbose. diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index d51b8b54e5..9c2766187e 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -35,7 +35,7 @@ let default_levels = 100,Extend.RightA,false; 99,Extend.RightA,true; 90,Extend.RightA,true; - 10,Extend.RightA,false; + 10,Extend.LeftA,false; 9,Extend.RightA,false; 8,Extend.RightA,true; 1,Extend.LeftA,false; @@ -46,8 +46,7 @@ let default_pattern_levels = 100,Extend.RightA,false; 99,Extend.RightA,true; 90,Extend.RightA,true; - 11,Extend.LeftA,false; - 10,Extend.RightA,false; + 10,Extend.LeftA,false; 1,Extend.LeftA,false; 0,Extend.RightA,false] @@ -259,9 +258,11 @@ let is_binder_level from e = match e with | (NumLevel 200, (BorderProd (Right, _) | InternalProd)) -> from = 200 | _ -> false -let make_sep_rules tkl = - let rec mkrule : Tok.t list -> unit rules = function - | [] -> Rules ({ norec_rule = Stop }, ignore) +let make_sep_rules = function + | [tk] -> Atoken tk + | tkl -> + let rec mkrule : Tok.t list -> string rules = function + | [] -> Rules ({ norec_rule = Stop }, fun _ -> (* dropped anyway: *) "") | tkn :: rem -> let Rules ({ norec_rule = r }, f) = mkrule rem in let r = { norec_rule = Next (r, Atoken tkn) } in @@ -440,7 +441,7 @@ let make_act : type r. r target -> _ -> r gen_eval = function CAst.make ~loc @@ CNotation (notation , env) | ForPattern -> fun notation loc env -> let invalid = List.exists (fun (_, b) -> not b) env.binders in - let () = if invalid then Topconstr.error_invalid_pattern_notation ~loc () in + let () = if invalid then Constrexpr_ops.error_invalid_pattern_notation ~loc () in let env = (env.constrs, env.constrlists) in CAst.make ~loc @@ CPatNotation (notation, env, []) diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index 844c040fdf..0cf96d487b 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -155,9 +155,15 @@ GEXTEND Gram | "Type" -> Sorts.InType ] ] ; + universe_expr: + [ [ id = global; "+"; n = natural -> Some (id,n) + | id = global -> Some (id,0) + | "_" -> None + ] ] + ; universe: - [ [ IDENT "max"; "("; ids = LIST1 name SEP ","; ")" -> ids - | id = name -> [id] + [ [ IDENT "max"; "("; ids = LIST1 universe_expr SEP ","; ")" -> ids + | u = universe_expr -> [u] ] ] ; lconstr: @@ -307,8 +313,9 @@ GEXTEND Gram universe_level: [ [ "Set" -> GSet | "Prop" -> GProp - | "Type" -> GType None - | id = name -> GType (Some id) + | "Type" -> GType UUnknown + | "_" -> GType UAnonymous + | id = global -> GType (UNamed id) ] ] ; fix_constr: @@ -377,11 +384,10 @@ GEXTEND Gram [ p = pattern; "|"; pl = LIST1 pattern SEP "|" -> CAst.make ~loc:!@loc @@ CPatOr (p::pl) ] | "99" RIGHTA [ ] | "90" RIGHTA [ ] - | "11" LEFTA + | "10" LEFTA [ p = pattern; "as"; id = ident -> - CAst.make ~loc:!@loc @@ CPatAlias (p, id) ] - | "10" RIGHTA - [ p = pattern; lp = LIST1 NEXT -> + CAst.make ~loc:!@loc @@ CPatAlias (p, id) + | p = pattern; lp = LIST1 NEXT -> (let open CAst in match p with | { v = CPatAtom (Some r) } -> CAst.make ~loc:!@loc @@ CPatCstr (r, None, lp) | { v = CPatCstr (r, None, l2); loc } -> @@ -392,7 +398,7 @@ GEXTEND Gram | _ -> CErrors.user_err ?loc:(cases_pattern_expr_loc p) ~hdr:"compound_pattern" (Pp.str "Such pattern cannot have arguments.")) - |"@"; r = Prim.reference; lp = LIST0 NEXT -> + | "@"; r = Prim.reference; lp = LIST0 NEXT -> CAst.make ~loc:!@loc @@ CPatCstr (r, Some lp, []) ] | "1" LEFTA [ c = pattern; "%"; key=IDENT -> CAst.make ~loc:!@loc @@ CPatDelimiters (key,c) ] diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4 index f10d746770..d88f6fa0dc 100644 --- a/parsing/g_proofs.ml4 +++ b/parsing/g_proofs.ml4 @@ -70,19 +70,16 @@ GEXTEND Gram VernacCreateHintDb (id, b) | IDENT "Remove"; IDENT "Hints"; ids = LIST1 global; dbnames = opt_hintbases -> VernacRemoveHints (dbnames, ids) - | IDENT "Hint"; local = obsolete_locality; h = hint; + | IDENT "Hint"; h = hint; dbnames = opt_hintbases -> - VernacHints (local,dbnames, h) + VernacHints (dbnames, h) (* Declare "Resolve" explicitly so as to be able to later extend with "Resolve ->" and "Resolve <-" *) | IDENT "Hint"; IDENT "Resolve"; lc = LIST1 reference_or_constr; info = hint_info; dbnames = opt_hintbases -> - VernacHints (false,dbnames, + VernacHints (dbnames, HintsResolve (List.map (fun x -> (info, true, x)) lc)) ] ]; - obsolete_locality: - [ [ IDENT "Local" -> true | -> false ] ] - ; reference_or_constr: [ [ r = global -> HintsReference r | c = constr -> HintsConstr c ] ] diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index a5b58b8553..444f36833b 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -129,16 +129,10 @@ let test_plural_form_types loc kwd = function warn_plural_command ~loc:!@loc kwd | _ -> () -let fresh_var env c = - Namegen.next_ident_away (Id.of_string "pat") - (List.fold_left (fun accu id -> Id.Set.add id accu) (Topconstr.free_vars_of_constr_expr c) env) - -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 ident_decl; + record_field decl_notation rec_definition ident_decl; gallina: (* Definition, Theorem, Variable, Axiom, ... *) @@ -155,7 +149,7 @@ GEXTEND Gram | 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) + VernacDefinition ((DoDischarge, Let), (id, None), b) (* Gallina inductive declarations *) | cum = cumulativity_token; priv = private_token; f = finite_token; indl = LIST1 inductive_definition SEP "with" -> @@ -173,13 +167,13 @@ GEXTEND Gram in VernacInductive (cum, priv,f,indl) | "Fixpoint"; recs = LIST1 rec_definition SEP "with" -> - VernacFixpoint (None, recs) + VernacFixpoint (NoDischarge, recs) | IDENT "Let"; "Fixpoint"; recs = LIST1 rec_definition SEP "with" -> - VernacFixpoint (Some Discharge, recs) + VernacFixpoint (DoDischarge, recs) | "CoFixpoint"; corecs = LIST1 corec_definition SEP "with" -> - VernacCoFixpoint (None, corecs) + VernacCoFixpoint (NoDischarge, corecs) | IDENT "Let"; "CoFixpoint"; corecs = LIST1 corec_definition SEP "with" -> - VernacCoFixpoint (Some Discharge, corecs) + VernacCoFixpoint (DoDischarge, corecs) | IDENT "Scheme"; l = LIST1 scheme SEP "with" -> VernacScheme l | IDENT "Combined"; IDENT "Scheme"; id = identref; IDENT "from"; l = LIST1 identref SEP "," -> VernacCombinedScheme (id, l) @@ -201,23 +195,23 @@ GEXTEND Gram | IDENT "Property" -> Property ] ] ; def_token: - [ [ "Definition" -> (None, Definition) - | IDENT "Example" -> (None, Example) - | IDENT "SubClass" -> (None, SubClass) ] ] + [ [ "Definition" -> (NoDischarge,Definition) + | IDENT "Example" -> (NoDischarge,Example) + | IDENT "SubClass" -> (NoDischarge,SubClass) ] ] ; assumption_token: - [ [ "Hypothesis" -> (Some Discharge, Logical) - | "Variable" -> (Some Discharge, Definitional) - | "Axiom" -> (None, Logical) - | "Parameter" -> (None, Definitional) - | IDENT "Conjecture" -> (None, Conjectural) ] ] + [ [ "Hypothesis" -> (DoDischarge, Logical) + | "Variable" -> (DoDischarge, Definitional) + | "Axiom" -> (NoDischarge, Logical) + | "Parameter" -> (NoDischarge, Definitional) + | IDENT "Conjecture" -> (NoDischarge, Conjectural) ] ] ; assumptions_token: - [ [ IDENT "Hypotheses" -> ("Hypotheses", (Some Discharge, Logical)) - | IDENT "Variables" -> ("Variables", (Some Discharge, Definitional)) - | IDENT "Axioms" -> ("Axioms", (None, Logical)) - | IDENT "Parameters" -> ("Parameters", (None, Definitional)) - | IDENT "Conjectures" -> ("Conjectures", (None, Conjectural)) ] ] + [ [ IDENT "Hypotheses" -> ("Hypotheses", (DoDischarge, Logical)) + | IDENT "Variables" -> ("Variables", (DoDischarge, Definitional)) + | IDENT "Axioms" -> ("Axioms", (NoDischarge, Logical)) + | IDENT "Parameters" -> ("Parameters", (NoDischarge, Definitional)) + | IDENT "Conjectures" -> ("Conjectures", (NoDischarge, Conjectural)) ] ] ; inline: [ [ IDENT "Inline"; "("; i = INT; ")" -> InlineAt (int_of_string i) @@ -228,9 +222,6 @@ GEXTEND Gram [ [ 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 ","; @@ -629,34 +620,22 @@ GEXTEND Gram | IDENT "Canonical"; IDENT "Structure"; qid = global; d = def_body -> let s = coerce_reference_to_id qid in - VernacDefinition - ((Some Global,CanonicalStructure),((Loc.tag s),None),d) + VernacLocal(false, + VernacDefinition ((NoDischarge,CanonicalStructure),((Loc.tag s),None),d)) (* Coercions *) | IDENT "Coercion"; qid = global; d = def_body -> let s = coerce_reference_to_id qid in - VernacDefinition ((None,Coercion),((Loc.tag s),None),d) - | IDENT "Coercion"; IDENT "Local"; qid = global; d = def_body -> - let s = coerce_reference_to_id qid in - VernacDefinition ((Some Decl_kinds.Local,Coercion),((Loc.tag s),None),d) - | IDENT "Identity"; IDENT "Coercion"; IDENT "Local"; f = identref; - ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> - VernacIdentityCoercion (true, f, s, t) + VernacDefinition ((NoDischarge,Coercion),((Loc.tag s),None),d) | IDENT "Identity"; IDENT "Coercion"; f = identref; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> - VernacIdentityCoercion (false, f, s, t) - | IDENT "Coercion"; IDENT "Local"; qid = global; ":"; - s = class_rawexpr; ">->"; t = class_rawexpr -> - VernacCoercion (true, AN qid, s, t) - | IDENT "Coercion"; IDENT "Local"; ntn = by_notation; ":"; - s = class_rawexpr; ">->"; t = class_rawexpr -> - VernacCoercion (true, ByNotation ntn, s, t) + VernacIdentityCoercion (f, s, t) | IDENT "Coercion"; qid = global; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> - VernacCoercion (false, AN qid, s, t) + VernacCoercion (AN qid, s, t) | IDENT "Coercion"; ntn = by_notation; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> - VernacCoercion (false, ByNotation ntn, s, t) + VernacCoercion (ByNotation ntn, s, t) | IDENT "Context"; c = binders -> VernacContext c @@ -884,7 +863,7 @@ GEXTEND Gram (* Printing (careful factorization of entries) *) | IDENT "Print"; p = printable -> VernacPrint p - | IDENT "Print"; qid = smart_global -> VernacPrint (PrintName qid) + | IDENT "Print"; qid = smart_global; l = OPT univ_name_list -> VernacPrint (PrintName (qid,l)) | IDENT "Print"; IDENT "Module"; "Type"; qid = global -> VernacPrint (PrintModuleType qid) | IDENT "Print"; IDENT "Module"; qid = global -> @@ -949,8 +928,8 @@ GEXTEND Gram | IDENT "Check"; c = lconstr; "." -> fun g -> VernacCheckMayEval (None, g, c) (* Searching the environment *) - | IDENT "About"; qid = smart_global; "." -> - fun g -> VernacPrint (PrintAbout (qid,g)) + | IDENT "About"; qid = smart_global; l = OPT univ_name_list; "." -> + fun g -> VernacPrint (PrintAbout (qid,l,g)) | IDENT "SearchHead"; c = constr_pattern; l = in_or_out_modules; "." -> fun g -> VernacSearch (SearchHead c,g, l) | IDENT "SearchPattern"; c = constr_pattern; l = in_or_out_modules; "." -> @@ -969,7 +948,7 @@ GEXTEND Gram ] ] ; printable: - [ [ IDENT "Term"; qid = smart_global -> PrintName qid + [ [ IDENT "Term"; qid = smart_global; l = OPT univ_name_list -> PrintName (qid,l) | IDENT "All" -> PrintFullContext | IDENT "Section"; s = global -> PrintSectionContext s | IDENT "Grammar"; ent = IDENT -> @@ -1069,6 +1048,9 @@ GEXTEND Gram | -> ([],SearchOutside []) ] ] ; + univ_name_list: + [ [ "@{" ; l = LIST0 name; "}" -> l ] ] + ; END; GEXTEND Gram @@ -1112,11 +1094,11 @@ GEXTEND Gram GLOBAL: syntax; syntax: - [ [ IDENT "Open"; local = obsolete_locality; IDENT "Scope"; sc = IDENT -> - VernacOpenCloseScope (local,(true,sc)) + [ [ IDENT "Open"; IDENT "Scope"; sc = IDENT -> + VernacOpenCloseScope (true,sc) - | IDENT "Close"; local = obsolete_locality; IDENT "Scope"; sc = IDENT -> - VernacOpenCloseScope (local,(false,sc)) + | IDENT "Close"; IDENT "Scope"; sc = IDENT -> + VernacOpenCloseScope (false,sc) | IDENT "Delimit"; IDENT "Scope"; sc = IDENT; "with"; key = IDENT -> VernacDelimiters (sc, Some key) @@ -1126,32 +1108,31 @@ GEXTEND Gram | IDENT "Bind"; IDENT "Scope"; sc = IDENT; "with"; refl = LIST1 class_rawexpr -> VernacBindScope (sc,refl) - | IDENT "Infix"; local = obsolete_locality; - op = ne_lstring; ":="; p = constr; + | IDENT "Infix"; op = ne_lstring; ":="; p = constr; modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]; sc = OPT [ ":"; sc = IDENT -> sc ] -> - VernacInfix (local,(op,modl),p,sc) - | IDENT "Notation"; local = obsolete_locality; id = identref; + VernacInfix ((op,modl),p,sc) + | IDENT "Notation"; id = identref; idl = LIST0 ident; ":="; c = constr; b = only_parsing -> VernacSyntacticDefinition - (id,(idl,c),local,b) - | IDENT "Notation"; local = obsolete_locality; s = lstring; ":="; + (id,(idl,c),b) + | IDENT "Notation"; s = lstring; ":="; c = constr; modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]; sc = OPT [ ":"; sc = IDENT -> sc ] -> - VernacNotation (local,c,(s,modl),sc) + VernacNotation (c,(s,modl),sc) | IDENT "Format"; IDENT "Notation"; n = STRING; s = STRING; fmt = STRING -> VernacNotationAddFormat (n,s,fmt) | IDENT "Reserved"; IDENT "Infix"; s = ne_lstring; l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ] -> let (loc,s) = s in - VernacSyntaxExtension (true, false,((loc,"x '"^s^"' y"),l)) + VernacSyntaxExtension (true,((loc,"x '"^s^"' y"),l)) - | IDENT "Reserved"; IDENT "Notation"; local = obsolete_locality; + | IDENT "Reserved"; IDENT "Notation"; s = ne_lstring; l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ] - -> VernacSyntaxExtension (false, local,(s,l)) + -> VernacSyntaxExtension (false, (s,l)) (* "Print" "Grammar" should be here but is in "command" entry in order to factorize with other "Print"-based vernac entries *) @@ -1164,9 +1145,6 @@ GEXTEND Gram Some (parse_compat_version s) | -> None ] ] ; - obsolete_locality: - [ [ IDENT "Local" -> true | -> false ] ] - ; level: [ [ IDENT "level"; n = natural -> NumLevel n | IDENT "next"; IDENT "level" -> NextLevel ] ] diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index d34da159ee..b766f0c6bb 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -444,7 +444,6 @@ 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" @@ -612,8 +611,8 @@ let unfreeze (grams, lex) = the lexer state should not be resetted, since it contains keywords declared in g_*.ml4 *) -let _ = - Summary.declare_summary "GRAMMAR_LEXER" +let parser_summary_tag = + Summary.declare_summary_tag "GRAMMAR_LEXER" { Summary.freeze_function = freeze; Summary.unfreeze_function = unfreeze; Summary.init_function = Summary.nop } diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 2f03754193..3ca013a968 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -194,7 +194,6 @@ module Prim : val ident : Id.t Gram.entry 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 @@ -314,3 +313,6 @@ val with_grammar_rule_protection : ('a -> 'b) -> 'a -> 'b (** Location Utils *) val to_coqloc : Ploc.t -> Loc.t val (!@) : Ploc.t -> Loc.t + +type frozen_t +val parser_summary_tag : frozen_t Summary.Dyn.tag diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index da8955f0d7..a09abfa193 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -200,7 +200,8 @@ module Btauto = struct let assign = List.combine env var in let map_msg (key, v) = let b = if v then str "true" else str "false" in - let term = Printer.pr_constr key in + let sigma, env = Pfedit.get_current_context () in + let term = Printer.pr_constr_env env sigma key in term ++ spc () ++ str ":=" ++ spc () ++ b in let assign = List.map map_msg assign in diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index faabd7c143..ccef9ab960 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -12,13 +12,13 @@ open CErrors open Pp -open Goptions open Names -open Term +open Sorts open Constr open Vars -open Tacmach open Evd +open Goptions +open Tacmach open Util let init_size=5 @@ -437,7 +437,7 @@ and make_app l=function and applist_proj c l = match c with | Symb s -> applist_projection s l - | _ -> applistc (constr_of_term c) l + | _ -> Term.applistc (constr_of_term c) l and applist_projection c l = match Constr.kind c with | Const c when Environ.is_projection (fst c) (Global.env()) -> @@ -447,10 +447,10 @@ and applist_projection c l = let ty = Typeops.type_of_constant_in (Global.env ()) c in (* FIXME constraints *) let pb = Environ.lookup_projection p (Global.env()) in let ctx,_ = Term.decompose_prod_n_assum (pb.Declarations.proj_npars + 1) ty in - it_mkLambda_or_LetIn (mkProj(p,mkRel 1)) ctx + Term.it_mkLambda_or_LetIn (mkProj(p,mkRel 1)) ctx | hd :: tl -> - applistc (mkProj (p, hd)) tl) - | _ -> applistc c l + Term.applistc (mkProj (p, hd)) tl) + | _ -> Term.applistc c l let rec canonize_name sigma c = let c = EConstr.Unsafe.to_constr c in @@ -838,7 +838,7 @@ let complete_one_class state i= let _args = List.map (fun i -> constr_of_term (term state.uf i)) pac.args in - let typ = prod_applist _c (List.rev _args) in + let typ = Term.prod_applist _c (List.rev _args) in let ct = app (term state.uf i) typ pac.arity in state.uf.epsilons <- pac :: state.uf.epsilons; ignore (add_term state ct) diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 7dec34d4d7..8642df6846 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -12,7 +12,6 @@ open Evd open Names open Inductiveops open Declarations -open Term open Constr open EConstr open Vars diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 47e8123191..4ae875cd70 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -302,7 +302,7 @@ let rec extract_type env db j c args = if Projection.unfolded p then Tunknown else extract_type env db j (mkProj (Projection.unfold p, t)) args | Case _ | Fix _ | CoFix _ -> Tunknown - | _ -> assert false + | Var _ | Meta _ | Evar _ | Cast _ | LetIn _ | Construct _ -> assert false (*s Auxiliary function dealing with type application. Precondition: [r] is a type scheme represented by the signature [s], diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index 9cbc3fd713..5d0f9c167e 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -100,11 +100,41 @@ let pp_global k r = str (str_global k r) let pp_modname mp = str (Common.pp_module mp) +(* grammar from OCaml 4.06 manual, "Prefix and infix symbols" *) + +let infix_symbols = + ['=' ; '<' ; '>' ; '@' ; '^' ; ';' ; '&' ; '+' ; '-' ; '*' ; '/' ; '$' ; '%' ] +let operator_chars = + [ '!' ; '$' ; '%' ; '&' ; '*' ; '+' ; '-' ; '.' ; '/' ; ':' ; '<' ; '=' ; '>' ; '?' ; '@' ; '^' ; '|' ; '~' ] + +(* infix ops in OCaml, but disallowed by preceding grammar *) + +let builtin_infixes = + [ "::" ; "," ] + +let substring_all_opchars s start stop = + let rec check_char i = + if i >= stop then true + else + List.mem s.[i] operator_chars && check_char (i+1) + in + check_char start + let is_infix r = is_inline_custom r && (let s = find_custom r in - let l = String.length s in - l >= 2 && s.[0] == '(' && s.[l-1] == ')') + let len = String.length s in + len >= 3 && + (* parenthesized *) + (s.[0] == '(' && s.[len-1] == ')' && + let inparens = String.trim (String.sub s 1 (len - 2)) in + let inparens_len = String.length inparens in + (* either, begins with infix symbol, any remainder is all operator chars *) + (List.mem inparens.[0] infix_symbols && substring_all_opchars inparens 1 inparens_len) || + (* or, starts with #, at least one more char, all are operator chars *) + (inparens.[0] == '#' && inparens_len >= 2 && substring_all_opchars inparens 1 inparens_len) || + (* or, is an OCaml built-in infix *) + (List.mem inparens builtin_infixes))) let get_infix r = let s = find_custom r in diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index 995d5fd19d..5903733a66 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -486,7 +486,7 @@ let check_loaded_modfile mp = match base_mp mp with if not (Library.library_is_loaded dp) then begin match base_mp (Lib.current_mp ()) with | MPfile dp' when not (DirPath.equal dp dp') -> - err (str "Please load library " ++ pr_dirpath dp ++ str " first.") + err (str "Please load library " ++ DirPath.print dp ++ str " first.") | _ -> () end | _ -> () diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4 index 1e7da3250b..938bec25b9 100644 --- a/plugins/firstorder/g_ground.ml4 +++ b/plugins/firstorder/g_ground.ml4 @@ -65,11 +65,14 @@ let default_intuition_tac = let (set_default_solver, default_solver, print_default_solver) = Tactic_option.declare_tactic_option ~default:default_intuition_tac "Firstorder default solver" -VERNAC COMMAND EXTEND Firstorder_Set_Solver CLASSIFIED AS SIDEFF +VERNAC COMMAND FUNCTIONAL EXTEND Firstorder_Set_Solver CLASSIFIED AS SIDEFF | [ "Set" "Firstorder" "Solver" tactic(t) ] -> [ - set_default_solver - (Locality.make_section_locality (Locality.LocalityFixme.consume ())) - (Tacintern.glob_tactic t) ] + fun ~atts ~st -> let open Vernacinterp in + set_default_solver + (Locality.make_section_locality atts.locality) + (Tacintern.glob_tactic t); + st + ] END VERNAC COMMAND EXTEND Firstorder_Print_Solver CLASSIFIED AS QUERY diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml index f660ba7343..d462013353 100644 --- a/plugins/firstorder/ground.ml +++ b/plugins/firstorder/ground.ml @@ -11,7 +11,7 @@ open Formula open Sequent open Rules open Instances -open Term +open Constr open Tacmach.New open Tacticals.New diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index d6309b057f..1a6eba8c62 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -235,8 +235,8 @@ let constant str = Universes.constr_of_global @@ Coqlib.coq_reference "User" ["Init";"Logic"] str let defined_connectives=lazy - [AllOccurrences,EvalConstRef (fst (Term.destConst (constant "not"))); - AllOccurrences,EvalConstRef (fst (Term.destConst (constant "iff")))] + [AllOccurrences,EvalConstRef (fst (Constr.destConst (constant "not"))); + AllOccurrences,EvalConstRef (fst (Constr.destConst (constant "iff")))] let normalize_evaluables= Proofview.Goal.enter begin fun gl -> diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index bd5fb1d923..62ca706264 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -1,7 +1,7 @@ open Printer open CErrors open Util -open Term +open Constr open EConstr open Vars open Namegen @@ -44,6 +44,10 @@ let observe_tac s tac g = observe_tac_stream (str s) tac g *) +let pr_leconstr_fp = + let sigma, env = Pfedit.get_current_context () in + Printer.pr_leconstr_env env sigma + let debug_queue = Stack.create () let rec print_debug_queue e = @@ -172,7 +176,7 @@ let is_incompatible_eq sigma t = | _ -> false with e when CErrors.noncritical e -> false in - if res then observe (str "is_incompatible_eq " ++ Printer.pr_leconstr t); + if res then observe (str "is_incompatible_eq " ++ pr_leconstr_fp t); res let change_hyp_with_using msg hyp_id t tac : tactic = @@ -220,7 +224,8 @@ let find_rectype env sigma c = let isAppConstruct ?(env=Global.env ()) sigma t = try let t',l = find_rectype env sigma t in - observe (str "isAppConstruct : " ++ Printer.pr_leconstr t ++ str " -> " ++ Printer.pr_leconstr (applist (t',l))); + observe (str "isAppConstruct : " ++ Printer.pr_leconstr_env env sigma t ++ str " -> " ++ + Printer.pr_leconstr_env env sigma (applist (t',l))); true with Not_found -> false @@ -233,7 +238,8 @@ exception NoChange let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = let nochange ?t' msg = begin - observe (str ("Not treating ( "^msg^" )") ++ pr_leconstr t ++ str " " ++ match t' with None -> str "" | Some t -> Printer.pr_leconstr t ); + observe (str ("Not treating ( "^msg^" )") ++ pr_leconstr_env env sigma t ++ str " " ++ + match t' with None -> str "" | Some t -> Printer.pr_leconstr_env env sigma t ); raise NoChange; end in @@ -841,7 +847,7 @@ let build_proof | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") and build_proof do_finalize dyn_infos g = (* observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *) - observe_tac_stream (str "build_proof with " ++ Printer.pr_leconstr dyn_infos.info ) (build_proof_aux do_finalize dyn_infos) g + observe_tac_stream (str "build_proof with " ++ pr_leconstr_fp dyn_infos.info ) (build_proof_aux do_finalize dyn_infos) g and build_proof_args do_finalize dyn_infos (* f_args' args *) :tactic = fun g -> let (f_args',args) = dyn_infos.info in @@ -1135,7 +1141,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam princ_params ); observe (str "fbody_with_full_params := " ++ - pr_leconstr fbody_with_full_params + pr_leconstr_env (Global.env ()) !evd fbody_with_full_params ); let all_funs_with_full_params = Array.map (fun f -> applist(f, List.rev_map var_of_decl full_params)) all_funs diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 722dbc16b5..7a9bbd92cf 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -1,7 +1,8 @@ open Printer open CErrors -open Util open Term +open Sorts +open Util open Constr open Vars open Namegen @@ -115,7 +116,9 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let dummy_var = mkVar (Id.of_string "________") in let mk_replacement c i args = let res = mkApp(rel_to_fun.(i), Array.map pop (array_get_start args)) in - observe (str "replacing " ++ pr_lconstr c ++ str " by " ++ pr_lconstr res); + observe (str "replacing " ++ + pr_lconstr_env env Evd.empty c ++ str " by " ++ + pr_lconstr_env env Evd.empty res); res in let rec compute_new_princ_type remove env pre_princ : types*(constr list) = @@ -345,8 +348,11 @@ let generate_functional_principle (evd: Evd.evar_map ref) 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 + let univs = + let poly = Flags.is_universe_polymorphism () in + Evd.const_univ_entry ~poly evd' + in + let ce = Declare.definition_entry ~univs value in ignore( Declare.declare_constant name @@ -565,7 +571,7 @@ let make_scheme evd (fas : (pconstant*Sorts.family) list) : Safe_typing.private_ List.map (* we can now compute the other principles *) (fun scheme_type -> incr i; - observe (Printer.pr_lconstr scheme_type); + observe (Printer.pr_lconstr_env env sigma scheme_type); let type_concl = (strip_prod_assum scheme_type) in let applied_f = List.hd (List.rev (snd (decompose_app type_concl))) in let f = fst (decompose_app applied_f) in @@ -577,8 +583,8 @@ let make_scheme evd (fas : (pconstant*Sorts.family) list) : Safe_typing.private_ let g = fst (decompose_app applied_g) in if Constr.equal f g then raise (Found_type j); - observe (Printer.pr_lconstr f ++ str " <> " ++ - Printer.pr_lconstr g) + observe (Printer.pr_lconstr_env env sigma f ++ str " <> " ++ + Printer.pr_lconstr_env env sigma g) ) ta; diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 829556a71e..87609296bc 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -154,7 +154,7 @@ VERNAC COMMAND EXTEND Function | _,((_,(_,CStructRec),_,_,_),_) -> false) recsl in match Vernac_classifier.classify_vernac - (Vernacexpr.VernacFixpoint(None, List.map snd recsl)) + (Vernacexpr.VernacFixpoint(Decl_kinds.NoDischarge, List.map snd recsl)) with | Vernacexpr.VtSideff ids, _ when hard -> Vernacexpr.(VtStartProof ("Classic", GuaranteesOpacity, ids), VtLater) diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 8ab6dbcdf3..fa43536304 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -1,7 +1,6 @@ open Printer open Pp open Names -open Term open Constr open Vars open Glob_term @@ -379,29 +378,30 @@ let add_pat_variables pat typ env : Environ.env = fst ( Context.Rel.fold_outside (fun decl (env,ctxt) -> - let open Context.Rel.Declaration in - match decl with + let open Context.Rel.Declaration in + let sigma, _ = Pfedit.get_current_context () in + match decl with | LocalAssum (Anonymous,_) | LocalDef (Anonymous,_,_) -> assert false | LocalAssum (Name id, t) -> - let new_t = substl ctxt t in - observe (str "for variable " ++ Ppconstr.pr_id id ++ fnl () ++ - str "old type := " ++ Printer.pr_lconstr t ++ fnl () ++ - str "new type := " ++ Printer.pr_lconstr new_t ++ fnl () - ); - let open Context.Named.Declaration in - (Environ.push_named (LocalAssum (id,new_t)) env,mkVar id::ctxt) - | LocalDef (Name id, v, t) -> - let new_t = substl ctxt t in - let new_v = substl ctxt v in - observe (str "for variable " ++ Ppconstr.pr_id id ++ fnl () ++ - str "old type := " ++ Printer.pr_lconstr t ++ fnl () ++ - str "new type := " ++ Printer.pr_lconstr new_t ++ fnl () ++ - str "old value := " ++ Printer.pr_lconstr v ++ fnl () ++ - str "new value := " ++ Printer.pr_lconstr new_v ++ fnl () - ); - let open Context.Named.Declaration in - (Environ.push_named (LocalDef (id,new_v,new_t)) env,mkVar id::ctxt) - ) + let new_t = substl ctxt t in + observe (str "for variable " ++ Ppconstr.pr_id id ++ fnl () ++ + str "old type := " ++ Printer.pr_lconstr_env env sigma t ++ fnl () ++ + str "new type := " ++ Printer.pr_lconstr_env env sigma new_t ++ fnl () + ); + let open Context.Named.Declaration in + (Environ.push_named (LocalAssum (id,new_t)) env,mkVar id::ctxt) + | LocalDef (Name id, v, t) -> + let new_t = substl ctxt t in + let new_v = substl ctxt v in + observe (str "for variable " ++ Ppconstr.pr_id id ++ fnl () ++ + str "old type := " ++ Printer.pr_lconstr_env env sigma t ++ fnl () ++ + str "new type := " ++ Printer.pr_lconstr_env env sigma new_t ++ fnl () ++ + str "old value := " ++ Printer.pr_lconstr_env env sigma v ++ fnl () ++ + str "new value := " ++ Printer.pr_lconstr_env env sigma new_v ++ fnl () + ); + let open Context.Named.Declaration in + (Environ.push_named (LocalDef (id,new_v,new_t)) env,mkVar id::ctxt) + ) (Environ.rel_context new_env) ~init:(env,[]) ) @@ -479,7 +479,7 @@ let rec pattern_to_term_and_type env typ = DAst.with_val (function let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = - observe (str " Entering : " ++ Printer.pr_glob_constr rt); + observe (str " Entering : " ++ Printer.pr_glob_constr_env env rt); let open CAst in match DAst.get rt with | GRef _ | GVar _ | GEvar _ | GPatVar _ | GSort _ | GHole _ -> @@ -652,8 +652,8 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = try Inductiveops.find_inductive env (Evd.from_env env) b_typ with Not_found -> user_err (str "Cannot find the inductive associated to " ++ - Printer.pr_glob_constr b ++ str " in " ++ - Printer.pr_glob_constr rt ++ str ". try again with a cast") + Printer.pr_glob_constr_env env b ++ str " in " ++ + Printer.pr_glob_constr_env env rt ++ str ". try again with a cast") in let case_pats = build_constructors_of_type (fst ind) [] in assert (Int.equal (Array.length case_pats) 2); @@ -684,8 +684,8 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = try Inductiveops.find_inductive env (Evd.from_env env) b_typ with Not_found -> user_err (str "Cannot find the inductive associated to " ++ - Printer.pr_glob_constr b ++ str " in " ++ - Printer.pr_glob_constr rt ++ str ". try again with a cast") + Printer.pr_glob_constr_env env b ++ str " in " ++ + Printer.pr_glob_constr_env env rt ++ str ". try again with a cast") in let case_pats = build_constructors_of_type (fst ind) nal_as_glob_constr in assert (Int.equal (Array.length case_pats) 1); @@ -897,24 +897,24 @@ let same_raw_term rt1 rt2 = | GHole _, GHole _ -> true | _ -> false let decompose_raw_eq lhs rhs = - let rec decompose_raw_eq lhs rhs acc = - observe (str "decomposing eq for " ++ pr_glob_constr lhs ++ str " " ++ pr_glob_constr rhs); - let (rhd,lrhs) = glob_decompose_app rhs in - let (lhd,llhs) = glob_decompose_app lhs in - observe (str "lhd := " ++ pr_glob_constr lhd); - observe (str "rhd := " ++ pr_glob_constr rhd); + let _, env = Pfedit.get_current_context () in + let rec decompose_raw_eq lhs rhs acc = + observe (str "decomposing eq for " ++ pr_glob_constr_env env lhs ++ str " " ++ pr_glob_constr_env env rhs); + let (rhd,lrhs) = glob_decompose_app rhs in + let (lhd,llhs) = glob_decompose_app lhs in + observe (str "lhd := " ++ pr_glob_constr_env env lhd); + observe (str "rhd := " ++ pr_glob_constr_env env rhd); observe (str "llhs := " ++ int (List.length llhs)); observe (str "lrhs := " ++ int (List.length lrhs)); - let sllhs = List.length llhs in - let slrhs = List.length lrhs in - if same_raw_term lhd rhd && Int.equal sllhs slrhs + let sllhs = List.length llhs in + let slrhs = List.length lrhs in + if same_raw_term lhd rhd && Int.equal sllhs slrhs then (* let _ = assert false in *) List.fold_right2 decompose_raw_eq llhs lrhs acc else (lhs,rhs)::acc in decompose_raw_eq lhs rhs [] - exception Continue (* @@ -923,7 +923,7 @@ exception Continue eliminates some meaningless equalities, applies some rewrites...... *) let rec rebuild_cons env nb_args relname args crossed_types depth rt = - observe (str "rebuilding : " ++ pr_glob_constr rt); + observe (str "rebuilding : " ++ pr_glob_constr_env env rt); let open Context.Rel.Declaration in let open CAst in match DAst.get rt with @@ -967,7 +967,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let id = match DAst.get id with GVar id -> id | _ -> assert false in begin try - observe (str "computing new type for eq : " ++ pr_glob_constr rt); + observe (str "computing new type for eq : " ++ pr_glob_constr_env env rt); let t' = try fst (Pretyping.understand env (Evd.from_env env) t)(*FIXME*) with e when CErrors.noncritical e -> raise Continue @@ -1012,7 +1012,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let eq' = DAst.make ?loc:loc1 @@ GApp(DAst.make ?loc:loc2 @@GRef(jmeq,None),[ty;DAst.make ?loc:loc3 @@ GVar id;rt_typ;rt]) in - observe (str "computing new type for jmeq : " ++ pr_glob_constr eq'); + observe (str "computing new type for jmeq : " ++ pr_glob_constr_env env eq'); let eq'_as_constr,ctx = Pretyping.understand env (Evd.from_env env) eq' in observe (str " computing new type for jmeq : done") ; let new_args = @@ -1099,7 +1099,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = rebuild_cons env nb_args relname args crossed_types depth new_rt else raise Continue with Continue -> - observe (str "computing new type for prod : " ++ pr_glob_constr rt); + observe (str "computing new type for prod : " ++ pr_glob_constr_env env rt); let t',ctx = Pretyping.understand env (Evd.from_env env) t in let new_env = Environ.push_rel (LocalAssum (n,t')) env in let new_b,id_to_exclude = @@ -1115,7 +1115,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = | _ -> mkGProd(n,t,new_b),Id.Set.filter not_free_in_t id_to_exclude end | _ -> - observe (str "computing new type for prod : " ++ pr_glob_constr rt); + observe (str "computing new type for prod : " ++ pr_glob_constr_env env rt); let t',ctx = Pretyping.understand env (Evd.from_env env) t in let new_env = Environ.push_rel (LocalAssum (n,t')) env in let new_b,id_to_exclude = @@ -1134,7 +1134,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = begin let not_free_in_t id = not (is_free_in id t) in let new_crossed_types = t :: crossed_types in - observe (str "computing new type for lambda : " ++ pr_glob_constr rt); + observe (str "computing new type for lambda : " ++ pr_glob_constr_env env rt); let t',ctx = Pretyping.understand env (Evd.from_env env) t in match n with | Name id -> diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index dab094f913..9e22ad3063 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -1,7 +1,8 @@ open CErrors +open Sorts open Util open Names -open Term +open Constr open EConstr open Pp open Indfun_common @@ -46,7 +47,7 @@ let functional_induction with_clean c princl pat = try find_Function_infos c' with Not_found -> user_err (str "Cannot find induction information on "++ - Printer.pr_leconstr (mkConst c') ) + Printer.pr_leconstr_env (Tacmach.pf_env g) sigma (mkConst c') ) in match Tacticals.elimination_sort_of_goal g with | InProp -> finfo.prop_lemma @@ -74,7 +75,7 @@ let functional_induction with_clean c princl pat = (* mkConst(const_of_id princ_name ),g (\* FIXME *\) *) with Not_found -> (* This one is neither defined ! *) user_err (str "Cannot find induction principle for " - ++Printer.pr_leconstr (mkConst c') ) + ++ Printer.pr_leconstr_env (Tacmach.pf_env g) sigma (mkConst c') ) in let princ = EConstr.of_constr princ in (princ,NoBindings,Tacmach.pf_unsafe_type_of g' princ,g') @@ -841,12 +842,13 @@ let rec get_args b t : Constrexpr.local_binder_expr list * let make_graph (f_ref:global_reference) = let c,c_body = match f_ref with - | ConstRef c -> - begin try c,Global.lookup_constant c - with Not_found -> - raise (UserError (None,str "Cannot find " ++ Printer.pr_leconstr (mkConst c)) ) - end - | _ -> raise (UserError (None, str "Not a function reference") ) + | ConstRef c -> + begin try c,Global.lookup_constant c + with Not_found -> + let sigma, env = Pfedit.get_current_context () in + raise (UserError (None,str "Cannot find " ++ Printer.pr_leconstr_env env sigma (mkConst c)) ) + end + | _ -> raise (UserError (None, str "Not a function reference") ) in (match Global.body_of_constant_body c_body with | None -> error "Cannot build a graph over an axiom!" diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index e9102e9c82..8bf6e48fdb 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -333,15 +333,17 @@ let discharge_Function (_,finfos) = } let pr_ocst c = - Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) c (mt ()) + let sigma, env = Pfedit.get_current_context () in + Option.fold_right (fun v acc -> Printer.pr_lconstr_env env sigma (mkConst v)) c (mt ()) let pr_info f_info = + let sigma, env = Pfedit.get_current_context () in str "function_constant := " ++ - Printer.pr_lconstr (mkConst f_info.function_constant)++ fnl () ++ + Printer.pr_lconstr_env env sigma (mkConst f_info.function_constant)++ fnl () ++ str "function_constant_type := " ++ (try - Printer.pr_lconstr - (fst (Global.type_of_global_in_context (Global.env ()) (ConstRef f_info.function_constant))) + Printer.pr_lconstr_env env sigma + (fst (Global.type_of_global_in_context env (ConstRef f_info.function_constant))) with e when CErrors.noncritical e -> mt ()) ++ fnl () ++ str "equation_lemma := " ++ pr_ocst f_info.equation_lemma ++ fnl () ++ str "completeness_lemma :=" ++ pr_ocst f_info.completeness_lemma ++ fnl () ++ @@ -349,7 +351,7 @@ let pr_info f_info = str "rect_lemma := " ++ pr_ocst f_info.rect_lemma ++ fnl () ++ str "rec_lemma := " ++ pr_ocst f_info.rec_lemma ++ fnl () ++ str "prop_lemma := " ++ pr_ocst f_info.prop_lemma ++ fnl () ++ - str "graph_ind := " ++ Printer.pr_lconstr (mkInd f_info.graph_ind) ++ fnl () + str "graph_ind := " ++ Printer.pr_lconstr_env env sigma (mkInd f_info.graph_ind) ++ fnl () let pr_table tb = let l = Cmap_env.fold (fun k v acc -> v::acc) tb [] in @@ -550,11 +552,11 @@ type tcc_lemma_value = | Value of constr | Not_needed -(* We only "purify" on exceptions *) +(* We only "purify" on exceptions. XXX: What is this doing here? *) let funind_purify f x = - let st = Vernacentries.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state `No in try f x with e -> let e = CErrors.push e in - Vernacentries.unfreeze_interp_state st; + Vernacstate.unfreeze_interp_state st; Exninfo.iraise e diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 692a874d36..694c800514 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -851,7 +851,7 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in let type_of_lemma = nf_zeta type_of_lemma in - observe (str "type_of_lemma := " ++ Printer.pr_leconstr type_of_lemma); + observe (str "type_of_lemma := " ++ Printer.pr_leconstr_env env !evd type_of_lemma); type_of_lemma,type_info ) funs_constr diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index b372241d20..9e2774ff32 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -90,20 +90,28 @@ let next_ident_fresh (id:Id.t) = (* comment this line to see debug msgs *) let msg x = () ;; let pr_lconstr c = str "" (* uncomment this to see debugging *) -let prconstr c = msg (str" " ++ Printer.pr_lconstr c) -let prconstrnl c = msg (str" " ++ Printer.pr_lconstr c ++ str"\n") +let prconstr c = + let sigma, env = Pfedit.get_current_context () in + msg (str" " ++ Printer.pr_lconstr_env env sigma c) + +let prconstrnl c = + let sigma, env = Pfedit.get_current_context () in + msg (str" " ++ Printer.pr_lconstr_env env sigma c ++ str"\n") + let prlistconstr lc = List.iter prconstr lc let prstr s = msg(str s) let prNamedConstr s c = + let sigma, env = Pfedit.get_current_context () in begin msg(str ""); - msg(str(s^" {§ ") ++ Printer.pr_lconstr c ++ str " §} "); + msg(str(s^" {§ ") ++ Printer.pr_lconstr_env env sigma c ++ str " §} "); msg(str ""); end let prNamedRConstr s c = + let sigma, env = Pfedit.get_current_context () in begin msg(str ""); - msg(str(s^" {§ ") ++ Printer.pr_glob_constr c ++ str " §} "); + msg(str(s^" {§ ") ++ Printer.pr_glob_constr_env env c ++ str " §} "); msg(str ""); end let prNamedLConstr_aux lc = List.iter (prNamedConstr "\n") lc diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 2fdc3bc37e..766adfc63a 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -9,7 +9,6 @@ module CVars = Vars -open Term open Constr open EConstr open Vars @@ -54,6 +53,10 @@ let coq_constant m s = EConstr.of_constr @@ Universes.constr_of_global @@ let arith_Nat = ["Arith";"PeanoNat";"Nat"] let arith_Lt = ["Arith";"Lt"] +let pr_leconstr_rd = + let sigma, env = Pfedit.get_current_context () in + Printer.pr_leconstr_env env sigma + let coq_init_constant s = EConstr.of_constr ( Universes.constr_of_global @@ @@ -63,8 +66,8 @@ let find_reference sl s = let dp = Names.DirPath.make (List.rev_map Id.of_string sl) in locate (make_qualid dp (Id.of_string s)) -let declare_fun f_id kind ?(ctx=Univ.UContext.empty) value = - let ce = definition_entry ~univs:ctx value (*FIXME *) in +let declare_fun f_id kind ?univs value = + let ce = definition_entry ?univs value (*FIXME *) in ConstRef(declare_constant f_id (DefinitionEntry ce, kind));; let defined () = Lemmas.save_proof (Vernacexpr.(Proved (Transparent,None))) @@ -138,7 +141,7 @@ let def_id = Id.of_string "def" let p_id = Id.of_string "p" let rec_res_id = Id.of_string "rec_res";; let lt = function () -> (coq_init_constant "lt") -let le = function () -> (coq_init_constant "le") +let le = function () -> (Coqlib.gen_reference_in_modules "RecursiveDefinition" Coqlib.init_modules "le") let ex = function () -> (coq_init_constant "ex") let nat = function () -> (coq_init_constant "nat") let iter_ref () = @@ -337,7 +340,8 @@ let check_not_nested sigma forbidden e = try check_not_nested e with UserError(_,p) -> - user_err ~hdr:"_" (str "on expr : " ++ Printer.pr_leconstr e ++ str " " ++ p) + let _, env = Pfedit.get_current_context () in + user_err ~hdr:"_" (str "on expr : " ++ Printer.pr_leconstr_env env sigma e ++ str " " ++ p) (* ['a info] contains the local information for traveling *) type 'a infos = @@ -455,7 +459,7 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) g = check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; jinfo.otherS () expr_info continuation_tac expr_info g with e when CErrors.noncritical e -> - user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id) + user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env (pf_env g) sigma expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id) end | Lambda(n,t,b) -> begin @@ -463,7 +467,7 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) g = check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; jinfo.otherS () expr_info continuation_tac expr_info g with e when CErrors.noncritical e -> - user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id) + user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env (pf_env g) sigma expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id) end | Case(ci,t,a,l) -> begin @@ -491,8 +495,8 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) g = jinfo.apP (f,args) expr_info continuation_tac in travel_args jinfo expr_info.is_main_branch new_continuation_tac new_infos g - | Case _ -> user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr expr_info.info ++ str " can not contain an applied match (See Limitation in Section 2.3 of refman)") - | _ -> anomaly (Pp.str "travel_aux : unexpected "++ Printer.pr_leconstr expr_info.info ++ Pp.str ".") + | Case _ -> user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env (pf_env g) sigma expr_info.info ++ str " can not contain an applied match (See Limitation in Section 2.3 of refman)") + | _ -> anomaly (Pp.str "travel_aux : unexpected "++ Printer.pr_leconstr_env (pf_env g) sigma expr_info.info ++ Pp.str ".") end | Cast(t,_,_) -> travel jinfo continuation_tac {expr_info with info=t} g | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ -> @@ -515,7 +519,7 @@ and travel_args jinfo is_final continuation_tac infos = {infos with info=arg;is_final=false} and travel jinfo continuation_tac expr_info = observe_tac - (str jinfo.message ++ Printer.pr_leconstr expr_info.info) + (str jinfo.message ++ pr_leconstr_rd expr_info.info) (travel_aux jinfo continuation_tac expr_info) (* Termination proof *) @@ -731,7 +735,7 @@ let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = let destruct_tac,rev_to_thin_intro = mkDestructEq [expr_info.rec_arg_id] a' g in let to_thin_intro = List.rev rev_to_thin_intro in - observe_tac (str "treating cases (" ++ int (Array.length l) ++ str")" ++ spc () ++ Printer.pr_leconstr a') + observe_tac (str "treating cases (" ++ int (Array.length l) ++ str")" ++ spc () ++ Printer.pr_leconstr_env (pf_env g) sigma a') (try (tclTHENS destruct_tac @@ -740,7 +744,7 @@ let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = with | UserError(Some "Refiner.thensn_tac3",_) | UserError(Some "Refiner.tclFAIL_s",_) -> - (observe_tac (str "is computable " ++ Printer.pr_leconstr new_info.info) (next_step continuation_tac {new_info with info = nf_betaiotazeta new_info.info} ) + (observe_tac (str "is computable " ++ Printer.pr_leconstr_env (pf_env g) sigma new_info.info) (next_step continuation_tac {new_info with info = nf_betaiotazeta new_info.info} ) )) g @@ -853,9 +857,13 @@ let rec prove_le g = Proofview.V82.of_tactic (apply (delayed_force le_n)); begin try - let matching_fun = - pf_is_matching g - (Pattern.PApp(Pattern.PRef (Globnames.global_of_constr (EConstr.Unsafe.to_constr (le ()))),[|Pattern.PVar (destVar sigma x);Pattern.PMeta None|])) in + let matching_fun c = match EConstr.kind sigma c with + | App (c, [| x0 ; _ |]) -> + EConstr.isVar sigma x0 && + Id.equal (destVar sigma x0) (destVar sigma x) && + is_global sigma (le ()) c + | _ -> false + in let (h,t) = List.find (fun (_,t) -> matching_fun t) (pf_hyps_types g) in let y = @@ -991,11 +999,11 @@ let rec intros_values_eq expr_info acc = let equation_others _ expr_info continuation_tac infos = if expr_info.is_final && expr_info.is_main_branch then - observe_tac (str "equation_others (cont_tac +intros) " ++ Printer.pr_leconstr expr_info.info) + observe_tac (str "equation_others (cont_tac +intros) " ++ pr_leconstr_rd expr_info.info) (tclTHEN (continuation_tac infos) - (observe_tac (str "intros_values_eq equation_others " ++ Printer.pr_leconstr expr_info.info) (intros_values_eq expr_info []))) - else observe_tac (str "equation_others (cont_tac) " ++ Printer.pr_leconstr expr_info.info) (continuation_tac infos) + (observe_tac (str "intros_values_eq equation_others " ++ pr_leconstr_rd expr_info.info) (intros_values_eq expr_info []))) + else observe_tac (str "equation_others (cont_tac) " ++ pr_leconstr_rd expr_info.info) (continuation_tac infos) let equation_app f_and_args expr_info continuation_tac infos = if expr_info.is_final && expr_info.is_main_branch @@ -1225,8 +1233,8 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a let get_current_subgoals_types () = let p = Proof_global.give_me_the_proof () in - let { Evd.it=sgs ; sigma=sigma } = Proof.V82.subgoals p in - sigma, List.map (Goal.V82.abstract_type sigma) sgs + let sgs,_,_,_,sigma = Proof.proof p in + sigma, List.map (Goal.V82.abstract_type sigma) sgs exception EmptySubgoals let build_and_l sigma l = @@ -1419,7 +1427,7 @@ let com_terminate nb_args ctx hook = let start_proof ctx (tac_start:tactic) (tac_end:tactic) = - let (evmap, env) = Lemmas.get_current_context() in + let evmap, env = Pfedit.get_current_context () in Lemmas.start_proof thm_name (Global, false (* FIXME *), Proof Lemma) ~sign:(Environ.named_context_val env) ctx (EConstr.of_constr (compute_terminate_type nb_args fonctional_ref)) hook; @@ -1471,7 +1479,7 @@ let (com_eqn : int -> Id.t -> | ConstRef c -> is_opaque_constant c | _ -> anomaly ~label:"terminate_lemma" (Pp.str "not a constant.") in - let (evmap, env) = Lemmas.get_current_context() in + let evmap, env = Pfedit.get_current_context () in let evmap = Evd.from_ctx (Evd.evar_universe_context evmap) in let f_constr = constr_of_global f_ref in let equation_lemma_type = subst1 f_constr equation_lemma_type in @@ -1552,8 +1560,8 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let functional_id = add_suffix function_name "_F" in let term_id = add_suffix function_name "_terminate" in let functional_ref = - let ctx = (snd (Evd.universe_context ~names:[] ~extensible:true evm)) in - declare_fun functional_id (IsDefinition Decl_kinds.Definition) ~ctx res + let univs = Entries.Monomorphic_const_entry (Evd.universe_context_set evm) in + declare_fun functional_id (IsDefinition Decl_kinds.Definition) ~univs res in (* Refresh the global universes, now including those of _F *) let evm = Evd.from_env (Global.env ()) in diff --git a/plugins/ltac/extraargs.ml4 b/plugins/ltac/extraargs.ml4 index 89feea8dcf..bb01aca558 100644 --- a/plugins/ltac/extraargs.ml4 +++ b/plugins/ltac/extraargs.ml4 @@ -133,7 +133,9 @@ let pr_occurrences = pr_occurrences () () () let pr_gen prc _prlc _prtac c = prc c -let pr_globc _prc _prlc _prtac (_,glob) = Printer.pr_glob_constr glob +let pr_globc _prc _prlc _prtac (_,glob) = + let _, env = Pfedit.get_current_context () in + Printer.pr_glob_constr_env env glob let interp_glob ist gl (t,_) = Tacmach.project gl , (ist,t) diff --git a/plugins/ltac/extratactics.ml4 b/plugins/ltac/extratactics.ml4 index 4b1555e551..982fc7cc3c 100644 --- a/plugins/ltac/extratactics.ml4 +++ b/plugins/ltac/extratactics.ml4 @@ -313,30 +313,51 @@ let project_hint pri l2r r = let id = Nameops.add_suffix (Nametab.basename_of_global gr) ("_proj_" ^ (if l2r then "l2r" else "r2l")) in - let ctx = Evd.universe_context_set sigma in + let poly = Flags.use_polymorphic_flag () in + let ctx = Evd.const_univ_entry ~poly sigma in let c = EConstr.to_constr sigma c in let c = Declare.declare_definition ~internal:Declare.InternalTacticRequest id (c,ctx) in let info = {Vernacexpr.hint_priority = pri; hint_pattern = None} in (info,false,true,Hints.PathAny, Hints.IsGlobRef (Globnames.ConstRef c)) -let add_hints_iff l2r lc n bl = - let l = Locality.LocalityFixme.consume () in - Hints.add_hints (Locality.make_module_locality l) bl +let add_hints_iff ?locality l2r lc n bl = + Hints.add_hints (Locality.make_module_locality locality) bl (Hints.HintsResolveEntry (List.map (project_hint n l2r) lc)) -VERNAC COMMAND EXTEND HintResolveIffLR CLASSIFIED AS SIDEFF +VERNAC COMMAND FUNCTIONAL EXTEND HintResolveIffLR CLASSIFIED AS SIDEFF [ "Hint" "Resolve" "->" ne_global_list(lc) natural_opt(n) ":" preident_list(bl) ] -> - [ add_hints_iff true lc n bl ] + [ fun ~atts ~st -> begin + let open Vernacinterp in + add_hints_iff ?locality:atts.locality true lc n bl; + st + end + ] | [ "Hint" "Resolve" "->" ne_global_list(lc) natural_opt(n) ] -> - [ add_hints_iff true lc n ["core"] ] + [ fun ~atts ~st -> begin + let open Vernacinterp in + add_hints_iff ?locality:atts.locality true lc n ["core"]; + st + end + ] END -VERNAC COMMAND EXTEND HintResolveIffRL CLASSIFIED AS SIDEFF + +VERNAC COMMAND FUNCTIONAL EXTEND HintResolveIffRL CLASSIFIED AS SIDEFF [ "Hint" "Resolve" "<-" ne_global_list(lc) natural_opt(n) ":" preident_list(bl) ] -> - [ add_hints_iff false lc n bl ] + [ fun ~atts ~st -> begin + let open Vernacinterp in + add_hints_iff ?locality:atts.locality false lc n bl; + st + end + ] | [ "Hint" "Resolve" "<-" ne_global_list(lc) natural_opt(n) ] -> - [ add_hints_iff false lc n ["core"] ] + [ fun ~atts ~st -> begin + let open Vernacinterp in + add_hints_iff ?locality:atts.locality false lc n ["core"]; + st + end + ] END (**********************************************************************) @@ -852,34 +873,12 @@ TACTIC EXTEND is_evar ] END -let has_evar sigma c = -let rec has_evar x = - match EConstr.kind sigma x with - | Evar _ -> true - | Rel _ | Var _ | Meta _ | Sort _ | Const _ | Ind _ | Construct _ -> - false - | Cast (t1, _, t2) | Prod (_, t1, t2) | Lambda (_, t1, t2) -> - has_evar t1 || has_evar t2 - | LetIn (_, t1, t2, t3) -> - has_evar t1 || has_evar t2 || has_evar t3 - | App (t1, ts) -> - has_evar t1 || has_evar_array ts - | Case (_, t1, t2, ts) -> - has_evar t1 || has_evar t2 || has_evar_array ts - | Fix ((_, tr)) | CoFix ((_, tr)) -> - has_evar_prec tr - | Proj (p, c) -> has_evar c -and has_evar_array x = - Array.exists has_evar x -and has_evar_prec (_, ts1, ts2) = - Array.exists has_evar ts1 || Array.exists has_evar ts2 -in -has_evar c - TACTIC EXTEND has_evar | [ "has_evar" constr(x) ] -> [ Proofview.tclEVARMAP >>= fun sigma -> - if has_evar sigma x then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "No evars") + if Evarutil.has_undefined_evars sigma x + then Proofview.tclUNIT () + else Tacticals.New.tclFAIL 0 (str "No evars") ] END diff --git a/plugins/ltac/g_auto.ml4 b/plugins/ltac/g_auto.ml4 index 5baa0d5c1d..90a44708fc 100644 --- a/plugins/ltac/g_auto.ml4 +++ b/plugins/ltac/g_auto.ml4 @@ -51,8 +51,12 @@ let eval_uconstrs ist cs = List.map (fun c -> map (Tacinterp.type_uconstr ~flags ist c)) cs let pr_auto_using_raw _ _ _ = Pptactic.pr_auto_using Ppconstr.pr_constr_expr -let pr_auto_using_glob _ _ _ = Pptactic.pr_auto_using (fun (c,_) -> Printer.pr_glob_constr c) -let pr_auto_using _ _ _ = Pptactic.pr_auto_using Printer.pr_closed_glob +let pr_auto_using_glob _ _ _ = Pptactic.pr_auto_using (fun (c,_) -> + let _, env = Pfedit.get_current_context () in + Printer.pr_glob_constr_env env c) +let pr_auto_using _ _ _ = Pptactic.pr_auto_using + (let sigma, env = Pfedit.get_current_context () in + Printer.pr_closed_glob_env env sigma) ARGUMENT EXTEND auto_using TYPED AS uconstr_list @@ -186,7 +190,7 @@ END let pr_hints_path prc prx pry c = Hints.pp_hints_path c let pr_pre_hints_path prc prx pry c = Hints.pp_hints_path_gen Libnames.pr_reference c let glob_hints_path ist = Hints.glob_hints_path - + ARGUMENT EXTEND hints_path PRINTED BY pr_hints_path @@ -210,10 +214,15 @@ ARGUMENT EXTEND opthints | [ ] -> [ None ] END -VERNAC COMMAND EXTEND HintCut CLASSIFIED AS SIDEFF +VERNAC COMMAND FUNCTIONAL EXTEND HintCut CLASSIFIED AS SIDEFF | [ "Hint" "Cut" "[" hints_path(p) "]" opthints(dbnames) ] -> [ - let entry = Hints.HintsCutEntry (Hints.glob_hints_path p) in - Hints.add_hints (Locality.make_section_locality (Locality.LocalityFixme.consume ())) - (match dbnames with None -> ["core"] | Some l -> l) entry ] + fun ~atts ~st -> begin + let open Vernacinterp in + let entry = Hints.HintsCutEntry (Hints.glob_hints_path p) in + Hints.add_hints (Locality.make_section_locality atts.locality) + (match dbnames with None -> ["core"] | Some l -> l) entry; + st + end + ] END diff --git a/plugins/ltac/g_ltac.ml4 b/plugins/ltac/g_ltac.ml4 index 1161525689..8b9eb39837 100644 --- a/plugins/ltac/g_ltac.ml4 +++ b/plugins/ltac/g_ltac.ml4 @@ -469,13 +469,13 @@ VERNAC ARGUMENT EXTEND ltac_production_item PRINTED BY pr_ltac_production_item [ Tacentries.TacNonTerm (Loc.tag ~loc ((Id.to_string nt, None), None)) ] END -VERNAC COMMAND EXTEND VernacTacticNotation +VERNAC COMMAND FUNCTIONAL EXTEND VernacTacticNotation | [ "Tactic" "Notation" ltac_tactic_level_opt(n) ne_ltac_production_item_list(r) ":=" tactic(e) ] => - [ VtUnknown, VtNow ] -> - [ - let l = Locality.LocalityFixme.consume () in - let n = Option.default 0 n in - Tacentries.add_tactic_notation (Locality.make_module_locality l) n r e + [ VtSideff [], VtNow ] -> + [ fun ~atts ~st -> let open Vernacinterp in + let n = Option.default 0 n in + Tacentries.add_tactic_notation (Locality.make_module_locality atts.locality) n r e; + st ] END @@ -512,15 +512,15 @@ PRINTED BY pr_tacdef_body | [ tacdef_body(t) ] -> [ t ] END -VERNAC COMMAND EXTEND VernacDeclareTacticDefinition +VERNAC COMMAND FUNCTIONAL EXTEND VernacDeclareTacticDefinition | [ "Ltac" ne_ltac_tacdef_body_list_sep(l, "with") ] => [ VtSideff (List.map (function | TacticDefinition ((_,r),_) -> r | TacticRedefinition (Ident (_,r),_) -> r | TacticRedefinition (Qualid (_,q),_) -> snd(repr_qualid q)) l), VtLater - ] -> [ - let lc = Locality.LocalityFixme.consume () in - Tacentries.register_ltac (Locality.make_module_locality lc) l + ] -> [ fun ~atts ~st -> let open Vernacinterp in + Tacentries.register_ltac (Locality.make_module_locality atts.locality) l; + st ] END diff --git a/plugins/ltac/g_obligations.ml4 b/plugins/ltac/g_obligations.ml4 index fea9e837b1..f6cc3833a7 100644 --- a/plugins/ltac/g_obligations.ml4 +++ b/plugins/ltac/g_obligations.ml4 @@ -123,11 +123,15 @@ VERNAC COMMAND EXTEND Admit_Obligations CLASSIFIED AS SIDEFF | [ "Admit" "Obligations" ] -> [ admit_obligations None ] END -VERNAC COMMAND EXTEND Set_Solver CLASSIFIED AS SIDEFF +VERNAC COMMAND FUNCTIONAL EXTEND Set_Solver CLASSIFIED AS SIDEFF | [ "Obligation" "Tactic" ":=" tactic(t) ] -> [ - set_default_tactic - (Locality.make_section_locality (Locality.LocalityFixme.consume ())) - (Tacintern.glob_tactic t) ] + fun ~atts ~st -> begin + let open Vernacinterp in + set_default_tactic + (Locality.make_section_locality atts.locality) + (Tacintern.glob_tactic t); + st + end] END open Pp diff --git a/plugins/ltac/g_rewrite.ml4 b/plugins/ltac/g_rewrite.ml4 index b148d962ed..ea1808a255 100644 --- a/plugins/ltac/g_rewrite.ml4 +++ b/plugins/ltac/g_rewrite.ml4 @@ -31,8 +31,12 @@ type constr_expr_with_bindings = constr_expr with_bindings type glob_constr_with_bindings = Tacexpr.glob_constr_and_expr with_bindings type glob_constr_with_bindings_sign = interp_sign * Tacexpr.glob_constr_and_expr with_bindings -let pr_glob_constr_with_bindings_sign _ _ _ (ge : glob_constr_with_bindings_sign) = Printer.pr_glob_constr (fst (fst (snd ge))) -let pr_glob_constr_with_bindings _ _ _ (ge : glob_constr_with_bindings) = Printer.pr_glob_constr (fst (fst ge)) +let pr_glob_constr_with_bindings_sign _ _ _ (ge : glob_constr_with_bindings_sign) = + let _, env = Pfedit.get_current_context () in + Printer.pr_glob_constr_env env (fst (fst (snd ge))) +let pr_glob_constr_with_bindings _ _ _ (ge : glob_constr_with_bindings) = + let _, env = Pfedit.get_current_context () in + Printer.pr_glob_constr_env env (fst (fst ge)) let pr_constr_expr_with_bindings prc _ _ (ge : constr_expr_with_bindings) = prc (fst ge) let interp_glob_constr_with_bindings ist gl c = Tacmach.project gl , (ist, c) let glob_glob_constr_with_bindings ist l = Tacintern.intern_constr_with_bindings ist l @@ -239,22 +243,37 @@ VERNAC COMMAND EXTEND AddParametricRelation3 CLASSIFIED AS SIDEFF [ declare_relation ~binders:b a aeq n None None (Some lemma3) ] END -VERNAC COMMAND EXTEND AddSetoid1 CLASSIFIED AS SIDEFF +VERNAC COMMAND FUNCTIONAL EXTEND AddSetoid1 CLASSIFIED AS SIDEFF [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> - [ add_setoid (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) [] a aeq t n ] + [ fun ~atts ~st -> let open Vernacinterp in + add_setoid (not (Locality.make_section_locality atts.locality)) [] a aeq t n; + st + ] | [ "Add" "Parametric" "Setoid" binders(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> - [ add_setoid (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) binders a aeq t n ] + [ fun ~atts ~st -> let open Vernacinterp in + add_setoid (not (Locality.make_section_locality atts.locality)) binders a aeq t n; + st + ] | [ "Add" "Morphism" constr(m) ":" ident(n) ] (* This command may or may not open a goal *) => [ Vernacexpr.VtUnknown, Vernacexpr.VtNow ] - -> [ add_morphism_infer (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) m n ] + -> [ fun ~atts ~st -> let open Vernacinterp in + add_morphism_infer (not (Locality.make_section_locality atts.locality)) m n; + st + ] | [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] => [ Vernacexpr.(VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater) ] - -> [ add_morphism (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) [] m s n ] + -> [ fun ~atts ~st -> let open Vernacinterp in + add_morphism (not (Locality.make_section_locality atts.locality)) [] m s n; + st + ] | [ "Add" "Parametric" "Morphism" binders(binders) ":" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] => [ Vernacexpr.(VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater) ] - -> [ add_morphism (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) binders m s n ] + -> [ fun ~atts ~st -> let open Vernacinterp in + add_morphism (not (Locality.make_section_locality atts.locality)) binders m s n; + st + ] END TACTIC EXTEND setoid_symmetry @@ -272,5 +291,7 @@ TACTIC EXTEND setoid_transitivity END VERNAC COMMAND EXTEND PrintRewriteHintDb CLASSIFIED AS QUERY - [ "Print" "Rewrite" "HintDb" preident(s) ] -> [ Feedback.msg_notice (Autorewrite.print_rewrite_hintdb s) ] + [ "Print" "Rewrite" "HintDb" preident(s) ] -> + [ let sigma, env = Pfedit.get_current_context () in + Feedback.msg_notice (Autorewrite.print_rewrite_hintdb env sigma s) ] END diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index 38460c669f..6aa2f6f898 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -84,6 +84,32 @@ type 'a extra_genarg_printer = (tolerability -> Val.t -> Pp.t) -> 'a -> Pp.t +type 'a raw_extra_genarg_printer_with_level = + (constr_expr -> Pp.t) -> + (constr_expr -> Pp.t) -> + (tolerability -> raw_tactic_expr -> Pp.t) -> + tolerability -> 'a -> Pp.t + +type 'a glob_extra_genarg_printer_with_level = + (glob_constr_and_expr -> Pp.t) -> + (glob_constr_and_expr -> Pp.t) -> + (tolerability -> glob_tactic_expr -> Pp.t) -> + tolerability -> 'a -> Pp.t + +type 'a extra_genarg_printer_with_level = + (EConstr.constr -> Pp.t) -> + (EConstr.constr -> Pp.t) -> + (tolerability -> Val.t -> Pp.t) -> + tolerability -> 'a -> Pp.t + +let string_of_genarg_arg (ArgumentType arg) = + let rec aux : type a b c. (a, b, c) genarg_type -> string = function + | ListArg t -> aux t ^ "_list" + | OptArg t -> aux t ^ "_opt" + | PairArg (t1, t2) -> assert false (* No parsing/printing rule for it *) + | ExtraArg s -> ArgT.repr s in + aux arg + let keyword x = tag_keyword (str x) let primitive x = tag_primitive (str x) @@ -119,9 +145,9 @@ type 'a extra_genarg_printer = | Some Refl -> let open Genprint in match generic_top_print (in_gen (Topwit wit) x) with - | PrinterBasic pr -> pr () - | PrinterNeedsContext pr -> pr (Global.env()) Evd.empty - | PrinterNeedsContextAndLevel { default_ensure_surrounded; printer } -> + | TopPrinterBasic pr -> pr () + | TopPrinterNeedsContext pr -> pr (Global.env()) Evd.empty + | TopPrinterNeedsContextAndLevel { default_ensure_surrounded; printer } -> printer (Global.env()) Evd.empty default_ensure_surrounded end | _ -> default @@ -536,15 +562,24 @@ let pr_goal_selector ~toplevel s = let pr_funvar n = spc () ++ Name.print n - let pr_let_clause k pr (na,(bl,t)) = + let pr_let_clause k pr_gen pr_arg (na,(bl,t)) = + let pr = function + | TacGeneric arg -> + let name = string_of_genarg_arg (genarg_tag arg) in + if name = "unit" || name = "int" then + (* Hard-wired parsing rules *) + pr_gen arg + else + str name ++ str ":" ++ surround (pr_gen arg) + | _ -> pr_arg (TacArg (Loc.tag t)) in hov 0 (keyword k ++ spc () ++ pr_lname na ++ prlist pr_funvar bl ++ - str " :=" ++ brk (1,1) ++ pr (TacArg (Loc.tag t))) + str " :=" ++ brk (1,1) ++ pr t) - let pr_let_clauses recflag pr = function + let pr_let_clauses recflag pr_gen pr = function | hd::tl -> hv 0 - (pr_let_clause (if recflag then "let rec" else "let") pr hd ++ - prlist (fun t -> spc () ++ pr_let_clause "with" pr t) tl) + (pr_let_clause (if recflag then "let rec" else "let") pr_gen pr hd ++ + prlist (fun t -> spc () ++ pr_let_clause "with" pr_gen pr t) tl) | [] -> anomaly (Pp.str "LetIn must declare at least one binding.") let pr_seq_body pr tl = @@ -706,8 +741,10 @@ let pr_goal_selector ~toplevel s = | TacIntroPattern (ev,[]) as t -> pr_atom0 t | TacIntroPattern (ev,(_::_ as p)) -> - hov 1 (primitive (if ev then "eintros" else "intros") ++ spc () ++ - prlist_with_sep spc (Miscprint.pr_intro_pattern pr.pr_dconstr) p) + hov 1 (primitive (if ev then "eintros" else "intros") ++ + (match p with + | [_,Misctypes.IntroForthcoming false] -> mt () + | _ -> spc () ++ prlist_with_sep spc (Miscprint.pr_intro_pattern pr.pr_dconstr) p)) | TacApply (a,ev,cb,inhyp) -> hov 1 ( (if a then mt() else primitive "simple ") ++ @@ -858,7 +895,7 @@ let pr_goal_selector ~toplevel s = let llc = List.map (fun (id,t) -> (id,extract_binders t)) llc in v 0 (hv 0 ( - pr_let_clauses recflag (pr_tac ltop) llc + pr_let_clauses recflag pr.pr_generic (pr_tac ltop) llc ++ spc () ++ keyword "in" ) ++ fnl () ++ pr_tac (llet,E) u), llet @@ -1003,7 +1040,7 @@ let pr_goal_selector ~toplevel s = | TacAtom (loc,t) -> pr_with_comments ?loc (hov 1 (pr_atom pr strip_prod_binders tag_atom t)), ltatom | TacArg(_,Tacexp e) -> - pr.pr_tactic (latom,E) e, latom + pr_tac inherited e, latom | TacArg(_,ConstrMayEval (ConstrTerm c)) -> keyword "constr:" ++ pr.pr_constr c, latom | TacArg(_,ConstrMayEval c) -> @@ -1175,42 +1212,77 @@ let declare_extra_genarg_pprule wit | ExtraArg s -> () | _ -> user_err Pp.(str "Can declare a pretty-printing rule only for extra argument types.") end; - let f x = f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x in + let f x = + Genprint.PrinterBasic (fun () -> + f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x) in let g x = + Genprint.PrinterBasic (fun () -> let env = Global.env () in - g (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) (pr_glob_tactic_level env) x + g (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) (pr_glob_tactic_level env) x) in let h x = - Genprint.PrinterNeedsContext (fun env sigma -> + Genprint.TopPrinterNeedsContext (fun env sigma -> h (pr_econstr_env env sigma) (pr_leconstr_env env sigma) (fun _ _ -> str "<tactic>") x) in Genprint.register_print0 wit f g h +let declare_extra_genarg_pprule_with_level wit + (f : 'a raw_extra_genarg_printer_with_level) + (g : 'b glob_extra_genarg_printer_with_level) + (h : 'c extra_genarg_printer_with_level) default_surrounded default_non_surrounded = + begin match wit with + | ExtraArg s -> () + | _ -> user_err Pp.(str "Can declare a pretty-printing rule only for extra argument types.") + end; + let open Genprint in + let f x = + PrinterNeedsLevel { + default_already_surrounded = default_surrounded; + default_ensure_surrounded = default_non_surrounded; + printer = (fun n -> + f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level n x) } in + let g x = + let env = Global.env () in + PrinterNeedsLevel { + default_already_surrounded = default_surrounded; + default_ensure_surrounded = default_non_surrounded; + printer = (fun n -> + g (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) (pr_glob_tactic_level env) n x) } + in + let h x = + TopPrinterNeedsContextAndLevel { + default_already_surrounded = default_surrounded; + default_ensure_surrounded = default_non_surrounded; + printer = (fun env sigma n -> + h (pr_econstr_env env sigma) (pr_leconstr_env env sigma) (fun _ _ -> str "<tactic>") n x) } + in + Genprint.register_print0 wit f g h + let declare_extra_vernac_genarg_pprule wit f = - let f x = f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x in + let f x = Genprint.PrinterBasic (fun () -> f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x) in Genprint.register_vernac_print0 wit f (** Registering *) -let pr_intro_pattern_env p = Genprint.PrinterNeedsContext (fun env sigma -> +let pr_intro_pattern_env p = Genprint.TopPrinterNeedsContext (fun env sigma -> let print_constr c = let (sigma, c) = c env sigma in pr_econstr_env env sigma c in Miscprint.pr_intro_pattern print_constr p) -let pr_red_expr_env r = Genprint.PrinterNeedsContext (fun env sigma -> +let pr_red_expr_env r = Genprint.TopPrinterNeedsContext (fun env sigma -> pr_red_expr (pr_econstr_env env sigma, pr_leconstr_env env sigma, pr_evaluable_reference_env env, pr_constr_pattern_env env sigma) r) -let pr_bindings_env bl = Genprint.PrinterNeedsContext (fun env sigma -> +let pr_bindings_env bl = Genprint.TopPrinterNeedsContext (fun env sigma -> let sigma, bl = bl env sigma in Miscprint.pr_bindings (pr_econstr_env env sigma) (pr_leconstr_env env sigma) bl) -let pr_with_bindings_env bl = Genprint.PrinterNeedsContext (fun env sigma -> +let pr_with_bindings_env bl = Genprint.TopPrinterNeedsContext (fun env sigma -> let sigma, bl = bl env sigma in pr_with_bindings (pr_econstr_env env sigma) (pr_leconstr_env env sigma) bl) -let pr_destruction_arg_env c = Genprint.PrinterNeedsContext (fun env sigma -> +let pr_destruction_arg_env c = Genprint.TopPrinterNeedsContext (fun env sigma -> let sigma, c = match c with | clear_flag,ElimOnConstr g -> let sigma,c = g env sigma in sigma,(clear_flag,ElimOnConstr c) | clear_flag,ElimOnAnonHyp n as x -> sigma, x @@ -1219,90 +1291,104 @@ let pr_destruction_arg_env c = Genprint.PrinterNeedsContext (fun env sigma -> (pr_econstr_env env sigma) (pr_leconstr_env env sigma) c) let make_constr_printer f c = - Genprint.PrinterNeedsContextAndLevel { + Genprint.TopPrinterNeedsContextAndLevel { Genprint.default_already_surrounded = Ppconstr.ltop; Genprint.default_ensure_surrounded = Ppconstr.lsimpleconstr; Genprint.printer = (fun env sigma n -> f env sigma n c)} let lift f a = Genprint.PrinterBasic (fun () -> f a) +let lift_top f a = Genprint.TopPrinterBasic (fun () -> f a) + +let register_basic_print0 wit f g h = + Genprint.register_print0 wit (lift f) (lift g) (lift_top h) + + +let pr_glob_constr_pptac c = + let _, env = Pfedit.get_current_context () in + pr_glob_constr_env env c + +let pr_lglob_constr_pptac c = + let _, env = Pfedit.get_current_context () in + pr_lglob_constr_env env c let () = let pr_bool b = if b then str "true" else str "false" in let pr_unit _ = str "()" in - Genprint.register_print0 wit_int_or_var - (pr_or_var int) (pr_or_var int) (lift int); - Genprint.register_print0 wit_ref - pr_reference (pr_or_var (pr_located pr_global)) (lift pr_global); - Genprint.register_print0 wit_ident - pr_id pr_id (lift pr_id); - Genprint.register_print0 wit_var - (pr_located pr_id) (pr_located pr_id) (lift pr_id); - Genprint.register_print0 + let open Genprint in + register_basic_print0 wit_int_or_var (pr_or_var int) (pr_or_var int) int; + register_basic_print0 wit_ref + pr_reference (pr_or_var (pr_located pr_global)) pr_global; + register_basic_print0 wit_ident pr_id pr_id pr_id; + register_basic_print0 wit_var (pr_located pr_id) (pr_located pr_id) pr_id; + register_print0 wit_intro_pattern - (Miscprint.pr_intro_pattern pr_constr_expr) - (Miscprint.pr_intro_pattern (fun (c,_) -> pr_glob_constr c)) + (lift (Miscprint.pr_intro_pattern pr_constr_expr)) + (lift (Miscprint.pr_intro_pattern (fun (c,_) -> pr_glob_constr_pptac c))) pr_intro_pattern_env; Genprint.register_print0 wit_clause_dft_concl - (pr_clauses (Some true) pr_lident) - (pr_clauses (Some true) pr_lident) - (fun c -> Genprint.PrinterBasic (fun () -> pr_clauses (Some true) (fun id -> pr_lident (Loc.tag id)) c)) + (lift (pr_clauses (Some true) pr_lident)) + (lift (pr_clauses (Some true) pr_lident)) + (fun c -> Genprint.TopPrinterBasic (fun () -> pr_clauses (Some true) (fun id -> pr_lident (Loc.tag id)) c)) ; Genprint.register_print0 wit_constr - Ppconstr.pr_constr_expr - (fun (c, _) -> Printer.pr_glob_constr c) + (lift Ppconstr.pr_lconstr_expr) + (lift (fun (c, _) -> pr_lglob_constr_pptac c)) (make_constr_printer Printer.pr_econstr_n_env) ; Genprint.register_print0 wit_uconstr - Ppconstr.pr_constr_expr - (fun (c,_) -> Printer.pr_glob_constr c) + (lift Ppconstr.pr_constr_expr) + (lift (fun (c,_) -> pr_glob_constr_pptac c)) (make_constr_printer Printer.pr_closed_glob_n_env) ; Genprint.register_print0 wit_open_constr - Ppconstr.pr_constr_expr - (fun (c, _) -> Printer.pr_glob_constr c) + (lift Ppconstr.pr_constr_expr) + (lift (fun (c, _) -> pr_glob_constr_pptac c)) (make_constr_printer Printer.pr_econstr_n_env) ; - Genprint.register_print0 wit_red_expr - (pr_red_expr (pr_constr_expr, pr_lconstr_expr, pr_or_by_notation pr_reference, pr_constr_pattern_expr)) - (pr_red_expr (pr_and_constr_expr pr_glob_constr, pr_and_constr_expr pr_lglob_constr, pr_or_var (pr_and_short_name pr_evaluable_reference), pr_pat_and_constr_expr pr_glob_constr)) + Genprint.register_print0 + wit_red_expr + (lift (pr_red_expr (pr_constr_expr, pr_lconstr_expr, pr_or_by_notation pr_reference, pr_constr_pattern_expr))) + (lift (pr_red_expr (pr_and_constr_expr pr_glob_constr_pptac, pr_and_constr_expr pr_lglob_constr_pptac, pr_or_var (pr_and_short_name pr_evaluable_reference), pr_pat_and_constr_expr pr_glob_constr_pptac))) pr_red_expr_env ; - Genprint.register_print0 wit_quant_hyp pr_quantified_hypothesis pr_quantified_hypothesis (lift pr_quantified_hypothesis); - Genprint.register_print0 wit_bindings - (Miscprint.pr_bindings_no_with pr_constr_expr pr_lconstr_expr) - (Miscprint.pr_bindings_no_with (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr)) + register_basic_print0 wit_quant_hyp pr_quantified_hypothesis pr_quantified_hypothesis pr_quantified_hypothesis; + register_print0 wit_bindings + (lift (Miscprint.pr_bindings_no_with pr_constr_expr pr_lconstr_expr)) + (lift (Miscprint.pr_bindings_no_with (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac))) pr_bindings_env ; - Genprint.register_print0 wit_constr_with_bindings - (pr_with_bindings pr_constr_expr pr_lconstr_expr) - (pr_with_bindings (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr)) + register_print0 wit_constr_with_bindings + (lift (pr_with_bindings pr_constr_expr pr_lconstr_expr)) + (lift (pr_with_bindings (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac))) pr_with_bindings_env ; - Genprint.register_print0 wit_open_constr_with_bindings - (pr_with_bindings pr_constr_expr pr_lconstr_expr) - (pr_with_bindings (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr)) + register_print0 wit_open_constr_with_bindings + (lift (pr_with_bindings pr_constr_expr pr_lconstr_expr)) + (lift (pr_with_bindings (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac))) pr_with_bindings_env ; - Genprint.register_print0 Tacarg.wit_destruction_arg - (pr_destruction_arg pr_constr_expr pr_lconstr_expr) - (pr_destruction_arg (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr)) + register_print0 Tacarg.wit_destruction_arg + (lift (pr_destruction_arg pr_constr_expr pr_lconstr_expr)) + (lift (pr_destruction_arg (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac))) pr_destruction_arg_env ; - Genprint.register_print0 Stdarg.wit_int int int (lift int); - Genprint.register_print0 Stdarg.wit_bool pr_bool pr_bool (lift pr_bool); - Genprint.register_print0 Stdarg.wit_unit pr_unit pr_unit (lift pr_unit); - Genprint.register_print0 Stdarg.wit_pre_ident str str (lift str); - Genprint.register_print0 Stdarg.wit_string qstring qstring (lift qstring) + register_basic_print0 Stdarg.wit_int int int int; + register_basic_print0 Stdarg.wit_bool pr_bool pr_bool pr_bool; + register_basic_print0 Stdarg.wit_unit pr_unit pr_unit pr_unit; + register_basic_print0 Stdarg.wit_pre_ident str str str; + register_basic_print0 Stdarg.wit_string qstring qstring qstring let () = - let printer _ _ prtac = prtac (0, E) in - declare_extra_genarg_pprule wit_tactic printer printer printer + let printer _ _ prtac = prtac in + declare_extra_genarg_pprule_with_level wit_tactic printer printer printer + ltop (0,E) let () = - let pr_unit _ _ _ () = str "()" in - let printer _ _ prtac = prtac (0, E) in - declare_extra_genarg_pprule wit_ltac printer printer pr_unit + let pr_unit _ _ _ _ () = str "()" in + let printer _ _ prtac = prtac in + declare_extra_genarg_pprule_with_level wit_ltac printer printer pr_unit + ltop (0,E) diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli index 5ecfaf590c..bda5774abf 100644 --- a/plugins/ltac/pptactic.mli +++ b/plugins/ltac/pptactic.mli @@ -40,12 +40,37 @@ type 'a extra_genarg_printer = (tolerability -> Val.t -> Pp.t) -> 'a -> Pp.t +type 'a raw_extra_genarg_printer_with_level = + (constr_expr -> Pp.t) -> + (constr_expr -> Pp.t) -> + (tolerability -> raw_tactic_expr -> Pp.t) -> + tolerability -> 'a -> Pp.t + +type 'a glob_extra_genarg_printer_with_level = + (glob_constr_and_expr -> Pp.t) -> + (glob_constr_and_expr -> Pp.t) -> + (tolerability -> glob_tactic_expr -> Pp.t) -> + tolerability -> 'a -> Pp.t + +type 'a extra_genarg_printer_with_level = + (EConstr.constr -> Pp.t) -> + (EConstr.constr -> Pp.t) -> + (tolerability -> Val.t -> Pp.t) -> + tolerability -> 'a -> Pp.t + val declare_extra_genarg_pprule : ('a, 'b, 'c) genarg_type -> 'a raw_extra_genarg_printer -> 'b glob_extra_genarg_printer -> 'c extra_genarg_printer -> unit +val declare_extra_genarg_pprule_with_level : + ('a, 'b, 'c) genarg_type -> + 'a raw_extra_genarg_printer_with_level -> + 'b glob_extra_genarg_printer_with_level -> + 'c extra_genarg_printer_with_level -> + (* surroounded *) tolerability -> (* non-surroounded *) tolerability -> unit + val declare_extra_vernac_genarg_pprule : ('a, 'b, 'c) genarg_type -> 'a raw_extra_genarg_printer -> unit diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index c63492d1be..c0060c5a7c 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -1800,9 +1800,9 @@ let declare_instance_trans global binders a aeq n lemma = in anew_instance global binders instance [(Ident (Loc.tag @@ Id.of_string "transitivity"),lemma)] -let declare_relation ?(binders=[]) a aeq n refl symm trans = +let declare_relation ?locality ?(binders=[]) a aeq n refl symm trans = init_setoid (); - let global = not (Locality.make_section_locality (Locality.LocalityFixme.consume ())) in + let global = not (Locality.make_section_locality locality) in let instance = declare_instance a aeq (add_suffix n "_relation") "Coq.Classes.RelationClasses.RewriteRelation" in ignore(anew_instance global binders instance []); match (refl,symm,trans) with @@ -1884,11 +1884,11 @@ 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 ~names:[] ~extensible:true sigma in + let univs = Evd.const_univ_entry ~poly sigma in let typ = EConstr.to_constr sigma typ in let term = EConstr.to_constr sigma term in let cst = - Declare.definition_entry ~types:typ ~poly ~univs:ctx term + Declare.definition_entry ~types:typ ~univs term in ignore(Declare.declare_constant n (Entries.DefinitionEntry cst, Decl_kinds.IsDefinition Decl_kinds.Definition)) @@ -1972,9 +1972,10 @@ let add_morphism_infer glob m n = let evd = Evd.from_env env in let uctx, instance = build_morphism_signature env evd m in if Lib.is_modtype () then + let uctx = UState.const_univ_entry ~poly uctx in let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest instance_id (Entries.ParameterEntry - (None,poly,(instance,UState.context uctx),None), + (None,(instance,uctx),None), Decl_kinds.IsAssumption Decl_kinds.Logical) in add_instance (Typeclasses.new_instance diff --git a/plugins/ltac/rewrite.mli b/plugins/ltac/rewrite.mli index 1306c590ba..17e7244b39 100644 --- a/plugins/ltac/rewrite.mli +++ b/plugins/ltac/rewrite.mli @@ -75,7 +75,7 @@ val cl_rewrite_clause : val is_applied_rewrite_relation : env -> evar_map -> rel_context -> constr -> types option -val declare_relation : +val declare_relation : ?locality:bool -> ?binders:local_binder_expr list -> constr_expr -> constr_expr -> Id.t -> constr_expr option -> constr_expr option -> constr_expr option -> unit diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml index c03a867326..9ae112d371 100644 --- a/plugins/ltac/taccoerce.ml +++ b/plugins/ltac/taccoerce.ml @@ -33,7 +33,7 @@ let (wit_constr_under_binders : (Empty.t, Empty.t, Ltac_pretype.constr_under_bin let () = register_val0 wit None in let () = Genprint.register_val_print0 (base_val_typ wit) (fun c -> - Genprint.PrinterNeedsContext (fun env sigma -> Printer.pr_constr_under_binders_env env sigma c)) in + Genprint.TopPrinterNeedsContext (fun env sigma -> Printer.pr_constr_under_binders_env env sigma c)) in wit (** All the types considered here are base types *) diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 1a8ec6d6f6..e0d7eca5f8 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -128,7 +128,7 @@ let (wit_tacvalue : (Empty.t, tacvalue, tacvalue) Genarg.genarg_type) = let wit = Genarg.create_arg "tacvalue" in let () = register_val0 wit None in let () = Genprint.register_val_print0 (base_val_typ wit) - (fun _ -> Genprint.PrinterBasic (fun () -> str "<tactic closure>")) in + (fun _ -> Genprint.TopPrinterBasic (fun () -> str "<tactic closure>")) in wit let of_tacvalue v = in_gen (topwit wit_tacvalue) v @@ -242,9 +242,9 @@ let pr_value env v = | None -> str "a value of type" ++ spc () ++ pr_argument_type v in let open Genprint in match generic_val_print v with - | PrinterBasic pr -> pr () - | PrinterNeedsContext pr -> pr_with_env pr - | PrinterNeedsContextAndLevel { default_already_surrounded; printer } -> + | TopPrinterBasic pr -> pr () + | TopPrinterNeedsContext pr -> pr_with_env pr + | TopPrinterNeedsContextAndLevel { default_already_surrounded; printer } -> pr_with_env (fun env sigma -> printer env sigma default_already_surrounded) let pr_closure env ist body = @@ -821,9 +821,9 @@ let message_of_value v = Ftactic.enter begin fun gl -> Ftactic.return (pr (pf_env gl) (project gl)) end in let open Genprint in match generic_val_print v with - | PrinterBasic pr -> Ftactic.return (pr ()) - | PrinterNeedsContext pr -> pr_with_env pr - | PrinterNeedsContextAndLevel { default_ensure_surrounded; printer } -> + | TopPrinterBasic pr -> Ftactic.return (pr ()) + | TopPrinterNeedsContext pr -> pr_with_env pr + | TopPrinterNeedsContextAndLevel { default_ensure_surrounded; printer } -> pr_with_env (fun env sigma -> printer env sigma default_ensure_surrounded) let interp_message_token ist = function @@ -1353,8 +1353,8 @@ and interp_app loc ist fv largs : Val.t Ftactic.t = begin let open Genprint in match generic_val_print v with - | PrinterBasic _ -> call_debug None - | PrinterNeedsContext _ | PrinterNeedsContextAndLevel _ -> + | TopPrinterBasic _ -> call_debug None + | TopPrinterNeedsContext _ | TopPrinterNeedsContextAndLevel _ -> Proofview.Goal.enter (fun gl -> call_debug (Some (pf_env gl,project gl))) end <*> if List.is_empty lval then Ftactic.return v else interp_app loc ist v lval @@ -1380,13 +1380,38 @@ and tactic_of_value ist vle = extra = TacStore.set ist.extra f_trace []; } in let tac = name_if_glob appl (eval_tactic ist t) in Profile_ltac.do_profile "tactic_of_value" trace (catch_error_tac trace tac) - | VFun (_, _, _,vars,_) -> - let numargs = List.length vars in - Tacticals.New.tclZEROMSG - (str "A fully applied tactic is expected:" ++ spc() ++ Pp.str "missing " ++ - Pp.str (String.plural numargs "argument") ++ Pp.str " for " ++ - Pp.str (String.plural numargs "variable") ++ Pp.str " " ++ - pr_enum Name.print vars ++ Pp.str ".") + | VFun (appl,_,vmap,vars,_) -> + let tactic_nm = + match appl with + UnnamedAppl -> "An unnamed user-defined tactic" + | GlbAppl apps -> + let nms = List.map (fun (kn,_) -> Names.KerName.to_string kn) apps in + match nms with + [] -> assert false + | kn::_ -> "The user-defined tactic \"" ^ kn ^ "\"" (* TODO: when do we not have a singleton? *) + in + let numargs = List.length vars in + let givenargs = + List.map (fun (arg,_) -> Names.Id.to_string arg) (Names.Id.Map.bindings vmap) in + let numgiven = List.length givenargs in + Tacticals.New.tclZEROMSG + (Pp.str tactic_nm ++ Pp.str " was not fully applied:" ++ spc() ++ + (match numargs with + 0 -> assert false + | 1 -> + Pp.str "There is a missing argument for variable " ++ + (Name.print (List.hd vars)) + | _ -> Pp.str "There are missing arguments for variables " ++ + pr_enum Name.print vars) ++ Pp.pr_comma () ++ + match numgiven with + 0 -> + Pp.str "no arguments at all were provided." + | 1 -> + Pp.str "an argument was provided for variable " ++ + Pp.str (List.hd givenargs) ++ Pp.str "." + | _ -> + Pp.str "arguments were provided for variables " ++ + pr_enum Pp.str givenargs ++ Pp.str ".") | VRec _ -> Tacticals.New.tclZEROMSG (str "A fully applied tactic is expected.") else if has_type vle (topwit wit_tactic) then let tac = out_gen (topwit wit_tactic) vle in diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml index 180fb2db40..918d1faebe 100644 --- a/plugins/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -91,9 +91,10 @@ let subst_global_reference subst = let subst_global ref = let ref',t' = subst_global subst ref in if not (is_global ref' t') then - Feedback.msg_warning (strbrk "The reference " ++ pr_global ref ++ str " is not " ++ - str " expanded to \"" ++ pr_lconstr t' ++ str "\", but to " ++ - pr_global ref') ; + (let sigma, env = Pfedit.get_current_context () in + Feedback.msg_warning (strbrk "The reference " ++ pr_global ref ++ str " is not " ++ + str " expanded to \"" ++ pr_lconstr_env env sigma t' ++ str "\", but to " ++ + pr_global ref')); ref' in subst_or_var (subst_located subst_global) diff --git a/plugins/ltac/tactic_debug.ml b/plugins/ltac/tactic_debug.ml index a669692fc9..2dd7c9a747 100644 --- a/plugins/ltac/tactic_debug.ml +++ b/plugins/ltac/tactic_debug.ml @@ -20,7 +20,9 @@ let prmatchpatt env sigma hyp = Pptactic.pr_match_pattern (Printer.pr_constr_pattern_env env sigma) hyp let prmatchrl rl = Pptactic.pr_match_rule false (Pptactic.pr_glob_tactic (Global.env())) - (fun (_,p) -> Printer.pr_constr_pattern p) rl + (fun (_,p) -> + let sigma, env = Pfedit.get_current_context () in + Printer.pr_constr_pattern_env env sigma p) rl (* This module intends to be a beginning of debugger for tactic expressions. Currently, it is quite simple and we can hope to have, in the future, a more @@ -369,7 +371,8 @@ let explain_ltac_call_trace last trace loc = strbrk " (with " ++ prlist_with_sep pr_comma (fun (id,c) -> - Id.print id ++ str ":=" ++ Printer.pr_lconstr_under_binders c) + let sigma, env = Pfedit.get_current_context () in + Id.print id ++ str ":=" ++ Printer.pr_lconstr_under_binders_env env sigma c) (List.rev (Id.Map.bindings vars)) ++ str ")" else mt()) in diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 218342efe4..cb54cac3f1 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -984,7 +984,9 @@ struct let parse_expr sigma parse_constant parse_exp ops_spec env term = if debug - then Feedback.msg_debug (Pp.str "parse_expr: " ++ Printer.pr_leconstr term); + then ( + let _, env = Pfedit.get_current_context () in + Feedback.msg_debug (Pp.str "parse_expr: " ++ Printer.pr_leconstr_env env sigma term)); (* let constant_or_variable env term = @@ -1103,9 +1105,10 @@ struct | _ -> raise ParseError - let rconstant sigma term = + let rconstant sigma term = + let _, env = Pfedit.get_current_context () in if debug - then Feedback.msg_debug (Pp.str "rconstant: " ++ Printer.pr_leconstr term ++ fnl ()); + then Feedback.msg_debug (Pp.str "rconstant: " ++ Printer.pr_leconstr_env env sigma term ++ fnl ()); let res = rconstant sigma term in if debug then (Printf.printf "rconstant -> %a\n" pp_Rcst res ; flush stdout) ; @@ -1145,9 +1148,9 @@ struct let parse_arith parse_op parse_expr env cstr gl = let sigma = gl.sigma in - if debug - then Feedback.msg_debug (Pp.str "parse_arith: " ++ Printer.pr_leconstr cstr ++ fnl ()); - match EConstr.kind sigma cstr with + if debug + then Feedback.msg_debug (Pp.str "parse_arith: " ++ Printer.pr_leconstr_env gl.env sigma cstr ++ fnl ()); + match EConstr.kind sigma cstr with | Term.App(op,args) -> let (op,lhs,rhs) = parse_op gl (op,args) in let (e1,env) = parse_expr sigma env lhs in @@ -1908,7 +1911,7 @@ let micromega_tauto negate normalise unsat deduce spec prover env polys1 polys2 let formula_typ = (EConstr.mkApp(Lazy.force coq_Cstr, [|spec.coeff|])) in let ff = dump_formula formula_typ (dump_cstr spec.typ spec.dump_coeff) ff in - Feedback.msg_notice (Printer.pr_leconstr ff); + Feedback.msg_notice (Printer.pr_leconstr_env gl.env gl.sigma ff); Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff end; @@ -1932,9 +1935,9 @@ let micromega_tauto negate normalise unsat deduce spec prover env polys1 polys2 Feedback.msg_notice (Pp.str "\nAFormula\n") ; let formula_typ = (EConstr.mkApp( Lazy.force coq_Cstr,[| spec.coeff|])) in let ff' = dump_formula formula_typ - (dump_cstr spec.typ spec.dump_coeff) ff' in - Feedback.msg_notice (Printer.pr_leconstr ff'); - Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff' + (dump_cstr spec.typ spec.dump_coeff) ff' in + Feedback.msg_notice (Printer.pr_leconstr_env gl.env gl.sigma ff'); + Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff' end; (* Even if it does not work, this does not mean it is not provable diff --git a/plugins/micromega/micromega.ml b/plugins/micromega/micromega.ml index 7da4a3b829..52c6ef983d 100644 --- a/plugins/micromega/micromega.ml +++ b/plugins/micromega/micromega.ml @@ -981,8 +981,8 @@ let rec or_cnf unsat deduce f f' = (** val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf **) -let and_cnf f1 f2 = - app f1 f2 +let and_cnf = + app (** val xcnf : ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 @@ -1204,22 +1204,22 @@ type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't pExpr } 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol **) -let norm cO cI cplus ctimes cminus copp ceqb = - norm_aux cO cI cplus ctimes cminus copp ceqb +let norm = + norm_aux (** val psub0 : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) -let psub0 cO cplus cminus copp ceqb = - psub cO cplus cminus copp ceqb +let psub0 = + psub (** val padd0 : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) -let padd0 cO cplus ceqb = - padd cO cplus ceqb +let padd0 = + padd (** val xnormalise : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml index 49ccb468c1..387a525141 100644 --- a/plugins/micromega/persistent_cache.ml +++ b/plugins/micromega/persistent_cache.ml @@ -149,7 +149,7 @@ let open_in f = match read_key_elem inch with | None -> () | Some (key,elem) -> - Table.add htbl key elem ; + Table.replace htbl key elem ; xload () in try (* Locking of the (whole) file while reading *) @@ -195,7 +195,7 @@ let add t k e = else let fd = descr_of_out_channel outch in begin - Table.add tbl k e ; + Table.replace tbl k e ; do_under_lock Write fd (fun _ -> Marshal.to_channel outch (k,e) [Marshal.No_sharing] ; diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index ff69ddefb8..8692842468 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -466,12 +466,14 @@ let destructurate_prop sigma t = | Prod (Name _,_,_),[] -> CErrors.user_err Pp.(str "Omega: Not a quantifier-free goal") | _ -> Kufo -let destructurate_type sigma t = - let eq_constr c1 c2 = eq_constr sigma c1 c2 in - let c, args = decompose_app sigma t in +let nf = Tacred.simpl + +let destructurate_type env sigma t = + let is_conv = Reductionops.is_conv env sigma in + let c, args = decompose_app sigma (nf env sigma t) in match EConstr.kind sigma c, args with - | _, [] when eq_constr c (Lazy.force coq_Z) -> Kapp (Z,args) - | _, [] when eq_constr c (Lazy.force coq_nat) -> Kapp (Nat,args) + | _, [] when is_conv c (Lazy.force coq_Z) -> Kapp (Z,args) + | _, [] when is_conv c (Lazy.force coq_nat) -> Kapp (Nat,args) | _ -> Kufo let destructurate_term sigma t = @@ -1459,17 +1461,13 @@ let normalize_equation sigma id flag theorem pos t t1 t2 (tactic,defs) = else (tactic,defs) -let pf_nf gl c = Tacmach.New.pf_apply Tacred.simpl gl c - -let destructure_omega gl tac_def (id,c) = - let open Tacmach.New in - let sigma = project gl in +let destructure_omega env sigma tac_def (id,c) = if String.equal (atompart_of_id id) "State" then tac_def else try match destructurate_prop sigma c with | Kapp(Eq,[typ;t1;t2]) - when begin match destructurate_type sigma (pf_nf gl typ) with Kapp(Z,[]) -> true | _ -> false end -> + when begin match destructurate_type env sigma typ with Kapp(Z,[]) -> true | _ -> false end -> let t = mk_plus t1 (mk_inv t2) in normalize_equation sigma id EQUA (Lazy.force coq_Zegal_left) 2 t t1 t2 tac_def @@ -1507,7 +1505,7 @@ let coq_omega = Proofview.Goal.enter begin fun gl -> clear_constr_tables (); let hyps_types = Tacmach.New.pf_hyps_types gl in - let destructure_omega = destructure_omega gl in + let destructure_omega = Tacmach.New.pf_apply destructure_omega gl in let tactic_normalisation, system = List.fold_left destructure_omega ([],[]) hyps_types in let prelude,sys = @@ -1727,27 +1725,26 @@ let not_binop = function exception Undecidable -let rec decidability gl t = - let open Tacmach.New in - match destructurate_prop (project gl) t with +let rec decidability env sigma t = + match destructurate_prop sigma t with | Kapp(Or,[t1;t2]) -> mkApp (Lazy.force coq_dec_or, [| t1; t2; - decidability gl t1; decidability gl t2 |]) + decidability env sigma t1; decidability env sigma t2 |]) | Kapp(And,[t1;t2]) -> mkApp (Lazy.force coq_dec_and, [| t1; t2; - decidability gl t1; decidability gl t2 |]) + decidability env sigma t1; decidability env sigma t2 |]) | Kapp(Iff,[t1;t2]) -> mkApp (Lazy.force coq_dec_iff, [| t1; t2; - decidability gl t1; decidability gl t2 |]) + decidability env sigma t1; decidability env sigma t2 |]) | Kimp(t1,t2) -> (* This is the only situation where it's not obvious that [t] is in Prop. The recursive call on [t2] will ensure that. *) mkApp (Lazy.force coq_dec_imp, - [| t1; t2; decidability gl t1; decidability gl t2 |]) + [| t1; t2; decidability env sigma t1; decidability env sigma t2 |]) | Kapp(Not,[t1]) -> - mkApp (Lazy.force coq_dec_not, [| t1; decidability gl t1 |]) + mkApp (Lazy.force coq_dec_not, [| t1; decidability env sigma t1 |]) | Kapp(Eq,[typ;t1;t2]) -> - begin match destructurate_type (project gl) (pf_nf gl typ) with + begin match destructurate_type env sigma typ with | Kapp(Z,[]) -> mkApp (Lazy.force coq_dec_eq, [| t1;t2 |]) | Kapp(Nat,[]) -> mkApp (Lazy.force coq_dec_eq_nat, [| t1;t2 |]) | _ -> raise Undecidable @@ -1784,15 +1781,16 @@ let onClearedName2 id tac = let destructure_hyps = Proofview.Goal.enter begin fun gl -> let type_of = Tacmach.New.pf_unsafe_type_of gl in - let decidability = decidability gl in - let pf_nf = pf_nf gl in + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let decidability = decidability env sigma in let rec loop = function | [] -> (tclTHEN nat_inject coq_omega) | LocalDef (i,body,typ) :: lit when !letin_flag -> Proofview.tclEVARMAP >>= fun sigma -> begin try - match destructurate_type sigma (pf_nf typ) with + match destructurate_type env sigma typ with | Kapp(Nat,_) | Kapp(Z,_) -> let hid = fresh_id Id.Set.empty (add_suffix i "_eqn") gl in let hty = mk_gen_eq typ (mkVar i) body in @@ -1895,7 +1893,7 @@ let destructure_hyps = with Not_found -> loop lit) | Kapp(Eq,[typ;t1;t2]) -> if !old_style_flag then begin - match destructurate_type sigma (pf_nf typ) with + match destructurate_type env sigma typ with | Kapp(Nat,_) -> tclTHENLIST [ (simplest_elim @@ -1912,7 +1910,7 @@ let destructure_hyps = ] | _ -> loop lit end else begin - match destructurate_type sigma (pf_nf typ) with + match destructurate_type env sigma typ with | Kapp(Nat,_) -> (tclTHEN (convert_hyp_no_check (NamedDecl.set_type (mkApp (Lazy.force coq_neq, [| t1;t2|])) @@ -1940,7 +1938,9 @@ let destructure_hyps = let destructure_goal = Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in - let decidability = decidability gl in + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let decidability = decidability env sigma in let rec loop t = Proofview.tclEVARMAP >>= fun sigma -> let prop () = Proofview.tclUNIT (destructurate_prop sigma t) in diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index 96bf31b11a..0ea8904f2c 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -104,7 +104,7 @@ open CErrors open Util open Names -open Term +open Constr open EConstr open Pattern open Patternops diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml index 5397b00656..0d491d92bd 100644 --- a/plugins/romega/const_omega.ml +++ b/plugins/romega/const_omega.ml @@ -7,7 +7,6 @@ *************************************************************************) open Names -open Term open Constr let module_refl_name = "ReflOmegaCore" @@ -156,7 +155,7 @@ let mk_list univ typ l = loop l let mk_plist = - let type1lev = Universes.new_univ_level (Global.current_dirpath ()) in + let type1lev = Universes.new_univ_level () in fun l -> mk_list type1lev mkProp l let mk_list = mk_list Univ.Level.set @@ -198,6 +197,7 @@ let parse_logic_rel c = match destructurate c with (* Binary numbers *) +let coq_Z = lazy (bin_constant "Z") let coq_xH = lazy (bin_constant "xH") let coq_xO = lazy (bin_constant "xO") let coq_xI = lazy (bin_constant "xI") @@ -238,7 +238,7 @@ end module Z : Int = struct -let typ = lazy (bin_constant "Z") +let typ = coq_Z let plus = lazy (z_constant "Z.add") let mult = lazy (z_constant "Z.mul") let opp = lazy (z_constant "Z.opp") @@ -286,14 +286,9 @@ let parse_term t = (match recognize_Z t with Some t -> Tnum t | None -> Tother) | _ -> Tother -let pf_nf gl c = - EConstr.Unsafe.to_constr - (Tacmach.New.pf_apply Tacred.simpl gl (EConstr.of_constr c)) - let is_int_typ gl t = - match destructurate (pf_nf gl t) with - | Kapp("Z",[]) -> true - | _ -> false + Tacmach.New.pf_apply Reductionops.is_conv gl + (EConstr.of_constr t) (EConstr.of_constr (Lazy.force coq_Z)) let parse_rel gl t = match destructurate t with diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index 430b608f4c..54ff44fbd3 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -183,8 +183,9 @@ let print_env_reification env = let rec loop c i = function [] -> str " ===============================\n\n" | t :: l -> + let sigma, env = Pfedit.get_current_context () in let s = Printf.sprintf "(%c%02d)" c i in - spc () ++ str s ++ str " := " ++ Printer.pr_lconstr t ++ fnl () ++ + spc () ++ str s ++ str " := " ++ Printer.pr_lconstr_env env sigma t ++ fnl () ++ loop c (succ i) l in let prop_info = str "ENVIRONMENT OF PROPOSITIONS :" ++ fnl () ++ loop 'P' 0 env.props in diff --git a/plugins/setoid_ring/ArithRing.v b/plugins/setoid_ring/ArithRing.v index 447acb9057..8e4d8b0d34 100644 --- a/plugins/setoid_ring/ArithRing.v +++ b/plugins/setoid_ring/ArithRing.v @@ -41,9 +41,12 @@ Ltac Ss_to_add f acc := | _ => constr:((acc + f)%nat) end. +(* For internal use only *) +Local Definition protected_to_nat := N.to_nat. + Ltac natprering := match goal with - |- context C [S ?p] => + |- context C [S ?p] => match p with O => fail 1 (* avoid replacing 1 with 1+0 ! *) | p => match isnatcst p with @@ -52,9 +55,19 @@ Ltac natprering := fold v; natprering end end - | _ => idtac + | _ => change N.to_nat with protected_to_nat + end. + +Ltac natpostring := + match goal with + | |- context [N.to_nat ?x] => + let v := eval cbv in (N.to_nat x) in + change (N.to_nat x) with v; + natpostring + | _ => change protected_to_nat with N.to_nat end. Add Ring natr : natSRth - (morphism nat_morph_N, constants [natcst], preprocess [natprering]). + (morphism nat_morph_N, constants [natcst], + preprocess [natprering], postprocess [natpostring]). diff --git a/plugins/setoid_ring/g_newring.ml4 b/plugins/setoid_ring/g_newring.ml4 index 05ab8ab326..a7d6d5bb20 100644 --- a/plugins/setoid_ring/g_newring.ml4 +++ b/plugins/setoid_ring/g_newring.ml4 @@ -82,10 +82,11 @@ VERNAC COMMAND EXTEND AddSetoidRing CLASSIFIED AS SIDEFF | [ "Print" "Rings" ] => [Vernac_classifier.classify_as_query] -> [ Feedback.msg_notice (strbrk "The following ring structures have been declared:"); Spmap.iter (fun fn fi -> + let sigma, env = Pfedit.get_current_context () in Feedback.msg_notice (hov 2 (Ppconstr.pr_id (Libnames.basename fn)++spc()++ - str"with carrier "++ pr_constr fi.ring_carrier++spc()++ - str"and equivalence relation "++ pr_constr fi.ring_req)) + str"with carrier "++ pr_constr_env env sigma fi.ring_carrier++spc()++ + str"and equivalence relation "++ pr_constr_env env sigma fi.ring_req)) ) !from_name ] END @@ -117,10 +118,11 @@ VERNAC COMMAND EXTEND AddSetoidField CLASSIFIED AS SIDEFF | [ "Print" "Fields" ] => [Vernac_classifier.classify_as_query] -> [ Feedback.msg_notice (strbrk "The following field structures have been declared:"); Spmap.iter (fun fn fi -> + let sigma, env = Pfedit.get_current_context () in Feedback.msg_notice (hov 2 (Ppconstr.pr_id (Libnames.basename fn)++spc()++ - str"with carrier "++ pr_constr fi.field_carrier++spc()++ - str"and equivalence relation "++ pr_constr fi.field_req)) + str"with carrier "++ pr_constr_env env sigma fi.field_carrier++spc()++ + str"and equivalence relation "++ pr_constr_env env sigma fi.field_req)) ) !field_from_name ] END diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 9e4b896f8e..e3e749b754 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -150,13 +150,14 @@ let ic_unsafe c = (*FIXME remove *) let sigma = Evd.from_env env in EConstr.of_constr (fst (Constrintern.interp_constr env sigma c)) -let decl_constant na ctx c = +let decl_constant na univs c = let open Constr in - let vars = Univops.universes_of_constr c in - let ctx = Univops.restrict_universe_context (Univ.ContextSet.of_context ctx) vars in + let env = Global.env () in + let vars = Univops.universes_of_constr env c in + let univs = Univops.restrict_universe_context univs vars in + let univs = Monomorphic_const_entry univs in mkConst(declare_constant (Id.of_string na) - (DefinitionEntry (definition_entry ~opaque:true - ~univs:(Univ.ContextSet.to_context ctx) c), + (DefinitionEntry (definition_entry ~opaque:true ~univs c), IsProof Lemma)) (* Calling a global tactic *) @@ -220,7 +221,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 ~names:[] ~extensible:true evd) + Array.map nf !tactic_res, Evd.universe_context_set evd let stdlib_modules = [["Coq";"Setoids";"Setoid"]; @@ -344,8 +345,6 @@ let _ = add_map "ring" (****************************************************************************) (* Ring database *) -let pr_constr c = pr_econstr c - module Cmap = Map.Make(Constr) let from_carrier = Summary.ref Cmap.empty ~name:"ring-tac-carrier-table" @@ -368,7 +367,7 @@ let find_ring_structure env sigma l = with Not_found -> CErrors.user_err ~hdr:"ring" (str"cannot find a declared ring structure over"++ - spc()++str"\""++pr_constr ty++str"\"")) + spc() ++ str"\"" ++ pr_econstr_env env sigma ty ++ str"\"")) | [] -> assert false let add_entry (sp,_kn) e = @@ -529,19 +528,19 @@ let ring_equality env evd (r,add,mul,opp,req) = op_morph r add mul opp req add_m_lem mul_m_lem opp_m_lem in Flags.if_verbose Feedback.msg_info - (str"Using setoid \""++pr_constr req++str"\""++spc()++ - str"and morphisms \""++pr_constr add_m_lem ++ - str"\","++spc()++ str"\""++pr_constr mul_m_lem++ - str"\""++spc()++str"and \""++pr_constr opp_m_lem++ + (str"Using setoid \""++ pr_econstr_env env !evd req++str"\""++spc()++ + str"and morphisms \""++pr_econstr_env env !evd add_m_lem ++ + str"\","++spc()++ str"\""++pr_econstr_env env !evd mul_m_lem++ + str"\""++spc()++str"and \""++pr_econstr_env env !evd opp_m_lem++ str"\""); op_morph) | None -> (Flags.if_verbose Feedback.msg_info - (str"Using setoid \""++pr_constr req ++str"\"" ++ spc() ++ - str"and morphisms \""++pr_constr add_m_lem ++ + (str"Using setoid \""++pr_econstr_env env !evd req ++str"\"" ++ spc() ++ + str"and morphisms \""++pr_econstr_env env !evd add_m_lem ++ str"\""++spc()++str"and \""++ - pr_constr mul_m_lem++str"\""); + pr_econstr_env env !evd mul_m_lem++str"\""); op_smorph r add mul req add_m_lem mul_m_lem) in (setoid,op_morph) @@ -861,7 +860,7 @@ let find_field_structure env sigma l = with Not_found -> CErrors.user_err ~hdr:"field" (str"cannot find a declared field structure over"++ - spc()++str"\""++pr_constr ty++str"\"")) + spc()++str"\""++pr_econstr_env env sigma ty++str"\"")) | [] -> assert false let add_field_entry (sp,_kn) e = diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index c1d7e62785..047ca509be 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -240,7 +240,7 @@ let interp_refine ist gl rc = in let sigma, c = Pretyping.understand_ltac flags (pf_env gl) (project gl) vars kind rc in (* ppdebug(lazy(str"sigma@interp_refine=" ++ pr_evar_map None sigma)); *) - ppdebug(lazy(str"c@interp_refine=" ++ Printer.pr_econstr c)); + ppdebug(lazy(str"c@interp_refine=" ++ Printer.pr_econstr_env (pf_env gl) sigma c)); (sigma, (sigma, c)) @@ -539,7 +539,7 @@ module Intset = Evar.Set let pf_abs_evars_pirrel gl (sigma, c0) = pp(lazy(str"==PF_ABS_EVARS_PIRREL==")); - pp(lazy(str"c0= " ++ Printer.pr_constr c0)); + pp(lazy(str"c0= " ++ Printer.pr_constr_env (pf_env gl) sigma c0)); let sigma0 = project gl in let c0 = nf_evar sigma0 (nf_evar sigma c0) in let nenv = env_size (pf_env gl) in @@ -563,9 +563,9 @@ let pf_abs_evars_pirrel gl (sigma, c0) = | _ -> Constr.fold put evlist c in let evlist = put [] c0 in if evlist = [] then 0, c0 else - let pr_constr t = Printer.pr_econstr (Reductionops.nf_beta (project gl) (EConstr.of_constr t)) in + let pr_constr t = Printer.pr_econstr_env (pf_env gl) sigma (Reductionops.nf_beta (project gl) (EConstr.of_constr t)) in pp(lazy(str"evlist=" ++ pr_list (fun () -> str";") - (fun (k,_) -> str(Evd.string_of_existential k)) evlist)); + (fun (k,_) -> Evar.print k) evlist)); let evplist = let depev = List.fold_left (fun evs (_,(_,t,_)) -> let t = EConstr.of_constr t in @@ -959,7 +959,7 @@ let applyn ~with_evars ?beta ?(with_shelve=false) n t gl = loop (meta_declare m (EConstr.Unsafe.to_constr ty) sigma) bo ((EConstr.mkMeta m)::args) (n-1) | _ -> assert false in loop sigma t [] n in - pp(lazy(str"Refiner.refiner " ++ Printer.pr_econstr t)); + pp(lazy(str"Refiner.refiner " ++ Printer.pr_econstr_env (pf_env gl) (project gl) t)); Tacmach.refine_no_check t gl let refine_with ?(first_goes_last=false) ?beta ?(with_evars=true) oc gl = @@ -973,7 +973,7 @@ let refine_with ?(first_goes_last=false) ?beta ?(with_evars=true) oc gl = compose_lam (let xs,y = List.chop (n-1) l in y @ xs) (mkApp (compose_lam l c, Array.of_list (mkRel 1 :: mkRels n))) in - pp(lazy(str"after: " ++ Printer.pr_constr oc)); + pp(lazy(str"after: " ++ Printer.pr_constr_env (pf_env gl) (project gl) oc)); try applyn ~with_evars ~with_shelve:true ?beta n (EConstr.of_constr oc) gl with e when CErrors.noncritical e -> raise dependent_apply_error @@ -1202,7 +1202,7 @@ let genclrtac cl cs clr = let gentac ist gen gl = (* ppdebug(lazy(str"sigma@gentac=" ++ pr_evar_map None (project gl))); *) let conv, _, cl, c, clr, ucst,gl = pf_interp_gen_aux ist gl false gen in - ppdebug(lazy(str"c@gentac=" ++ pr_econstr c)); + ppdebug(lazy(str"c@gentac=" ++ pr_econstr_env (pf_env gl) (project gl) c)); let gl = pf_merge_uc ucst gl in if conv then tclTHEN (Proofview.V82.of_tactic (convert_concl cl)) (cleartac clr) gl diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml index 26b5c57675..4e0b44a44d 100644 --- a/plugins/ssr/ssrelim.ml +++ b/plugins/ssr/ssrelim.ml @@ -46,7 +46,7 @@ let analyze_eliminator elimty env sigma = if not (EConstr.eq_constr sigma t t') then loop ctx t' else errorstrm Pp.(str"The eliminator has the wrong shape."++spc()++ str"A (applied) bound variable was expected as the conclusion of "++ - str"the eliminator's"++Pp.cut()++str"type:"++spc()++pr_econstr elimty) in + str"the eliminator's"++Pp.cut()++str"type:"++spc()++pr_econstr_env env' sigma elimty) in let ctx, pred_id, elim_is_dep, n_pred_args,concl = loop [] elimty in let n_elim_args = Context.Rel.nhyps ctx in let is_rec_elim = @@ -126,7 +126,7 @@ let ssrelim ?(ind=ref None) ?(is_case=false) ?ist deps what ?elim eqid elim_intr ppdebug(lazy Pp.(str"matching: " ++ pr_occ occ ++ pp_pattern p)); let (c,ucst), cl = fill_occ_pattern ~raise_NoMatch:true env sigma0 (EConstr.Unsafe.to_constr cl) p occ h in - ppdebug(lazy Pp.(str" got: " ++ pr_constr c)); + ppdebug(lazy Pp.(str" got: " ++ pr_constr_env env sigma0 c)); c, EConstr.of_constr cl, ucst in let mkTpat gl t = (* takes a term, refreshes it and makes a T pattern *) let n, t, _, ucst = pf_abs_evars orig_gl (project gl, fire_subst gl t) in @@ -239,8 +239,8 @@ let ssrelim ?(ind=ref None) ?(is_case=false) ?ist deps what ?elim eqid elim_intr | Some (c, _, _,gl) -> true, gl | None -> errorstrm Pp.(str"Unable to apply the eliminator to the term"++ - spc()++pr_econstr c++spc()++str"or to unify it's type with"++ - pr_econstr inf_arg_ty) in + spc()++pr_econstr_env env (project gl) c++spc()++str"or to unify it's type with"++ + pr_econstr_env env (project gl) inf_arg_ty) in ppdebug(lazy Pp.(str"c_is_head_p= " ++ bool c_is_head_p)); let gl, predty = pfe_type_of gl pred in (* Patterns for the inductive types indexes to be bound in pred are computed diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index e82f222b9c..bd9633afbd 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -77,7 +77,7 @@ let interp_congrarg_at ist gl n rf ty m = if i + n > m then None else try let rt = mkRApp congrn (args1 @ mkRApp rf (mkRHoles i) :: args2) in - ppdebug(lazy Pp.(str"rt=" ++ Printer.pr_glob_constr rt)); + ppdebug(lazy Pp.(str"rt=" ++ Printer.pr_glob_constr_env (pf_env gl) rt)); Some (interp_refine ist gl rt) with _ -> loop (i + 1) in loop 0 @@ -86,7 +86,7 @@ let pattern_id = mk_internal_id "pattern value" let congrtac ((n, t), ty) ist gl = ppdebug(lazy (Pp.str"===congr===")); - ppdebug(lazy Pp.(str"concl=" ++ Printer.pr_econstr (Tacmach.pf_concl gl))); + ppdebug(lazy Pp.(str"concl=" ++ Printer.pr_econstr_env (pf_env gl) (project gl) (Tacmach.pf_concl gl))); let sigma, _ as it = interp_term ist gl t in let gl = pf_merge_uc_of sigma gl in let _, f, _, _ucst = pf_abs_evars gl it in @@ -109,7 +109,7 @@ let congrtac ((n, t), ty) ist gl = let newssrcongrtac arg ist gl = ppdebug(lazy Pp.(str"===newcongr===")); - ppdebug(lazy Pp.(str"concl=" ++ Printer.pr_econstr (pf_concl gl))); + ppdebug(lazy Pp.(str"concl=" ++ Printer.pr_econstr_env (pf_env gl) (project gl) (pf_concl gl))); (* utils *) let fs gl t = Reductionops.nf_evar (project gl) t in let tclMATCH_GOAL (c, gl_c) proj t_ok t_fail gl = @@ -247,7 +247,7 @@ let unfoldintac occ rdx t (kt,_) gl = try find_T env c h ~k:(fun env c _ _ -> EConstr.Unsafe.to_constr (body env t (EConstr.of_constr c))) with NoMatch when easy -> c | NoMatch | NoProgress -> errorstrm Pp.(str"No occurrence of " - ++ pr_constr_pat (EConstr.Unsafe.to_constr t) ++ spc() ++ str "in " ++ Printer.pr_constr c)), + ++ pr_constr_pat (EConstr.Unsafe.to_constr t) ++ spc() ++ str "in " ++ Printer.pr_constr_env env sigma c)), (fun () -> try end_T () with | NoMatch when easy -> fake_pmatcher_end () | NoMatch -> anomaly "unfoldintac") @@ -267,13 +267,13 @@ let unfoldintac occ rdx t (kt,_) gl = | Proj _ when same_proj sigma0 c t -> body env t c | Const f -> aux (body env c c) | App (f, a) -> aux (EConstr.mkApp (body env f f, a)) - | _ -> errorstrm Pp.(str "The term "++pr_constr orig_c++ - str" contains no " ++ pr_econstr t ++ str" even after unfolding") + | _ -> errorstrm Pp.(str "The term "++ pr_constr_env env sigma orig_c++ + str" contains no " ++ pr_econstr_env env sigma t ++ str" even after unfolding") in EConstr.Unsafe.to_constr @@ aux (EConstr.of_constr c) else try EConstr.Unsafe.to_constr @@ body env t (fs (unify_HO env sigma (EConstr.of_constr c) t) t) with _ -> errorstrm Pp.(str "The term " ++ - pr_constr c ++spc()++ str "does not unify with " ++ pr_constr_pat (EConstr.Unsafe.to_constr t))), + pr_constr_env env sigma c ++spc()++ str "does not unify with " ++ pr_constr_pat (EConstr.Unsafe.to_constr t))), fake_pmatcher_end in let concl = let concl0 = EConstr.Unsafe.to_constr concl0 in @@ -342,7 +342,7 @@ let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = let sort = elimination_sort_of_goal gl in let elim, gl = pf_fresh_global (Indrec.lookup_eliminator ind sort) gl in if dir = R2L then elim, gl else (* taken from Coq's rewrite *) - let elim, _ = Term.destConst elim in + let elim, _ = destConst elim in let mp,dp,l = Constant.repr3 (Constant.make1 (Constant.canonical elim)) in let l' = Label.of_id (Nameops.add_suffix (Label.to_id l) "_r") in let c1' = Global.constant_of_delta_kn (Constant.canonical (Constant.make3 mp dp l')) in @@ -352,7 +352,7 @@ let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = (* We check the proof is well typed *) let sigma, proof_ty = try Typing.type_of env sigma proof with _ -> raise PRtype_error in - ppdebug(lazy Pp.(str"pirrel_rewrite proof term of type: " ++ pr_econstr proof_ty)); + ppdebug(lazy Pp.(str"pirrel_rewrite proof term of type: " ++ pr_econstr_env env sigma proof_ty)); try refine_with ~first_goes_last:(not !ssroldreworder) ~with_evars:false (sigma, proof) gl with _ -> @@ -374,8 +374,8 @@ let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = if open_evs <> [] then Some name else None) (List.combine (Array.to_list args) names) | _ -> anomaly "rewrite rule not an application" in - errorstrm Pp.(Himsg.explain_refiner_error (Logic.UnresolvedBindings miss)++ - (Pp.fnl()++str"Rule's type:" ++ spc() ++ pr_econstr hd_ty)) + errorstrm Pp.(Himsg.explain_refiner_error env sigma (Logic.UnresolvedBindings miss)++ + (Pp.fnl()++str"Rule's type:" ++ spc() ++ pr_econstr_env env sigma hd_ty)) ;; let is_construct_ref sigma c r = @@ -391,12 +391,12 @@ let rwcltac cl rdx dir sr gl = let gl = pf_unsafe_merge_uc ucst gl in let rdxt = Retyping.get_type_of (pf_env gl) (fst sr) rdx in (* ppdebug(lazy(str"sigma@rwcltac=" ++ pr_evar_map None (fst sr))); *) - ppdebug(lazy Pp.(str"r@rwcltac=" ++ pr_econstr (snd sr))); + ppdebug(lazy Pp.(str"r@rwcltac=" ++ pr_econstr_env (pf_env gl) (project gl) (snd sr))); let cvtac, rwtac, gl = if EConstr.Vars.closed0 (project gl) r' then let env, sigma, c, c_eq = pf_env gl, fst sr, snd sr, Coqlib.build_coq_eq () in let sigma, c_ty = Typing.type_of env sigma c in - ppdebug(lazy Pp.(str"c_ty@rwcltac=" ++ pr_econstr c_ty)); + ppdebug(lazy Pp.(str"c_ty@rwcltac=" ++ pr_econstr_env env sigma c_ty)); match EConstr.kind_of_type sigma (Reductionops.whd_all env sigma c_ty) with | AtomicType(e, a) when is_ind_ref sigma e c_eq -> let new_rdx = if dir = L2R then a.(2) else a.(1) in @@ -411,7 +411,7 @@ let rwcltac cl rdx dir sr gl = let r3, _, r3t = try EConstr.destCast (project gl) r2 with _ -> errorstrm Pp.(str "no cast from " ++ pr_constr_pat (EConstr.Unsafe.to_constr (snd sr)) - ++ str " to " ++ pr_econstr r2) in + ++ str " to " ++ pr_econstr_env (pf_env gl) (project gl) r2) in let cl' = EConstr.mkNamedProd rule_id (EConstr.it_mkProd_or_LetIn r3t dc) (EConstr.Vars.lift 1 cl) in let cl'' = EConstr.mkNamedProd pattern_id rdxt cl' in let itacs = [introid pattern_id; introid rule_id] in @@ -605,7 +605,7 @@ let ssrinstancesofrule ist dir arg gl = sigma, pats @ [pat] in let rpats = List.fold_left (rpat env0 sigma0) (r_sigma,[]) rules in mk_tpattern_matcher ~all_instances:true ~raise_NoMatch:true sigma0 None ~upats_origin rpats in - let print env p c _ = Feedback.msg_info Pp.(hov 1 (str"instance:" ++ spc() ++ pr_constr p ++ spc() ++ str "matches:" ++ spc() ++ pr_constr c)); c in + let print env p c _ = Feedback.msg_info Pp.(hov 1 (str"instance:" ++ spc() ++ pr_constr_env env r_sigma p ++ spc() ++ str "matches:" ++ spc() ++ pr_constr_env env r_sigma c)); c in Feedback.msg_info Pp.(str"BEGIN INSTANCES"); try while true do diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml index 29e96ec59f..5c1b399a80 100644 --- a/plugins/ssr/ssrfwd.ml +++ b/plugins/ssr/ssrfwd.ml @@ -8,11 +8,12 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) +open Pp open Names +open Constr open Tacmach open Ssrmatching_plugin.Ssrmatching - open Ssrprinters open Ssrcommon open Ssrtacticals @@ -30,10 +31,6 @@ let ssrposetac ist (id, (_, t)) gl = let sigma, t, ucst, _ = pf_abs_ssrterm ist gl t in posetac id t (pf_merge_uc ucst gl) -open Pp -open Term -open Constr - let ssrsettac ist id ((_, (pat, pty)), (_, occ)) gl = let pat = interp_cpattern ist gl pat (Option.map snd pty) in let cl, sigma, env = pf_concl gl, project gl, pf_env gl in @@ -72,13 +69,14 @@ let examine_abstract id gl = let gl, tid = pfe_type_of gl id in let abstract, gl = pf_mkSsrConst "abstract" gl in let sigma = project gl in + let env = pf_env gl in if not (EConstr.isApp sigma tid) || not (EConstr.eq_constr sigma (fst(EConstr.destApp sigma tid)) abstract) then - errorstrm(strbrk"not an abstract constant: "++pr_econstr id); + errorstrm(strbrk"not an abstract constant: "++ pr_econstr_env env sigma id); let _, args_id = EConstr.destApp sigma tid in if Array.length args_id <> 3 then - errorstrm(strbrk"not a proper abstract constant: "++pr_econstr id); + errorstrm(strbrk"not a proper abstract constant: "++ pr_econstr_env env sigma id); if not (is_Evar_or_CastedMeta sigma args_id.(2)) then - errorstrm(strbrk"abstract constant "++pr_econstr id++str" already used"); + errorstrm(strbrk"abstract constant "++ pr_econstr_env env sigma id++str" already used"); tid, args_id let pf_find_abstract_proof check_lock gl abstract_n = @@ -94,7 +92,7 @@ let pf_find_abstract_proof check_lock gl abstract_n = | _ -> l) (project gl) [] in match l with | [e] -> e - | _ -> errorstrm(strbrk"abstract constant "++pr_constr abstract_n++ + | _ -> errorstrm(strbrk"abstract constant "++ pr_constr_env (pf_env gl) (project gl) abstract_n ++ strbrk" not found in the evar map exactly once. "++ strbrk"Did you tamper with it?") @@ -205,7 +203,7 @@ let havetac ist let assert_is_conv gl = try Proofview.V82.of_tactic (convert_concl (EConstr.it_mkProd_or_LetIn concl ctx)) gl with _ -> errorstrm (str "Given proof term is not of type " ++ - pr_econstr (EConstr.mkArrow (EConstr.mkVar (Id.of_string "_")) concl)) in + pr_econstr_env (pf_env gl) (project gl) (EConstr.mkArrow (EConstr.mkVar (Id.of_string "_")) concl)) in gl, ty, Tacticals.tclTHEN assert_is_conv (Proofview.V82.of_tactic (Tactics.apply t)), id, itac_c | FwdHave, false, false -> let skols = List.flatten (List.map (function @@ -271,7 +269,7 @@ let ssrabstract ist gens (*last*) gl = let gl, proof = let pf_unify_HO gl a b = try pf_unify_HO gl a b - with _ -> errorstrm(strbrk"The abstract variable "++pr_econstr id++ + with _ -> errorstrm(strbrk"The abstract variable "++ pr_econstr_env env (project gl) id++ strbrk" cannot abstract this goal. Did you generalize it?") in let find_hole p t = match EConstr.kind (project gl) t with @@ -290,7 +288,7 @@ let ssrabstract ist gens (*last*) gl = | App(hd, [|left; right|]) when Term.Constr.equal hd prod -> find_hole (mkApp (proj1,[|left;right;p|])) left *) - | _ -> errorstrm(strbrk"abstract constant "++pr_econstr abstract_n++ + | _ -> errorstrm(strbrk"abstract constant "++ pr_econstr_env env (project gl) abstract_n++ strbrk" has an unexpected shape. Did you tamper with it?") in find_hole @@ -361,14 +359,14 @@ let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave gl = | Sort _, [] -> EConstr.Vars.subst_vars s ct | LetIn(Name id as n,b,ty,c), _::g -> EConstr.mkLetIn (n,b,ty,var2rel c g (id::s)) | Prod(Name id as n,ty,c), _::g -> EConstr.mkProd (n,ty,var2rel c g (id::s)) - | _ -> CErrors.anomaly(str"SSR: wlog: var2rel: " ++ pr_econstr c) in + | _ -> CErrors.anomaly(str"SSR: wlog: var2rel: " ++ pr_econstr_env env sigma c) in let c = var2rel c gens [] in let rec pired c = function | [] -> c | t::ts as args -> match EConstr.kind sigma c with | Prod(_,_,c) -> pired (EConstr.Vars.subst1 t c) ts | LetIn(id,b,ty,c) -> EConstr.mkLetIn (id,b,ty,pired c args) - | _ -> CErrors.anomaly(str"SSR: wlog: pired: " ++ pr_econstr c) in + | _ -> CErrors.anomaly(str"SSR: wlog: pired: " ++ pr_econstr_env env sigma c) in c, args, pired c args, pf_merge_uc uc gl in let tacipat pats = introstac ~ist pats in let tacigens = @@ -396,8 +394,8 @@ let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave gl = | Some id -> if pats = [] then Tacticals.tclIDTAC else let args = Array.of_list args in - ppdebug(lazy(str"specialized="++pr_econstr EConstr.(mkApp (mkVar id,args)))); - ppdebug(lazy(str"specialized_ty="++pr_econstr ct)); + ppdebug(lazy(str"specialized="++ pr_econstr_env (pf_env gl) (project gl) EConstr.(mkApp (mkVar id,args)))); + ppdebug(lazy(str"specialized_ty="++ pr_econstr_env (pf_env gl) (project gl) ct)); Tacticals.tclTHENS (basecuttac "ssr_have" ct) [Proofview.V82.of_tactic (Tactics.apply EConstr.(mkApp (mkVar id,args))); Tacticals.tclIDTAC] in "ssr_have", diff --git a/plugins/ssr/ssripats.ml b/plugins/ssr/ssripats.ml index 023778fdbf..6c325cce43 100644 --- a/plugins/ssr/ssripats.ml +++ b/plugins/ssr/ssripats.ml @@ -272,7 +272,7 @@ let (introstac : ?ist:Tacinterp.interp_sign -> ssripats -> Tacmach.tactic), let elim_intro_tac ipats ?ist what eqid ssrelim is_rec clr gl = (* Utils of local interest only *) let iD s ?t gl = let t = match t with None -> pf_concl gl | Some x -> x in - ppdebug(lazy Pp.(str s ++ pr_econstr t)); Tacticals.tclIDTAC gl in + ppdebug(lazy Pp.(str s ++ pr_econstr_env (pf_env gl) (project gl) t)); Tacticals.tclIDTAC gl in let protectC, gl = pf_mkSsrConst "protect_term" gl in let eq, gl = pf_fresh_global (Coqlib.build_coq_eq ()) gl in let eq = EConstr.of_constr eq in diff --git a/plugins/ssr/ssrparser.ml4 b/plugins/ssr/ssrparser.ml4 index 7b591feada..46403aef3c 100644 --- a/plugins/ssr/ssrparser.ml4 +++ b/plugins/ssr/ssrparser.ml4 @@ -1131,7 +1131,7 @@ let pr_fwd_guarded prval prval' = function | (fk, h), (_, (_, Some c)) -> pr_gen_fwd prval pr_constr_expr prl_constr_expr fk (format_constr_expr h c) | (fk, h), (_, (c, None)) -> - pr_gen_fwd prval' pr_glob_constr prl_glob_constr fk (format_glob_constr h c) + pr_gen_fwd prval' pr_glob_constr_env prl_glob_constr fk (format_glob_constr h c) let pr_unguarded prc prlc = prlc diff --git a/plugins/ssr/ssrprinters.ml b/plugins/ssr/ssrprinters.ml index e865ef706d..4b2fab6d19 100644 --- a/plugins/ssr/ssrprinters.ml +++ b/plugins/ssr/ssrprinters.ml @@ -24,7 +24,7 @@ let pp_concat hd ?(sep=str", ") = function [] -> hd | x :: xs -> hd ++ List.fold_left (fun acc x -> acc ++ sep ++ x) x xs let pp_term gl t = - let t = Reductionops.nf_evar (project gl) t in pr_econstr t + let t = Reductionops.nf_evar (project gl) t in pr_econstr_env (pf_env gl) (project gl) t (* FIXME *) (* terms are pre constr, the kind is parsing/printing flag to distinguish diff --git a/plugins/ssr/ssrvernac.ml4 b/plugins/ssr/ssrvernac.ml4 index 36dce37aea..3efb7b9147 100644 --- a/plugins/ssr/ssrvernac.ml4 +++ b/plugins/ssr/ssrvernac.ml4 @@ -158,11 +158,14 @@ let declare_one_prenex_implicit locality f = | impls -> Impargs.declare_manual_implicits locality fref ~enriching:false [impls] -VERNAC COMMAND EXTEND Ssrpreneximplicits CLASSIFIED AS SIDEFF +VERNAC COMMAND FUNCTIONAL EXTEND Ssrpreneximplicits CLASSIFIED AS SIDEFF | [ "Prenex" "Implicits" ne_global_list(fl) ] - -> [ let locality = - Locality.make_section_locality (Locality.LocalityFixme.consume ()) in - List.iter (declare_one_prenex_implicit locality) fl ] + -> [ fun ~atts ~st -> + let open Vernacinterp in + let locality = Locality.make_section_locality atts.locality in + List.iter (declare_one_prenex_implicit locality) fl; + st + ] END (* Vernac grammar visibility patch *) @@ -343,7 +346,7 @@ let coerce_search_pattern_to_sort hpat = let hpat' = if np = na then hpat else mkPApp hpat (np - na) [||] in let warn () = Feedback.msg_warning (str "Listing only lemmas with conclusion matching " ++ - pr_constr_pattern hpat') in + pr_constr_pattern_env env sigma hpat') in if EConstr.isSort sigma ht then begin warn (); true, hpat' end else let filter_head, coe_path = try @@ -359,7 +362,7 @@ let coerce_search_pattern_to_sort hpat = let n_imps = Option.get (Classops.hide_coercion coe_ref) in mkPApp (Pattern.PRef coe_ref) n_imps [|hp|] with _ -> - errorstrm (str "need explicit coercion " ++ pr_constr coe ++ spc () + errorstrm (str "need explicit coercion " ++ pr_constr_env env sigma coe ++ spc () ++ str "to interpret head search pattern as type") in filter_head, List.fold_left coerce hpat' coe_path @@ -468,10 +471,12 @@ let pr_raw_ssrhintref prc _ _ = let open CAst in function prc c ++ str "|" ++ int (List.length args) | c -> prc c -let pr_rawhintref c = match DAst.get c with +let pr_rawhintref c = + let _, env = Pfedit.get_current_context () in + match DAst.get c with | GApp (f, args) when isRHoles args -> - pr_glob_constr f ++ str "|" ++ int (List.length args) - | _ -> pr_glob_constr c + pr_glob_constr_env env f ++ str "|" ++ int (List.length args) + | _ -> pr_glob_constr_env env c let pr_glob_ssrhintref _ _ _ (c, _) = pr_rawhintref c @@ -546,9 +551,9 @@ GEXTEND Gram | IDENT "Canonical"; qid = Constr.global; d = G_vernac.def_body -> let s = coerce_reference_to_id qid in - Vernacexpr.VernacDefinition - ((Some Decl_kinds.Global,Decl_kinds.CanonicalStructure), - ((Loc.tag s),None),(d )) + Vernacexpr.VernacLocal(false,Vernacexpr.VernacDefinition + ((Decl_kinds.NoDischarge,Decl_kinds.CanonicalStructure), + ((Loc.tag s),None),(d ))) ]]; END diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index d5c9e4988e..e63a05b781 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -100,7 +100,6 @@ let pr_guarded guard prc c = let s = Pp.string_of_ppcmds (prc c) ^ "$" in if guard s (skip_wschars s 0) then pr_paren prc c else prc c (* More sensible names for constr printers *) -let pr_constr = pr_constr let prl_glob_constr c = pr_lglob_constr_env (Global.env ()) c let pr_glob_constr c = pr_glob_constr_env (Global.env ()) c let prl_constr_expr = pr_lconstr_expr @@ -397,7 +396,7 @@ let inv_dir = function L2R -> R2L | R2L -> L2R type pattern_class = | KpatFixed | KpatConst - | KpatEvar of existential_key + | KpatEvar of Evar.t | KpatLet | KpatLam | KpatRigid @@ -427,7 +426,8 @@ let hole_var = mkVar (Id.of_string "_") let pr_constr_pat c0 = let rec wipe_evar c = if isEvar c then hole_var else map wipe_evar c in - pr_constr (wipe_evar c0) + let sigma, env = Pfedit.get_current_context () in + pr_constr_env env sigma (wipe_evar c0) (* Turn (new) evars into metas *) let evars_for_FO ~hack env sigma0 (ise0:evar_map) c0 = @@ -1215,7 +1215,7 @@ let eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst = let pop_evar sigma e p = let { Evd.evar_body = e_body } as e_def = Evd.find sigma e in let e_body = match e_body with Evar_defined c -> c - | _ -> errorstrm (str "Matching the pattern " ++ pr_constr p ++ + | _ -> errorstrm (str "Matching the pattern " ++ pr_constr_env env0 sigma0 p ++ str " did not instantiate ?" ++ int (Evar.repr e) ++ spc () ++ str "Does the variable bound by the \"in\" construct occur "++ str "in the pattern?") in @@ -1417,7 +1417,8 @@ let ssrinstancesof ist arg gl = let find, conclude = mk_tpattern_matcher ~all_instances:true ~raise_NoMatch:true sigma None (etpat,[tpat]) in - let print env p c _ = ppnl (hov 1 (str"instance:" ++ spc() ++ pr_constr p ++ spc() ++ str "matches:" ++ spc() ++ pr_constr c)); c in + let print env p c _ = ppnl (hov 1 (str"instance:" ++ spc() ++ pr_constr_env (pf_env gl) (gl.sigma) p ++ spc() + ++ str "matches:" ++ spc() ++ pr_constr_env (pf_env gl) (gl.sigma) c)); c in ppnl (str"BEGIN INSTANCES"); try while true do diff --git a/pretyping/cases.mli b/pretyping/cases.mli index 3a139b7b03..43dbc31058 100644 --- a/pretyping/cases.mli +++ b/pretyping/cases.mli @@ -13,8 +13,8 @@ open Environ open EConstr open Inductiveops open Glob_term -open Evarutil open Ltac_pretype +open Evardefine (** {5 Compilation of pattern-matching } *) @@ -116,7 +116,7 @@ type 'a pattern_matching_problem = val compile : 'a pattern_matching_problem -> unsafe_judgment val prepare_predicate : ?loc:Loc.t -> - (Evarutil.type_constraint -> + (type_constraint -> Environ.env -> Evd.evar_map ref -> ltac_var_map -> glob_constr -> unsafe_judgment) -> Environ.env -> Evd.evar_map -> diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index 3a2eac7e79..192eca63bb 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -45,7 +45,7 @@ type cbv_value = | LAM of int * (Name.t * constr) list * constr * cbv_value subs | FIXP of fixpoint * cbv_value subs * cbv_value array | COFIXP of cofixpoint * cbv_value subs * cbv_value array - | CONSTR of constructor puniverses * cbv_value array + | CONSTR of constructor Univ.puniverses * cbv_value array (* type of terms with a hole. This hole can appear only under App or Case. * TOP means the term is considered without context @@ -208,25 +208,32 @@ and reify_value = function (* reduction under binders *) | STACK (n,v,stk) -> lift n (reify_stack (reify_value v) stk) | CBN(t,env) -> - t - (* map_constr_with_binders subs_lift (cbv_norm_term) env t *) - | LAM (n,ctxt,b,env) -> - List.fold_left (fun c (n,t) -> mkLambda (n, t, c)) b ctxt + apply_env env t + | LAM (k,ctxt,b,env) -> + apply_env env @@ + List.fold_left (fun c (n,t) -> + mkLambda (n, t, c)) b ctxt | FIXP ((lij,(names,lty,bds)),env,args) -> - mkApp - (mkFix (lij, - (names, - lty, - bds)), - Array.map reify_value args) + let fix = mkFix (lij, (names, lty, bds)) in + mkApp (apply_env env fix, Array.map reify_value args) | COFIXP ((j,(names,lty,bds)),env,args) -> - mkApp - (mkCoFix (j, - (names,lty,bds)), - Array.map reify_value args) + let cofix = mkCoFix (j, (names,lty,bds)) in + mkApp (apply_env env cofix, Array.map reify_value args) | CONSTR (c,args) -> mkApp(mkConstructU c, Array.map reify_value args) +and apply_env env t = + match kind t with + | Rel i -> + begin match expand_rel i env with + | Inl (k, v) -> + reify_value (shift_value k v) + | Inr (k,_) -> + mkRel k + end + | _ -> + map_with_binders subs_lift apply_env env t + (* The main recursive functions * * Go under applications and cases/projections (pushed in the stack), @@ -290,7 +297,10 @@ let rec norm_head info env t stack = | Evar ev -> (match evar_value info.infos.i_cache ev with Some c -> norm_head info env c stack - | None -> (VAL(0, t), stack)) + | None -> + let e, xs = ev in + let xs' = Array.map (apply_env env) xs in + (VAL(0, mkEvar (e,xs')), stack)) (* non-neutral cases *) | Lambda _ -> diff --git a/pretyping/cbv.mli b/pretyping/cbv.mli index 5f9609a5c5..1d4c88ea22 100644 --- a/pretyping/cbv.mli +++ b/pretyping/cbv.mli @@ -33,7 +33,7 @@ type cbv_value = | LAM of int * (Name.t * constr) list * constr * cbv_value subs | FIXP of fixpoint * cbv_value subs * cbv_value array | COFIXP of cofixpoint * cbv_value subs * cbv_value array - | CONSTR of constructor puniverses * cbv_value array + | CONSTR of constructor Univ.puniverses * cbv_value array and cbv_stack = | TOP diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index 3a91798138..478ba73fd5 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -13,7 +13,6 @@ open Util open Names open Globnames open Termops -open Reductionops open Term open EConstr open Vars @@ -207,7 +206,7 @@ let merge_binding sigma allow_bound_rels ctx n cT subst = in constrain sigma n c subst -let matches_core env sigma convert allow_partial_app allow_bound_rels +let matches_core env sigma allow_partial_app allow_bound_rels (binding_vars,pat) c = let open EConstr in let convref ref c = @@ -216,11 +215,7 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels | ConstRef c, Const (c',_) -> Constant.equal c c' | IndRef i, Ind (i', _) -> Names.eq_ind i i' | ConstructRef c, Construct (c',u) -> Names.eq_constructor c c' - | _, _ -> - (if convert then - let sigma,c' = Evd.fresh_global env sigma ref in - is_conv env sigma (EConstr.of_constr c') c - else false) + | _, _ -> false in let rec sorec ctx env subst p t = let cT = strip_outer_cast sigma t in @@ -371,19 +366,21 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels | PCoFix c1, CoFix _ when eq_constr sigma (mkCoFix (to_fix c1)) cT -> subst | PEvar (c1,args1), Evar (c2,args2) when Evar.equal c1 c2 -> Array.fold_left2 (sorec ctx env) subst args1 args2 - | _ -> raise PatternMatchingFailure + | (PRef _ | PVar _ | PRel _ | PApp _ | PProj _ | PLambda _ + | PProd _ | PLetIn _ | PSort _ | PIf _ | PCase _ + | PFix _ | PCoFix _| PEvar _), _ -> raise PatternMatchingFailure in sorec [] env (Id.Map.empty, Id.Map.empty) pat c -let matches_core_closed env sigma convert allow_partial_app pat c = - let names, subst = matches_core env sigma convert allow_partial_app false pat c in +let matches_core_closed env sigma allow_partial_app pat c = + let names, subst = matches_core env sigma allow_partial_app false pat c in (names, Id.Map.map snd subst) -let extended_matches env sigma = matches_core env sigma false true true +let extended_matches env sigma = matches_core env sigma true true let matches env sigma pat c = - snd (matches_core_closed env sigma false true (Id.Set.empty,pat) c) + snd (matches_core_closed env sigma true (Id.Set.empty,pat) c) let special_meta = (-1) @@ -410,7 +407,7 @@ let matches_head env sigma pat c = (* Tells if it is an authorized occurrence and if the instance is closed *) let authorized_occ env sigma partial_app closed pat c mk_ctx = try - let subst = matches_core_closed env sigma false partial_app pat c in + let subst = matches_core_closed env sigma partial_app pat c in if closed && Id.Map.exists (fun _ c -> not (closed0 sigma c)) (snd subst) then (fun next -> next ()) else (fun next -> mkresult subst (mk_ctx (mkMeta special_meta)) next) @@ -550,10 +547,3 @@ let is_matching_appsubterm ?(closed=true) env sigma pat c = let pat = (Id.Set.empty,pat) in let results = sub_match ~partial_app:true ~closed env sigma pat c in not (IStream.is_empty results) - -let matches_conv env sigma p c = - snd (matches_core_closed env sigma true false (Id.Set.empty,p) c) - -let is_matching_conv env sigma pat n = - try let _ = matches_conv env sigma pat n in true - with PatternMatchingFailure -> false diff --git a/pretyping/constr_matching.mli b/pretyping/constr_matching.mli index 780ccc23d1..60e1c34a15 100644 --- a/pretyping/constr_matching.mli +++ b/pretyping/constr_matching.mli @@ -55,12 +55,6 @@ val is_matching : env -> Evd.evar_map -> constr_pattern -> constr -> bool prefix of it matches against [pat] *) val is_matching_head : env -> Evd.evar_map -> constr_pattern -> constr -> bool -(** [matches_conv env sigma] matches up to conversion in environment - [(env,sigma)] when constants in pattern are concerned; it raises - [PatternMatchingFailure] if not matchable; bindings are given in - increasing order based on the numbers given in the pattern *) -val matches_conv : env -> Evd.evar_map -> constr_pattern -> constr -> patvar_map - (** The type of subterm matching results: a substitution + a context (whose hole is denoted here with [special_meta]) *) type matching_result = @@ -85,8 +79,3 @@ val match_subterm_gen : env -> Evd.evar_map -> (** [is_matching_appsubterm pat c] tells if a subterm of [c] matches against [pat] taking partial subterms into consideration *) val is_matching_appsubterm : ?closed:bool -> env -> Evd.evar_map -> constr_pattern -> constr -> bool - -(** [is_matching_conv env sigma pat c] tells if [c] matches against [pat] - up to conversion for constants in patterns *) -val is_matching_conv : - env -> Evd.evar_map -> constr_pattern -> constr -> bool diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 0d1e401d98..6527ba9355 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -414,15 +414,17 @@ let detype_case computable detype detype_eqns testdep avoid data p c bl = let eqnl = detype_eqns constructs constagsl bl in GCases (tag,pred,[tomatch,(alias,aliastyp)],eqnl) +let detype_universe sigma u = + let fn (l, n) = Some (Termops.reference_of_level sigma l, n) in + Univ.Universe.map fn u + let detype_sort sigma = function | Prop Null -> GProp | Prop Pos -> GSet | Type u -> GType (if !print_universes - then - let u = Pp.string_of_ppcmds (Univ.Universe.pr_with (Termops.pr_evd_level sigma) u) in - [Loc.tag @@ Name.mk_name (Id.of_string_soft u)] + then detype_universe sigma u else []) type binder_kind = BProd | BLambda | BLetIn @@ -434,8 +436,8 @@ let detype_anonymous = ref (fun ?loc n -> anomaly ~label:"detype" (Pp.str "index let set_detype_anonymous f = detype_anonymous := f let detype_level sigma l = - let l = Pp.string_of_ppcmds (Termops.pr_evd_level sigma l) in - GType (Some (Loc.tag @@ Name.mk_name (Id.of_string_soft l))) + let l = Termops.reference_of_level sigma l in + GType (UNamed l) let detype_instance sigma l = let l = EInstance.kind sigma l in diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 681eb17d3c..e5776d2eca 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -9,7 +9,6 @@ open CErrors open Util open Names -open Term open Constr open Termops open Environ @@ -49,7 +48,7 @@ let _ = Goptions.declare_bool_option { "data.id.type" etc... *) let impossible_default_case () = let c, ctx = Universes.fresh_global_instance (Global.env()) (Globnames.ConstRef Coqlib.id) in - let (_, u) = Term.destConst c in + let (_, u) = Constr.destConst c in Some (c, Constr.mkConstU (Coqlib.type_of_id, u), ctx) let coq_unit_judge = @@ -311,8 +310,6 @@ let ise_stack2 no_app env evd f sk1 sk2 = | Success i' -> ise_stack2 true i' q1 q2 | UnifFailure _ as x -> fail x else fail (UnifFailure (i,NotSameHead)) - | Stack.Update _ :: _, _ | Stack.Shift _ :: _, _ - | _, Stack.Update _ :: _ | _, Stack.Shift _ :: _ -> assert false | Stack.App _ :: _, Stack.App _ :: _ -> if no_app && deep then fail ((*dummy*)UnifFailure(i,NotSameHead)) else begin match ise_app_stack2 env f i sk1 sk2 with @@ -345,8 +342,6 @@ let exact_ise_stack2 env evd f sk1 sk2 = if Constant.equal (Projection.constant p1) (Projection.constant p2) then ise_stack2 i q1 q2 else (UnifFailure (i, NotSameHead)) - | Stack.Update _ :: _, _ | Stack.Shift _ :: _, _ - | _, Stack.Update _ :: _ | _, Stack.Shift _ :: _ -> assert false | Stack.App _ :: _, Stack.App _ :: _ -> begin match ise_app_stack2 env f i sk1 sk2 with |_,(UnifFailure _ as x) -> x @@ -458,7 +453,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty let out1 = whd_betaiota_deltazeta_for_iota_state (fst ts) env' evd Cst_stack.empty (c'1, Stack.empty) in let out2 = whd_nored_state evd - (Stack.zip evd (term', sk' @ [Stack.Shift 1]), Stack.append_app [|EConstr.mkRel 1|] Stack.empty), + (lift 1 (Stack.zip evd (term', sk')), Stack.append_app [|EConstr.mkRel 1|] Stack.empty), Cst_stack.empty in if onleft then evar_eqappr_x ts env' evd CONV out1 out2 else evar_eqappr_x ts env' evd CONV out2 out1 diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml index 18dbbea1bd..b646a37f8a 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -6,10 +6,10 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Sorts open Util open Pp open Names -open Term open Constr open Termops open EConstr diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index fba1542912..e6d1e59b3a 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -6,10 +6,10 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Sorts open Util open CErrors open Names -open Term open Constr open Environ open Termops diff --git a/pretyping/evarsolve.mli b/pretyping/evarsolve.mli index e5d288b5c3..703c4616c7 100644 --- a/pretyping/evarsolve.mli +++ b/pretyping/evarsolve.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Constr open EConstr open Evd open Environ @@ -49,7 +48,7 @@ val refresh_universes : env -> evar_map -> types -> evar_map * types val solve_refl : ?can_drop:bool -> conv_fun_bool -> env -> evar_map -> - bool option -> existential_key -> constr array -> constr array -> evar_map + bool option -> Evar.t -> constr array -> constr array -> evar_map val solve_evar_evar : ?force:bool -> (env -> evar_map -> bool option -> existential -> constr -> evar_map) -> @@ -78,10 +77,10 @@ exception IllTypedInstance of env * types * types (* May raise IllTypedInstance if types are not convertible *) val check_evar_instance : - evar_map -> existential_key -> constr -> conv_fun -> evar_map + evar_map -> Evar.t -> constr -> conv_fun -> evar_map val remove_instance_local_defs : - evar_map -> existential_key -> 'a array -> 'a list + evar_map -> Evar.t -> 'a array -> 'a list val get_type_of_refresh : ?polyprop:bool -> ?lax:bool -> env -> evar_map -> constr -> evar_map * types diff --git a/engine/geninterp.ml b/pretyping/geninterp.ml index 768ef3cfd9..768ef3cfd9 100644 --- a/engine/geninterp.ml +++ b/pretyping/geninterp.ml diff --git a/engine/geninterp.mli b/pretyping/geninterp.mli index ae0b26e594..ae0b26e594 100644 --- a/engine/geninterp.mli +++ b/pretyping/geninterp.mli diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index febe99b0bc..58b1ce6c3f 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -28,8 +28,8 @@ val arities_of_constructors : env -> pinductive -> types array reasoning either with only recursively uniform parameters or with all parameters including the recursively non-uniform ones *) type inductive_family -val make_ind_family : inductive puniverses * constr list -> inductive_family -val dest_ind_family : inductive_family -> inductive puniverses * constr list +val make_ind_family : inductive Univ.puniverses * constr list -> inductive_family +val dest_ind_family : inductive_family -> inductive Univ.puniverses * constr list val map_ind_family : (constr -> constr) -> inductive_family -> inductive_family val liftn_inductive_family : int -> int -> inductive_family -> inductive_family val lift_inductive_family : int -> inductive_family -> inductive_family @@ -195,7 +195,7 @@ i*) (********************) val type_of_inductive_knowing_conclusion : - env -> evar_map -> Inductive.mind_specif puniverses -> EConstr.types -> evar_map * EConstr.types + env -> evar_map -> Inductive.mind_specif Univ.puniverses -> EConstr.types -> evar_map * EConstr.types (********************) val control_only_guard : env -> types -> unit diff --git a/pretyping/miscops.ml b/pretyping/miscops.ml index bc563b46dc..f0cb8fd1f2 100644 --- a/pretyping/miscops.ml +++ b/pretyping/miscops.ml @@ -30,7 +30,8 @@ let smartmap_cast_type f c = let glob_sort_eq g1 g2 = match g1, g2 with | GProp, GProp -> true | GSet, GSet -> true -| GType l1, GType l2 -> List.equal (fun x y -> Names.Name.equal (snd x) (snd y)) l1 l2 +| GType l1, GType l2 -> + List.equal (Option.equal (fun (x,m) (y,n) -> Libnames.eq_reference x y && Int.equal m n)) l1 l2 | _ -> false let intro_pattern_naming_eq nam1 nam2 = match nam1, nam2 with diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index 4d8c09c50a..41e09004c6 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -59,7 +59,11 @@ let rec constr_pattern_eq p1 p2 = match p1, p2 with fixpoint_eq f1 f2 | PCoFix f1, PCoFix f2 -> cofixpoint_eq f1 f2 -| _ -> false +| PProj (p1, t1), PProj (p2, t2) -> + Projection.equal p1 p2 && constr_pattern_eq t1 t2 +| (PRef _ | PVar _ | PEvar _ | PRel _ | PApp _ | PSoApp _ + | PLambda _ | PProd _ | PLetIn _ | PSort _ | PMeta _ + | PIf _ | PCase _ | PFix _ | PCoFix _ | PProj _), _ -> false (** FIXME: fixpoint and cofixpoint should be relativized to pattern *) and pattern_eq (i1, j1, p1) (i2, j2, p2) = @@ -442,8 +446,8 @@ let rec pat_of_raw metas vars = DAst.with_loc_val (fun ?loc -> function one non-trivial branch. These facts are used in [Constrextern]. *) PCase (info, pred, pat_of_raw metas vars c, brs) - | r -> err ?loc (Pp.str "Non supported pattern.") - ) + | GPatVar _ | GIf _ | GLetTuple _ | GCases _ | GEvar _ | GRec _ -> + err ?loc (Pp.str "Non supported pattern.")) and pats_of_glob_branches loc metas vars ind brs = let get_arg p = match DAst.get p with diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml index ce478ac202..7149d62a19 100644 --- a/pretyping/pretype_errors.ml +++ b/pretyping/pretype_errors.ml @@ -7,20 +7,19 @@ (************************************************************************) open Names -open Constr open Environ open EConstr open Type_errors type unification_error = - | OccurCheck of existential_key * constr + | OccurCheck of Evar.t * constr | NotClean of existential * env * constr (* Constr is a variable not in scope *) | NotSameArgSize | NotSameHead | NoCanonicalStructure | ConversionFailed of env * constr * constr (* Non convertible closed terms *) - | MetaOccurInBody of existential_key - | InstanceNotSameType of existential_key * env * types * types + | MetaOccurInBody of Evar.t + | InstanceNotSameType of Evar.t * env * types * types | UnifUnivInconsistency of Univ.univ_inconsistency | CannotSolveConstraint of Evd.evar_constraint * unification_error | ProblemBeyondCapabilities @@ -39,8 +38,8 @@ type pretype_error = (* Type inference unification *) | ActualTypeNotCoercible of unsafe_judgment * types * unification_error (* Tactic unification *) - | UnifOccurCheck of existential_key * constr - | UnsolvableImplicit of existential_key * Evd.unsolvability_explanation option + | UnifOccurCheck of Evar.t * constr + | UnsolvableImplicit of Evar.t * Evd.unsolvability_explanation option | CannotUnify of constr * constr * unification_error option | CannotUnifyLocal of constr * constr * constr | CannotUnifyBindingType of constr * constr @@ -57,7 +56,7 @@ type pretype_error = | TypingError of type_error | CannotUnifyOccurrences of subterm_unification_error | UnsatisfiableConstraints of - (existential_key * Evar_kinds.t) option * Evar.Set.t option + (Evar.t * Evar_kinds.t) option * Evar.Set.t option exception PretypeError of env * Evd.evar_map * pretype_error diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli index dab376ef07..430755ea04 100644 --- a/pretyping/pretype_errors.mli +++ b/pretyping/pretype_errors.mli @@ -15,14 +15,14 @@ open Type_errors (** {6 The type of errors raised by the pretyper } *) type unification_error = - | OccurCheck of existential_key * constr + | OccurCheck of Evar.t * constr | NotClean of existential * env * constr | NotSameArgSize | NotSameHead | NoCanonicalStructure | ConversionFailed of env * constr * constr - | MetaOccurInBody of existential_key - | InstanceNotSameType of existential_key * env * types * types + | MetaOccurInBody of Evar.t + | InstanceNotSameType of Evar.t * env * types * types | UnifUnivInconsistency of Univ.univ_inconsistency | CannotSolveConstraint of Evd.evar_constraint * unification_error | ProblemBeyondCapabilities @@ -41,8 +41,8 @@ type pretype_error = (** Type inference unification *) | ActualTypeNotCoercible of unsafe_judgment * types * unification_error (** Tactic Unification *) - | UnifOccurCheck of existential_key * constr - | UnsolvableImplicit of existential_key * Evd.unsolvability_explanation option + | UnifOccurCheck of Evar.t * constr + | UnsolvableImplicit of Evar.t * Evd.unsolvability_explanation option | CannotUnify of constr * constr * unification_error option | CannotUnifyLocal of constr * constr * constr | CannotUnifyBindingType of constr * constr @@ -59,7 +59,7 @@ type pretype_error = | TypingError of type_error | CannotUnifyOccurrences of subterm_unification_error | UnsatisfiableConstraints of - (existential_key * Evar_kinds.t) option * Evar.Set.t option + (Evar.t * Evar_kinds.t) option * Evar.Set.t option (** unresolvable evar, connex component *) exception PretypeError of env * Evd.evar_map * pretype_error @@ -112,10 +112,10 @@ val error_cannot_coerce : env -> Evd.evar_map -> constr * constr -> 'b (** {6 Implicit arguments synthesis errors } *) -val error_occur_check : env -> Evd.evar_map -> existential_key -> constr -> 'b +val error_occur_check : env -> Evd.evar_map -> Evar.t -> constr -> 'b val error_unsolvable_implicit : - ?loc:Loc.t -> env -> Evd.evar_map -> existential_key -> + ?loc:Loc.t -> env -> Evd.evar_map -> Evar.t -> Evd.unsolvability_explanation option -> 'b val error_cannot_unify : ?loc:Loc.t -> env -> Evd.evar_map -> @@ -154,7 +154,7 @@ val error_var_not_found : ?loc:Loc.t -> Id.t -> 'b (** {6 Typeclass errors } *) -val unsatisfiable_constraints : env -> Evd.evar_map -> Evd.evar option -> +val unsatisfiable_constraints : env -> Evd.evar_map -> Evar.t option -> Evar.Set.t option -> 'a val unsatisfiable_exception : exn -> bool diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index e3470b0f11..b930c5db83 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -177,53 +177,79 @@ let _ = optwrite = (:=) Universes.set_minimization }) (** Miscellaneous interpretation functions *) -let interp_universe_level_name ~anon_rigidity evd (loc, s) = - match s with - | Anonymous -> - new_univ_level_variable ?loc anon_rigidity evd - | Name s -> - let s = Id.to_string s in - let names, _ = Global.global_universe_names () in - if CString.string_contains ~where:s ~what:"." then - match List.rev (CString.split '.' s) with - | [] -> anomaly (str"Invalid universe name " ++ str s ++ str".") - | n :: dp -> - let num = int_of_string n in - let dp = DirPath.make (List.map Id.of_string dp) in - let level = Univ.Level.make dp num in - let evd = - try Evd.add_global_univ evd level - with UGraph.AlreadyDeclared -> evd - in evd, level - else - try - let level = Evd.universe_of_name evd s in - evd, level - with Not_found -> - try - let id = try Id.of_string s with _ -> raise Not_found in - evd, snd (Id.Map.find id names) - with Not_found -> - if not (is_strict_universe_declarations ()) then - new_univ_level_variable ?loc ~name:s univ_rigid evd - else user_err ?loc ~hdr:"interp_universe_level_name" - (Pp.(str "Undeclared universe: " ++ str s)) + +let interp_known_universe_level evd r = + let loc, qid = Libnames.qualid_of_reference r in + try + match r with + | Libnames.Ident (loc, id) -> Evd.universe_of_name evd id + | Libnames.Qualid _ -> raise Not_found + with Not_found -> + let univ, k = Nametab.locate_universe qid in + Univ.Level.make univ k + +let interp_universe_level_name ~anon_rigidity evd r = + try evd, interp_known_universe_level evd r + with Not_found -> + match r with (* Qualified generated name *) + | Libnames.Qualid (loc, qid) -> + let dp, i = Libnames.repr_qualid qid in + let num = + try int_of_string (Id.to_string i) + with Failure _ -> + user_err ?loc ~hdr:"interp_universe_level_name" + (Pp.(str "Undeclared global universe: " ++ Libnames.pr_reference r)) + in + let level = Univ.Level.make dp num in + let evd = + try Evd.add_global_univ evd level + with UGraph.AlreadyDeclared -> evd + in evd, level + | Libnames.Ident (loc, id) -> (* Undeclared *) + if not (is_strict_universe_declarations ()) then + new_univ_level_variable ?loc ~name:id univ_rigid evd + else user_err ?loc ~hdr:"interp_universe_level_name" + (Pp.(str "Undeclared universe: " ++ Id.print id)) let interp_universe ?loc evd = function | [] -> let evd, l = new_univ_level_variable ?loc univ_rigid evd in evd, Univ.Universe.make l | l -> - List.fold_left (fun (evd, u) l -> - (* [univ_flexible_alg] can produce algebraic universes in terms *) - let evd', l = interp_universe_level_name ~anon_rigidity:univ_flexible evd l in - (evd', Univ.sup u (Univ.Universe.make l))) + List.fold_left (fun (evd, u) l -> + let evd', u' = + match l with + | Some (l,n) -> + (* [univ_flexible_alg] can produce algebraic universes in terms *) + let anon_rigidity = univ_flexible in + let evd', l = interp_universe_level_name ~anon_rigidity evd l in + let u' = Univ.Universe.make l in + (match n with + | 0 -> evd', u' + | 1 -> evd', Univ.Universe.super u' + | _ -> + user_err ?loc ~hdr:"interp_universe" + (Pp.(str "Cannot interpret universe increment +" ++ int n))) + | None -> + let evd, l = new_univ_level_variable ?loc univ_flexible evd in + evd, Univ.Universe.make l + in (evd', Univ.sup u u')) (evd, Univ.Universe.type0m) l +let interp_known_level_info ?loc evd = function + | UUnknown | UAnonymous -> + user_err ?loc ~hdr:"interp_known_level_info" + (str "Anonymous universes not allowed here.") + | UNamed ref -> + try interp_known_universe_level evd ref + with Not_found -> + user_err ?loc ~hdr:"interp_known_level_info" (str "Undeclared universe " ++ Libnames.pr_reference ref) + 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) + | UUnknown -> new_univ_level_variable ?loc univ_rigid evd + | UAnonymous -> new_univ_level_variable ?loc univ_flexible evd + | UNamed s -> interp_universe_level_name ~anon_rigidity:univ_flexible evd s -type inference_hook = env -> evar_map -> evar -> evar_map * constr +type inference_hook = env -> evar_map -> Evar.t -> evar_map * constr type inference_flags = { use_typeclasses : bool; @@ -467,6 +493,11 @@ let pretype_id pretype k0 loc env evdref lvar id = (*************************************************************************) (* Main pretyping function *) +let interp_known_glob_level ?loc evd = function + | GProp -> Univ.Level.prop + | GSet -> Univ.Level.set + | GType s -> interp_known_level_info ?loc evd s + let interp_glob_level ?loc evd : Misctypes.glob_level -> _ = function | GProp -> evd, Univ.Level.prop | GSet -> evd, Univ.Level.set diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index eb2b435bf6..fe10be9e7c 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -17,8 +17,11 @@ open Environ open Evd open EConstr open Glob_term -open Evarutil open Ltac_pretype +open Evardefine + +val interp_known_glob_level : ?loc:Loc.t -> Evd.evar_map -> + Misctypes.glob_level -> Univ.Level.t (** An auxiliary function for searching for fixpoint guard indexes *) @@ -27,7 +30,7 @@ val search_guard : type typing_constraint = OfType of types | IsType | WithoutTypeConstraint -type inference_hook = env -> evar_map -> evar -> evar_map * constr +type inference_hook = env -> evar_map -> Evar.t -> evar_map * constr type inference_flags = { use_typeclasses : bool; diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib index 9904b73540..1da5b4567f 100644 --- a/pretyping/pretyping.mllib +++ b/pretyping/pretyping.mllib @@ -1,3 +1,4 @@ +Geninterp Ltac_pretype Locusops Pretype_errors diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index e6d8a0af26..9ff9a75b3e 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -213,7 +213,7 @@ let compute_canonical_projections warn (con,ind) = let sign = List.map (on_snd EConstr.Unsafe.to_constr) sign in let t = EConstr.Unsafe.to_constr t in let lt = List.rev_map snd sign in - let args = snd (Term.decompose_app t) in + let args = snd (decompose_app t) in let { s_EXPECTEDPARAM = p; s_PROJ = lpj; s_PROJKIND = kl } = lookup_structure ind in let params, projs = List.chop p args in diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 04374c88b4..3181766112 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -284,8 +284,6 @@ sig | Proj of int * int * projection * Cst_stack.t | Fix of ('a, 'a) pfixpoint * 'a t * Cst_stack.t | Cst of cst_member * int * int list * 'a t * Cst_stack.t - | Shift of int - | Update of 'a and 'a t = 'a member list exception IncompatibleFold2 @@ -343,8 +341,6 @@ struct | Proj of int * int * projection * Cst_stack.t | Fix of ('a, 'a) pfixpoint * 'a t * Cst_stack.t | Cst of cst_member * int * int list * 'a t * Cst_stack.t - | Shift of int - | Update of 'a and 'a t = 'a member list let rec pr_member pr_c member = @@ -367,8 +363,6 @@ struct ++ pr_comma () ++ prlist_with_sep pr_semicolon int remains ++ pr_comma () ++ pr pr_c params ++ str ")" - | Shift i -> str "ZShift(" ++ int i ++ str ")" - | Update t -> str "ZUpdate(" ++ pr_c t ++ str ")" and pr pr_c l = let open Pp in prlist_with_sep pr_semicolon (fun x -> hov 1 (pr_member pr_c x)) l @@ -414,9 +408,6 @@ struct let rec equal_rec sk1 lft1 sk2 lft2 = match sk1,sk2 with | [],[] -> Some (lft1,lft2) - | (Update _ :: _, _ | _, Update _ :: _) -> assert false - | Shift k :: s1, _ -> equal_rec s1 (lft1+k) sk2 lft2 - | _, Shift k :: s2 -> equal_rec sk1 lft1 s2 (lft2+k) | App a1 :: s1, App a2 :: s2 -> let t1,s1' = decomp_node_last a1 s1 in let t2,s2' = decomp_node_last a2 s2 in @@ -449,8 +440,6 @@ struct let rec compare_rec bal stk1 stk2 = match (stk1,stk2) with ([],[]) -> Int.equal bal 0 - | ((Update _|Shift _)::s1, _) -> compare_rec bal s1 stk2 - | (_, (Update _|Shift _)::s2) -> compare_rec bal stk1 s2 | (App (i,_,j)::s1, _) -> compare_rec (bal + j + 1 - i) s1 stk2 | (_, App (i,_,j)::s2) -> compare_rec (bal - j - 1 + i) stk1 s2 | (Case(c1,_,_,_)::s1, Case(c2,_,_,_)::s2) -> @@ -472,8 +461,6 @@ struct in match sk1,sk2 with | [], [] -> o,lft1,lft2 - | Shift n :: q1, _ -> aux o (lft1+n) q1 lft2 sk2 - | _, Shift n :: q2 -> aux o lft1 sk1 (lft2+n) q2 | App n1 :: q1, App n2 :: q2 -> let t1,l1 = decomp_node_last n1 q1 in let t2,l2 = decomp_node_last n2 q2 in @@ -493,13 +480,12 @@ struct let (o',lft1',lft2') = aux o lft1 (List.rev params1) lft2 (List.rev params2) in aux o' lft1' q1 lft2' q2 - | (((Update _|App _|Case _|Proj _|Fix _| Cst _) :: _|[]), _) -> + | (((App _|Case _|Proj _|Fix _| Cst _) :: _|[]), _) -> raise IncompatibleFold2 in aux o 0 (List.rev sk1) 0 (List.rev sk2) let rec map f x = List.map (function - | Update _ -> assert false - | (Proj (_,_,_,_) | Shift _) as e -> e + | (Proj (_,_,_,_)) as e -> e | App (i,a,j) -> let le = j - i + 1 in App (0,Array.map f (Array.sub a i le), le-1) @@ -516,18 +502,15 @@ struct let rec args_size = function | App (i,_,j)::s -> j + 1 - i + args_size s - | Shift(_)::s -> args_size s - | Update(_)::s -> args_size s | (Case _|Fix _|Proj _|Cst _)::_ | [] -> 0 let strip_app s = let rec aux out = function - | ( App _ | Shift _ as e) :: s -> aux (e :: out) s + | ( App _ as e) :: s -> aux (e :: out) s | s -> List.rev out,s in aux [] s let strip_n_app n s = let rec aux n out = function - | Shift k as e :: s -> aux n (e :: out) s | App (i,a,j) as e :: s -> let nb = j - i + 1 in if n >= nb then @@ -555,8 +538,6 @@ struct let (k,(args',s')) = aux s in let a' = Array.map (Vars.lift k) (Array.sub a i (j - i + 1)) in k,(Array.fold_right (fun x y -> x::y) a' args', s') - | Shift n :: s -> - let (k,(args',s')) = aux s in (k+n,(args', s')) | s -> (0,([],s)) in let (lft,(out,s')) = aux s in let init = match s' with [] when Int.equal lft 0 -> true | _ -> false in @@ -568,20 +549,18 @@ struct | None -> assert false let tail n0 s0 = - let rec aux lft n s = - let out s = if Int.equal lft 0 then s else Shift lft :: s in - if Int.equal n 0 then out s else + let rec aux n s = + if Int.equal n 0 then s else match s with | App (i,a,j) :: s -> let nb = j - i + 1 in if n >= nb then - aux lft (n - nb) s + aux (n - nb) s else let p = i+n in if j >= p then App(p,a,j)::s else s - | Shift k :: s' -> aux (lft+k) n s' | _ -> raise (Invalid_argument "Reductionops.Stack.tail") - in aux 0 n0 s0 + in aux n0 s0 let nth s p = match strip_n_app p s with @@ -627,11 +606,9 @@ struct zip (best_state sigma (constr_of_cst_member cst (params @ (append_app [|f|] s))) cst_l) | f, (Cst (cst,_,_,params,_)::s) -> zip (constr_of_cst_member cst (params @ (append_app [|f|] s))) - | f, (Shift n::s) -> zip (lift n f, s) | f, (Proj (n,m,p,cst_l)::s) when refold -> zip (best_state sigma (mkProj (p,f),s) cst_l) | f, (Proj (n,m,p,_)::s) -> zip (mkProj (p,f),s) - | _, (Update _::_) -> assert false in zip s @@ -1074,7 +1051,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = (arg, Stack.Cst (const,next,remains',s' @ (Stack.append_app [|x'|] bef),cst_l) :: s''') end - |_, (Stack.App _|Stack.Update _|Stack.Shift _)::_ -> assert false + |_, (Stack.App _)::_ -> assert false |_, _ -> fold () else fold () @@ -1155,7 +1132,7 @@ let local_whd_state_gen flags sigma = |args, (Stack.Fix (f,s',cst)::s'') when use_fix -> let x' = Stack.zip sigma (x,args) in whrec (contract_fix sigma f, s' @ (Stack.append_app [|x'|] s'')) - |_, (Stack.App _|Stack.Update _|Stack.Shift _|Stack.Cst _)::_ -> assert false + |_, (Stack.App _|Stack.Cst _)::_ -> assert false |_, _ -> s else s @@ -1167,7 +1144,8 @@ let local_whd_state_gen flags sigma = |_ -> s else s - | x -> s + | Rel _ | Var _ | Sort _ | Prod _ | LetIn _ | Const _ | Ind _ | Proj _ -> s + in whrec @@ -1305,7 +1283,7 @@ let is_transparent e k = (* Conversion utility functions *) -type conversion_test = constraints -> constraints +type conversion_test = Constraint.t -> Constraint.t let pb_is_equal pb = pb == Reduction.CONV @@ -1684,7 +1662,7 @@ let whd_betaiota_deltazeta_for_iota_state ts env sigma csts s = if isConstruct sigma t_o then whrec Cst_stack.empty (Stack.nth stack_o (n+m), stack'') else s,csts' - |_, ((Stack.App _| Stack.Shift _|Stack.Update _|Stack.Cst _) :: _|[]) -> s,csts' + |_, ((Stack.App _|Stack.Cst _) :: _|[]) -> s,csts' in whrec csts s let find_conclusion env sigma = @@ -1771,8 +1749,8 @@ let meta_reducible_instance evd b = let is_coerce = match s with CoerceToType -> true | _ -> false in if not is_coerce then irec g else u with Not_found -> u) - | Proj (p,c) when isMeta evd c || isCast evd c && isMeta evd (pi1 (destCast evd c)) -> - let m = try destMeta evd c with _ -> destMeta evd (pi1 (destCast evd c)) in + | Proj (p,c) when isMeta evd c || isCast evd c && isMeta evd (pi1 (destCast evd c)) (* What if two nested casts? *) -> + let m = try destMeta evd c with _ -> destMeta evd (pi1 (destCast evd c)) (* idem *) in (match try let g, s = Metamap.find m metas in diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index db0c29aeff..7e12d263aa 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -82,8 +82,6 @@ module Stack : sig | Fix of ('a, 'a) pfixpoint * 'a t * Cst_stack.t | Cst of cst_member * int (** current foccussed arg *) * int list (** remaining args *) * 'a t * Cst_stack.t - | Shift of int - | Update of 'a and 'a t = 'a member list val pr : ('a -> Pp.t) -> 'a t -> Pp.t @@ -107,7 +105,7 @@ module Stack : sig val append_app_list : 'a list -> 'a t -> 'a t (** if [strip_app s] = [(a,b)], then [s = a @ b] and [b] does not - start by App or Shift *) + start by App *) val strip_app : 'a t -> 'a t * 'a t (** @return (the nth first elements, the (n+1)th element, the remaining stack) *) val strip_n_app : int -> 'a t -> ('a t * 'a * 'a t) option @@ -262,7 +260,7 @@ val is_transparent : Environ.env -> Constant.t tableKey -> bool (** {6 Conversion Functions (uses closures, lazy strategy) } *) -type conversion_test = constraints -> constraints +type conversion_test = Constraint.t -> Constraint.t val pb_is_equal : conv_pb -> bool val pb_equal : conv_pb -> conv_pb diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index 5dd6879d39..f8f086fad3 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -166,23 +166,6 @@ let retype ?(polyprop=true) sigma = | Lambda _ | Fix _ | Construct _ -> retype_error NotAType | _ -> decomp_sort env sigma (type_of env t) - and sort_family_of env t = - match EConstr.kind sigma t with - | Cast (c,_, s) when isSort sigma s -> Sorts.family (destSort sigma s) - | Sort _ -> InType - | Prod (name,t,c2) -> - let s2 = sort_family_of (push_rel (LocalAssum (name,t)) env) c2 in - if not (is_impredicative_set env) && - s2 == InSet && sort_family_of env t == InType then InType else s2 - | App(f,args) when is_template_polymorphic env sigma f -> - let t = type_of_global_reference_knowing_parameters env f args in - Sorts.family (sort_of_atomic_type env sigma t args) - | App(f,args) -> - Sorts.family (sort_of_atomic_type env sigma (type_of env f) args) - | Lambda _ | Fix _ | Construct _ -> retype_error NotAType - | _ -> - Sorts.family (decomp_sort env sigma (type_of env t)) - and type_of_global_reference_knowing_parameters env c args = let argtyps = Array.map (fun c -> lazy (EConstr.to_constr sigma (type_of env c))) args in @@ -198,15 +181,34 @@ let retype ?(polyprop=true) sigma = EConstr.of_constr (type_of_constructor env (cstr, u)) | _ -> assert false - in type_of, sort_of, sort_family_of, - type_of_global_reference_knowing_parameters + in type_of, sort_of, type_of_global_reference_knowing_parameters + +let get_sort_family_of ?(truncation_style=false) ?(polyprop=true) env sigma t = + let type_of,_,type_of_global_reference_knowing_parameters = retype ~polyprop sigma in + let rec sort_family_of env t = + match EConstr.kind sigma t with + | Cast (c,_, s) when isSort sigma s -> Sorts.family (destSort sigma s) + | Sort _ -> InType + | Prod (name,t,c2) -> + let s2 = sort_family_of (push_rel (LocalAssum (name,t)) env) c2 in + if not (is_impredicative_set env) && + s2 == InSet && sort_family_of env t == InType then InType else s2 + | App(f,args) when is_template_polymorphic env sigma f -> + if truncation_style then InType else + let t = type_of_global_reference_knowing_parameters env f args in + Sorts.family (sort_of_atomic_type env sigma t args) + | App(f,args) -> + Sorts.family (sort_of_atomic_type env sigma (type_of env f) args) + | Lambda _ | Fix _ | Construct _ -> retype_error NotAType + | Ind _ when truncation_style && is_template_polymorphic env sigma t -> InType + | _ -> + Sorts.family (decomp_sort env sigma (type_of env t)) + in sort_family_of env t let get_sort_of ?(polyprop=true) env sigma t = - let _,f,_,_ = retype ~polyprop sigma in anomaly_on_error (f env) t -let get_sort_family_of ?(polyprop=true) env sigma c = - let _,_,f,_ = retype ~polyprop sigma in anomaly_on_error (f env) c + let _,f,_ = retype ~polyprop sigma in anomaly_on_error (f env) t let type_of_global_reference_knowing_parameters env sigma c args = - let _,_,_,f = retype sigma in anomaly_on_error (f env c) args + let _,_,f = retype sigma in anomaly_on_error (f env c) args let type_of_global_reference_knowing_conclusion env sigma c conclty = match EConstr.kind sigma c with @@ -232,7 +234,7 @@ let type_of_global_reference_knowing_conclusion env sigma c conclty = (* get_type_of polyprop lax env sigma c *) let get_type_of ?(polyprop=true) ?(lax=false) env sigma c = - let f,_,_,_ = retype ~polyprop sigma in + let f,_,_ = retype ~polyprop sigma in if lax then f env c else anomaly_on_error (f env) c (* Makes an unsafe judgment from a constr *) diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli index af86df499c..6fdde90463 100644 --- a/pretyping/retyping.mli +++ b/pretyping/retyping.mli @@ -31,8 +31,11 @@ val get_type_of : val get_sort_of : ?polyprop:bool -> env -> evar_map -> types -> Sorts.t +(* When [truncation_style] is [true], tells if the type has been explicitly + truncated to Prop or (impredicative) Set; in particular, singleton type and + small inductive types, which have all eliminations to Type, are in Type *) val get_sort_family_of : - ?polyprop:bool -> env -> evar_map -> types -> Sorts.family + ?truncation_style:bool -> ?polyprop:bool -> env -> evar_map -> types -> Sorts.family (** Makes an unsafe judgment from a constr *) val get_judgment_of : env -> evar_map -> constr -> unsafe_judgment diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index d55b286fb4..2e213a51d7 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -521,7 +521,7 @@ let mark_unresolvable evi = mark_resolvability false evi let mark_resolvable evi = mark_resolvability true evi open Evar_kinds -type evar_filter = existential_key -> Evar_kinds.t -> bool +type evar_filter = Evar.t -> Evar_kinds.t -> bool let all_evars _ _ = true let all_goals _ = function VarInstance _ | GoalEvar -> true | _ -> false diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli index 062d5cf356..618826f3d0 100644 --- a/pretyping/typeclasses.mli +++ b/pretyping/typeclasses.mli @@ -68,7 +68,7 @@ val class_info : global_reference -> typeclass (** raises a UserError if not a c val dest_class_app : env -> evar_map -> EConstr.constr -> (typeclass * EConstr.EInstance.t) * constr list (** Get the instantiated typeclass structure for a given universe instance. *) -val typeclass_univ_instance : typeclass puniverses -> typeclass +val typeclass_univ_instance : typeclass Univ.puniverses -> typeclass (** Just return None if not a class *) val class_of_constr : evar_map -> EConstr.constr -> (EConstr.rel_context * ((typeclass * EConstr.EInstance.t) * constr list)) option @@ -83,11 +83,11 @@ val is_instance : global_reference -> bool (** Returns the term and type for the given instance of the parameters and fields of the type class. *) -val instance_constructor : typeclass puniverses -> constr list -> +val instance_constructor : typeclass Univ.puniverses -> constr list -> constr option * types (** Filter which evars to consider for resolution. *) -type evar_filter = existential_key -> Evar_kinds.t -> bool +type evar_filter = Evar.t -> Evar_kinds.t -> bool val all_evars : evar_filter val all_goals : evar_filter val no_goals : evar_filter diff --git a/pretyping/unification.ml b/pretyping/unification.ml index a4e2f90d4c..84ffab4260 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -573,7 +573,9 @@ let is_rigid_head sigma flags t = | Ind (i,u) -> true | Construct _ -> true | Fix _ | CoFix _ -> true - | _ -> false + | Rel _ | Var _ | Meta _ | Evar _ | Sort _ | Cast (_, _, _) | Prod (_, _, _) + | Lambda (_, _, _) | LetIn (_, _, _, _) | App (_, _) | Case (_, _, _, _) + | Proj (_, _) -> false (* Why aren't Prod, Sort rigid heads ? *) let force_eqs c = Universes.Constraints.fold @@ -654,7 +656,10 @@ let rec is_neutral env sigma ts t = | Evar _ | Meta _ -> true | Case (_, p, c, cl) -> is_neutral env sigma ts c | Proj (p, c) -> is_neutral env sigma ts c - | _ -> false + | Lambda _ | LetIn _ | Construct _ | CoFix _ -> false + | Sort _ | Cast (_, _, _) | Prod (_, _, _) | Ind _ -> false (* Really? *) + | Fix _ -> false (* This is an approximation *) + | App _ -> assert false let is_eta_constructor_app env sigma ts f l1 term = match EConstr.kind sigma f with @@ -1788,7 +1793,9 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = with ex when precatchable_exception ex -> matchrec c) - | _ -> user_err Pp.(str "Match_subterm"))) + | Cast (_, _, _) (* Is this expected? *) + | Rel _ | Var _ | Meta _ | Evar _ | Sort _ | Const _ | Ind _ + | Construct _ -> user_err Pp.(str "Match_subterm"))) in try matchrec cl with ex when precatchable_exception ex -> @@ -1854,7 +1861,11 @@ let w_unify_to_subterm_all env evd ?(flags=default_unify_flags ()) (op,cl) = | Lambda (_,t,c) -> bind (matchrec t) (matchrec c) - | _ -> fail "Match_subterm")) + | Cast (_, _, _) -> fail "Match_subterm" (* Is this expected? *) + + | Rel _ | Var _ | Meta _ | Evar _ | Sort _ | Const _ | Ind _ + | Construct _ -> fail "Match_subterm")) + in let res = matchrec cl [] in match res with diff --git a/pretyping/univdecls.ml b/pretyping/univdecls.ml index 5576e33f46..3cf32d7ff0 100644 --- a/pretyping/univdecls.ml +++ b/pretyping/univdecls.ml @@ -6,9 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Pp -open CErrors open Names +open CErrors (** Local universes and constraints declarations *) type universe_decl = @@ -22,27 +21,16 @@ let default_univ_decl = 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 " ++ Id.print 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 ul = Pretyping.interp_known_glob_level evd u in + let u'l = Pretyping.interp_known_glob_level evd 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 *)) + user_err ~hdr:"interp_constraint" + (Univ.explain_universe_inconsistency (Termops.pr_evd_level evd) e) in List.fold_left interp (evd,Univ.Constraint.empty) cstrs diff --git a/printing/genprint.ml b/printing/genprint.ml index 776a212b5c..37a94fe219 100644 --- a/printing/genprint.ml +++ b/printing/genprint.ml @@ -16,21 +16,27 @@ open Geninterp (* Printing generic values *) -type printer_with_level = +type 'a with_level = { default_already_surrounded : Notation_term.tolerability; default_ensure_surrounded : Notation_term.tolerability; - printer : Environ.env -> Evd.evar_map -> Notation_term.tolerability -> Pp.t } + printer : 'a } type printer_result = | PrinterBasic of (unit -> Pp.t) -| PrinterNeedsContext of (Environ.env -> Evd.evar_map -> Pp.t) -| PrinterNeedsContextAndLevel of printer_with_level +| PrinterNeedsLevel of (Notation_term.tolerability -> Pp.t) with_level -type 'a printer = 'a -> Pp.t +type printer_fun_with_level = Environ.env -> Evd.evar_map -> Notation_term.tolerability -> Pp.t -type 'a top_printer = 'a -> printer_result +type top_printer_result = +| TopPrinterBasic of (unit -> Pp.t) +| TopPrinterNeedsContext of (Environ.env -> Evd.evar_map -> Pp.t) +| TopPrinterNeedsContextAndLevel of printer_fun_with_level with_level -module ValMap = ValTMap (struct type 'a t = 'a -> printer_result end) +type 'a printer = 'a -> printer_result + +type 'a top_printer = 'a -> top_printer_result + +module ValMap = ValTMap (struct type 'a t = 'a -> top_printer_result end) let print0_val_map = ref ValMap.empty @@ -48,32 +54,32 @@ let register_val_print0 s pr = print0_val_map := ValMap.add s pr !print0_val_map let combine_dont_needs pr_pair pr1 = function - | PrinterBasic pr2 -> - PrinterBasic (fun () -> pr_pair (pr1 ()) (pr2 ())) - | PrinterNeedsContext pr2 -> - PrinterNeedsContext (fun env sigma -> + | TopPrinterBasic pr2 -> + TopPrinterBasic (fun () -> pr_pair (pr1 ()) (pr2 ())) + | TopPrinterNeedsContext pr2 -> + TopPrinterNeedsContext (fun env sigma -> pr_pair (pr1 ()) (pr2 env sigma)) - | PrinterNeedsContextAndLevel { default_ensure_surrounded; printer } -> - PrinterNeedsContext (fun env sigma -> + | TopPrinterNeedsContextAndLevel { default_ensure_surrounded; printer } -> + TopPrinterNeedsContext (fun env sigma -> pr_pair (pr1 ()) (printer env sigma default_ensure_surrounded)) let combine_needs pr_pair pr1 = function - | PrinterBasic pr2 -> - PrinterNeedsContext (fun env sigma -> pr_pair (pr1 env sigma) (pr2 ())) - | PrinterNeedsContext pr2 -> - PrinterNeedsContext (fun env sigma -> + | TopPrinterBasic pr2 -> + TopPrinterNeedsContext (fun env sigma -> pr_pair (pr1 env sigma) (pr2 ())) + | TopPrinterNeedsContext pr2 -> + TopPrinterNeedsContext (fun env sigma -> pr_pair (pr1 env sigma) (pr2 env sigma)) - | PrinterNeedsContextAndLevel { default_ensure_surrounded; printer } -> - PrinterNeedsContext (fun env sigma -> + | TopPrinterNeedsContextAndLevel { default_ensure_surrounded; printer } -> + TopPrinterNeedsContext (fun env sigma -> pr_pair (pr1 env sigma) (printer env sigma default_ensure_surrounded)) let combine pr_pair pr1 v2 = match pr1 with - | PrinterBasic pr1 -> + | TopPrinterBasic pr1 -> combine_dont_needs pr_pair pr1 (generic_val_print v2) - | PrinterNeedsContext pr1 -> + | TopPrinterNeedsContext pr1 -> combine_needs pr_pair pr1 (generic_val_print v2) - | PrinterNeedsContextAndLevel { default_ensure_surrounded; printer } -> + | TopPrinterNeedsContextAndLevel { default_ensure_surrounded; printer } -> combine_needs pr_pair (fun env sigma -> printer env sigma default_ensure_surrounded) (generic_val_print v2) @@ -81,14 +87,14 @@ let _ = let pr_cons a b = Pp.(a ++ spc () ++ b) in register_val_print0 Val.typ_list (function - | [] -> PrinterBasic mt + | [] -> TopPrinterBasic mt | a::l -> List.fold_left (combine pr_cons) (generic_val_print a) l) let _ = register_val_print0 Val.typ_opt (function - | None -> PrinterBasic Pp.mt + | None -> TopPrinterBasic Pp.mt | Some v -> generic_val_print v) let _ = @@ -99,9 +105,9 @@ let _ = (* Printing generic arguments *) type ('raw, 'glb, 'top) genprinter = { - raw : 'raw printer; - glb : 'glb printer; - top : 'top -> printer_result; + raw : 'raw -> printer_result; + glb : 'glb -> printer_result; + top : 'top -> top_printer_result; } module PrintObj = @@ -112,9 +118,9 @@ struct | ExtraArg tag -> let name = ArgT.repr tag in let printer = { - raw = (fun _ -> str "<genarg:" ++ str name ++ str ">"); - glb = (fun _ -> str "<genarg:" ++ str name ++ str ">"); - top = (fun _ -> PrinterBasic (fun () -> str "<genarg:" ++ str name ++ str ">")); + raw = (fun _ -> PrinterBasic (fun () -> str "<genarg:" ++ str name ++ str ">")); + glb = (fun _ -> PrinterBasic (fun () -> str "<genarg:" ++ str name ++ str ">")); + top = (fun _ -> TopPrinterBasic (fun () -> str "<genarg:" ++ str name ++ str ">")); } in Some printer | _ -> assert false diff --git a/printing/genprint.mli b/printing/genprint.mli index 2da9bbc36b..baa60fcb2e 100644 --- a/printing/genprint.mli +++ b/printing/genprint.mli @@ -10,19 +10,25 @@ open Genarg -type printer_with_level = +type 'a with_level = { default_already_surrounded : Notation_term.tolerability; default_ensure_surrounded : Notation_term.tolerability; - printer : Environ.env -> Evd.evar_map -> Notation_term.tolerability -> Pp.t } + printer : 'a } type printer_result = | PrinterBasic of (unit -> Pp.t) -| PrinterNeedsContext of (Environ.env -> Evd.evar_map -> Pp.t) -| PrinterNeedsContextAndLevel of printer_with_level +| PrinterNeedsLevel of (Notation_term.tolerability -> Pp.t) with_level -type 'a printer = 'a -> Pp.t +type printer_fun_with_level = Environ.env -> Evd.evar_map -> Notation_term.tolerability -> Pp.t -type 'a top_printer = 'a -> printer_result +type top_printer_result = +| TopPrinterBasic of (unit -> Pp.t) +| TopPrinterNeedsContext of (Environ.env -> Evd.evar_map -> Pp.t) +| TopPrinterNeedsContextAndLevel of printer_fun_with_level with_level + +type 'a printer = 'a -> printer_result + +type 'a top_printer = 'a -> top_printer_result val raw_print : ('raw, 'glb, 'top) genarg_type -> 'raw printer (** Printer for raw level generic arguments. *) @@ -34,7 +40,7 @@ val top_print : ('raw, 'glb, 'top) genarg_type -> 'top top_printer (** Printer for top level generic arguments. *) val register_print0 : ('raw, 'glb, 'top) genarg_type -> - 'raw printer -> 'glb printer -> ('top -> printer_result) -> unit + 'raw printer -> 'glb printer -> 'top top_printer -> unit val register_val_print0 : 'top Geninterp.Val.typ -> 'top top_printer -> unit val register_vernac_print0 : ('raw, 'glb, 'top) genarg_type -> diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index 0f6452de69..2abbc389fa 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -150,10 +150,15 @@ let tag_var = tag Tag.variable let pr_sep_com sep f c = pr_with_comments ?loc:(constr_loc c) (sep() ++ f c) + let pr_univ_expr = function + | Some (x,n) -> + pr_reference x ++ (match n with 0 -> mt () | _ -> str"+" ++ int n) + | None -> str"_" + let pr_univ l = match l with - | [_,x] -> Name.print x - | l -> str"max(" ++ prlist_with_sep (fun () -> str",") (fun x -> Name.print (snd x)) l ++ str")" + | [x] -> pr_univ_expr x + | l -> str"max(" ++ prlist_with_sep (fun () -> str",") pr_univ_expr l ++ str")" let pr_univ_annot pr x = str "@{" ++ pr x ++ str "}" @@ -166,8 +171,9 @@ let tag_var = tag Tag.variable let pr_glob_level = function | GProp -> tag_type (str "Prop") | GSet -> tag_type (str "Set") - | GType None -> tag_type (str "Type") - | GType (Some (_, u)) -> tag_type (Name.print u) + | GType UUnknown -> tag_type (str "Type") + | GType UAnonymous -> tag_type (str "_") + | GType (UNamed u) -> tag_type (pr_reference u) let pr_qualid sp = let (sl, id) = repr_qualid sp in @@ -192,8 +198,9 @@ let tag_var = tag Tag.variable tag_type (str "Set") | GType u -> (match u with - | Some (_,u) -> Name.print u - | None -> tag_type (str "Type")) + | UNamed u -> pr_reference u + | UAnonymous -> tag_type (str "Type") + | UUnknown -> tag_type (str "_")) let pr_universe_instance l = pr_opt_no_spc (pr_univ_annot (prlist_with_sep spc pr_glob_sort_instance)) l @@ -396,7 +403,7 @@ let tag_var = tag Tag.variable extract_prod_binders c | { loc; v = CProdN ([[_,Name id],bk,t], { v = CCases (LetPatternStyle,None, [{ v = CRef (Ident (_,id'),None)},None,None],[(_,([_,[p]],b))])} ) } - when Id.equal id id' && not (Id.Set.mem id (Topconstr.free_vars_of_constr_expr b)) -> + when Id.equal id id' && not (Id.Set.mem id (free_vars_of_constr_expr b)) -> let bl,c = extract_prod_binders b in CLocalPattern (loc, (p,None)) :: bl, c | { loc; v = CProdN ((nal,bk,t)::bl,c) } -> @@ -412,7 +419,7 @@ let tag_var = tag Tag.variable extract_lam_binders c | CLambdaN ([[_,Name id],bk,t], { v = CCases (LetPatternStyle,None, [{ v = CRef (Ident (_,id'),None)},None,None],[(_,([_,[p]],b))])} ) - when Id.equal id id' && not (Id.Set.mem id (Topconstr.free_vars_of_constr_expr b)) -> + when Id.equal id id' && not (Id.Set.mem id (free_vars_of_constr_expr b)) -> let bl,c = extract_lam_binders b in CLocalPattern (ce.loc,(p,None)) :: bl, c | CLambdaN ((nal,bk,t)::bl,c) -> @@ -430,7 +437,7 @@ let tag_var = tag Tag.variable let rename na na' t c = match (na,na') with | (_,Name id), (_,Name id') -> - (na',t,Topconstr.replace_vars_constr_expr (Id.Map.singleton id id') c) + (na',t,replace_vars_constr_expr (Id.Map.singleton id id') c) | (_,Name id), (_,Anonymous) -> (na,t,c) | _ -> (na',t,c) diff --git a/printing/pputils.ml b/printing/pputils.ml index 3cc7a3e6b9..a544b47623 100644 --- a/printing/pputils.ml +++ b/printing/pputils.ml @@ -103,6 +103,9 @@ let pr_red_expr (pr_constr,pr_lconstr,pr_ref,pr_pattern) keyword = function | CbvNative o -> keyword "native_compute" ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern) keyword) o +let pr_red_expr_env env sigma (pr_constr,pr_lconstr,pr_ref,pr_pattern) = + pr_red_expr (pr_constr env sigma, pr_lconstr env sigma, pr_ref, pr_pattern env sigma) + let pr_or_by_notation f = function | AN v -> f v | ByNotation (_,(s,sc)) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc @@ -127,7 +130,10 @@ let rec pr_raw_generic env (GenArg (Rawwit wit, x)) = let q = in_gen (rawwit wit2) q in hov_if_not_empty 0 (pr_sequence (pr_raw_generic env) [p; q]) | ExtraArg s -> - Genprint.generic_raw_print (in_gen (rawwit wit) x) + let open Genprint in + match generic_raw_print (in_gen (rawwit wit) x) with + | PrinterBasic pp -> pp () + | PrinterNeedsLevel { default_ensure_surrounded; printer } -> printer default_ensure_surrounded let rec pr_glb_generic env (GenArg (Glbwit wit, x)) = @@ -149,4 +155,7 @@ let rec pr_glb_generic env (GenArg (Glbwit wit, x)) = let ans = pr_sequence (pr_glb_generic env) [p; q] in hov_if_not_empty 0 ans | ExtraArg s -> - Genprint.generic_glb_print (in_gen (glbwit wit) x) + let open Genprint in + match generic_glb_print (in_gen (glbwit wit) x) with + | PrinterBasic pp -> pp () + | PrinterNeedsLevel { default_ensure_surrounded; printer } -> printer default_ensure_surrounded diff --git a/printing/pputils.mli b/printing/pputils.mli index 1f4fa1390d..f7f586b773 100644 --- a/printing/pputils.mli +++ b/printing/pputils.mli @@ -21,8 +21,16 @@ val pr_with_occurrences : val pr_short_red_flag : ('a -> Pp.t) -> 'a glob_red_flag -> Pp.t val pr_red_flag : ('a -> Pp.t) -> 'a glob_red_flag -> Pp.t + val pr_red_expr : ('a -> Pp.t) * ('a -> Pp.t) * ('b -> Pp.t) * ('c -> Pp.t) -> + (string -> Pp.t) -> ('a,'b,'c) red_expr_gen -> Pp.t + +val pr_red_expr_env : Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> 'a -> Pp.t) * + (Environ.env -> Evd.evar_map -> 'a -> Pp.t) * + ('b -> Pp.t) * + (Environ.env -> Evd.evar_map -> 'c -> Pp.t) -> (string -> Pp.t) -> ('a,'b,'c) red_expr_gen -> Pp.t diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index 143f9ddcc5..46ef2ac031 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -41,6 +41,11 @@ open Decl_kinds pr_glob_level l ++ spc () ++ Univ.pr_constraint_type d ++ spc () ++ pr_glob_level r + let pr_univ_name_list = function + | None -> mt () + | Some l -> + str "@{" ++ prlist_with_sep spc pr_lname l ++ str"}" + let pr_univdecl_instance l extensible = prlist_with_sep spc pr_lident l ++ (if extensible then str"+" else mt ()) @@ -319,23 +324,18 @@ open Decl_kinds | SortClass -> keyword "Sortclass" | RefClass qid -> pr_smart_global qid - let pr_assumption_token many (l,a) = - let l = match l with Some x -> x | None -> Decl_kinds.Global in - match l, a with - | (Discharge,Logical) -> - keyword (if many then "Hypotheses" else "Hypothesis") - | (Discharge,Definitional) -> - keyword (if many then "Variables" else "Variable") - | (Global,Logical) -> + let pr_assumption_token many discharge kind = + match discharge, kind with + | (NoDischarge,Logical) -> keyword (if many then "Axioms" else "Axiom") - | (Global,Definitional) -> + | (NoDischarge,Definitional) -> keyword (if many then "Parameters" else "Parameter") - | (Local, Logical) -> - keyword (if many then "Local Axioms" else "Local Axiom") - | (Local,Definitional) -> - keyword (if many then "Local Parameters" else "Local Parameter") - | (Global,Conjectural) -> str"Conjecture" - | ((Discharge | Local),Conjectural) -> + | (NoDischarge,Conjectural) -> str"Conjecture" + | (DoDischarge,Logical) -> + keyword (if many then "Hypotheses" else "Hypothesis") + | (DoDischarge,Definitional) -> + keyword (if many then "Variables" else "Variable") + | (DoDischarge,Conjectural) -> anomaly (Pp.str "Don't know how to beautify a local conjecture.") let pr_params pr_c (xl,(c,t)) = @@ -447,7 +447,7 @@ open Decl_kinds | PrintGrammar ent -> keyword "Print Grammar" ++ spc() ++ str ent | PrintLoadPath dir -> - keyword "Print LoadPath" ++ pr_opt pr_dirpath dir + keyword "Print LoadPath" ++ pr_opt DirPath.print dir | PrintModules -> keyword "Print Modules" | PrintMLLoadPath -> @@ -488,8 +488,8 @@ open Decl_kinds else "Print Universes" in keyword cmd ++ pr_opt str fopt - | PrintName qid -> - keyword "Print" ++ spc() ++ pr_smart_global qid + | PrintName (qid,udecl) -> + keyword "Print" ++ spc() ++ pr_smart_global qid ++ pr_univ_name_list udecl | PrintModuleType qid -> keyword "Print Module Type" ++ spc() ++ pr_reference qid | PrintModule qid -> @@ -502,9 +502,9 @@ open Decl_kinds keyword "Print Scope" ++ spc() ++ str s | PrintVisibility s -> keyword "Print Visibility" ++ pr_opt str s - | PrintAbout (qid,gopt) -> + | PrintAbout (qid,l,gopt) -> pr_opt (fun g -> Proof_bullet.pr_goal_selector g ++ str ":"++ spc()) gopt - ++ keyword "About" ++ spc() ++ pr_smart_global qid + ++ keyword "About" ++ spc() ++ pr_smart_global qid ++ pr_univ_name_list l | PrintImplicit qid -> keyword "Print Implicit" ++ spc() ++ pr_smart_global qid (* spiwack: command printing all the axioms and section variables used in a @@ -518,7 +518,7 @@ open Decl_kinds in keyword cmd ++ spc() ++ pr_smart_global qid | PrintNamespace dp -> - keyword "Print Namespace" ++ pr_dirpath dp + keyword "Print Namespace" ++ DirPath.print dp | PrintStrategy None -> keyword "Print Strategies" | PrintStrategy (Some qid) -> @@ -626,7 +626,7 @@ open Decl_kinds return (keyword "Fail" ++ spc() ++ pr_vernac_body v) (* Syntax *) - | VernacOpenCloseScope (_,(opening,sc)) -> + | VernacOpenCloseScope (opening,sc) -> return ( keyword (if opening then "Open " else "Close ") ++ keyword "Scope" ++ spc() ++ str sc @@ -655,7 +655,7 @@ open Decl_kinds ++ spc() ++ pr_smart_global q ++ spc() ++ str"[" ++ prlist_with_sep sep pr_opt_scope scl ++ str"]" ) - | VernacInfix (_,((_,s),mv),q,sn) -> (* A Verifier *) + | VernacInfix (((_,s),mv),q,sn) -> (* A Verifier *) return ( hov 0 (hov 0 (keyword "Infix " ++ qs s ++ str " :=" ++ pr_constrarg q) ++ @@ -664,7 +664,7 @@ open Decl_kinds | None -> mt() | Some sc -> spc() ++ str":" ++ spc() ++ str sc)) ) - | VernacNotation (_,c,((_,s),l),opt) -> + | VernacNotation (c,((_,s),l),opt) -> return ( hov 2 (keyword "Notation" ++ spc() ++ qs s ++ str " :=" ++ Flags.without_option Flags.beautify pr_constrarg c ++ pr_syntax_modifiers l ++ @@ -672,7 +672,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 @@ -683,10 +683,9 @@ open Decl_kinds ) (* Gallina *) - | VernacDefinition (d,id,b) -> (* A verifier... *) - let pr_def_token (l,dk) = - let l = match l with Some x -> x | None -> Decl_kinds.Global in - keyword (Kindops.string_of_definition_kind (l,false,dk)) + | VernacDefinition ((discharge,kind),id,b) -> (* A verifier... *) + let pr_def_token dk = + keyword (Kindops.string_of_definition_object_kind dk) in let pr_reduce = function | None -> mt() @@ -707,7 +706,7 @@ open Decl_kinds let (binds,typ,c) = pr_def_body b in return ( hov 2 ( - pr_def_token d ++ spc() + pr_def_token kind ++ spc() ++ pr_ident_decl id ++ binds ++ typ ++ (match c with | None -> mt() @@ -732,13 +731,13 @@ open Decl_kinds ) | VernacExactProof c -> return (hov 2 (keyword "Proof" ++ pr_lconstrarg c)) - | VernacAssumption (stre,t,l) -> + | VernacAssumption ((discharge,kind),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_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 ++ + return (hov 2 (pr_assumption_token (n > 1) discharge kind ++ pr_non_empty_arg pr_assumption_inline t ++ spc() ++ assumptions)) | VernacInductive (cum, p,f,l) -> let pr_constructor (coe,(id,c)) = @@ -788,9 +787,8 @@ open Decl_kinds | VernacFixpoint (local, recs) -> let local = match local with - | Some Discharge -> "Let " - | Some Local -> "Local " - | None | Some Global -> "" + | DoDischarge -> "Let " + | NoDischarge -> "" in return ( hov 0 (str local ++ keyword "Fixpoint" ++ spc () ++ @@ -800,9 +798,8 @@ open Decl_kinds | VernacCoFixpoint (local, corecs) -> let local = match local with - | Some Discharge -> keyword "Let" ++ spc () - | Some Local -> keyword "Local" ++ spc () - | None | Some Global -> str "" + | DoDischarge -> keyword "Let" ++ spc () + | NoDischarge -> str "" in let pr_onecorec ((iddecl,bl,c,def),ntn) = pr_ident_decl iddecl ++ spc() ++ pr_binders bl ++ spc() ++ str":" ++ @@ -863,14 +860,14 @@ open Decl_kinds return ( keyword "Canonical Structure" ++ spc() ++ pr_smart_global q ) - | VernacCoercion (_,id,c1,c2) -> + | VernacCoercion (id,c1,c2) -> return ( hov 1 ( keyword "Coercion" ++ spc() ++ pr_smart_global id ++ spc() ++ str":" ++ spc() ++ pr_class_rawexpr c1 ++ spc() ++ str">->" ++ spc() ++ pr_class_rawexpr c2) ) - | VernacIdentityCoercion (_,id,c1,c2) -> + | VernacIdentityCoercion (id,c1,c2) -> return ( hov 1 ( keyword "Identity Coercion" ++ spc() ++ pr_lident id ++ @@ -964,7 +961,7 @@ open Decl_kinds keyword "LoadPath" ++ spc() ++ qs s ++ (match d with | None -> mt() - | Some dir -> spc() ++ keyword "as" ++ spc() ++ pr_dirpath dir)) + | Some dir -> spc() ++ keyword "as" ++ spc() ++ DirPath.print dir)) ) | VernacRemoveLoadPath s -> return (keyword "Remove LoadPath" ++ qs s) @@ -994,9 +991,9 @@ open Decl_kinds prlist_with_sep spc (fun r -> pr_id (coerce_reference_to_id r)) ids ++ pr_opt_hintbases dbnames) ) - | VernacHints (_, dbnames,h) -> + | VernacHints (dbnames,h) -> return (pr_hints dbnames h pr_constr pr_constr_pattern_expr) - | VernacSyntacticDefinition (id,(ids,c),_,compat) -> + | VernacSyntacticDefinition (id,(ids,c),compat) -> return ( hov 2 (keyword "Notation" ++ spc () ++ pr_lident id ++ spc () ++ diff --git a/printing/prettyp.ml b/printing/prettyp.ml index acbd2d5d2f..1eb2c31c88 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -15,7 +15,6 @@ open CErrors open Util open Names open Nameops -open Term open Termops open Declarations open Environ @@ -33,15 +32,15 @@ open Context.Rel.Declaration module NamedDecl = Context.Named.Declaration type object_pr = { - print_inductive : MutInd.t -> Pp.t; - print_constant_with_infos : Constant.t -> Pp.t; - print_section_variable : variable -> Pp.t; - print_syntactic_def : KerName.t -> Pp.t; + print_inductive : MutInd.t -> Universes.univ_name_list option -> Pp.t; + print_constant_with_infos : Constant.t -> Universes.univ_name_list option -> Pp.t; + print_section_variable : env -> Evd.evar_map -> variable -> Pp.t; + print_syntactic_def : env -> KerName.t -> Pp.t; print_module : bool -> ModPath.t -> Pp.t; print_modtype : ModPath.t -> Pp.t; - print_named_decl : Context.Named.Declaration.t -> Pp.t; - print_library_entry : bool -> (object_name * Lib.node) -> Pp.t option; - print_context : bool -> int option -> Lib.library_segment -> Pp.t; + print_named_decl : env -> Evd.evar_map -> Context.Named.Declaration.t -> Pp.t; + print_library_entry : env -> Evd.evar_map -> bool -> (object_name * Lib.node) -> Pp.t option; + print_context : env -> Evd.evar_map -> bool -> int option -> Lib.library_segment -> Pp.t; print_typed_value_in_env : Environ.env -> Evd.evar_map -> EConstr.constr * EConstr.types -> Pp.t; print_eval : Reductionops.reduction_function -> env -> Evd.evar_map -> Constrexpr.constr_expr -> EConstr.unsafe_judgment -> Pp.t; } @@ -69,7 +68,7 @@ let int_or_no n = if Int.equal n 0 then str "no" else int n let print_basename sp = pr_global (ConstRef sp) -let print_ref reduce ref = +let print_ref reduce ref udecl = let typ, ctx = Global.type_of_global_in_context (Global.env ()) ref in let typ = Vars.subst_instance_constr (Univ.AUContext.instance ctx) typ in let typ = EConstr.of_constr typ in @@ -82,7 +81,8 @@ let print_ref reduce ref = let inst = Univ.AUContext.instance univs in let univs = Univ.UContext.make (inst, Univ.AUContext.instantiate inst univs) in let env = Global.env () in - let bl = Universes.universe_binders_of_global ref in + let bl = Universes.universe_binders_with_opt_names ref + (Array.to_list (Univ.Instance.to_array inst)) udecl in let sigma = Evd.from_ctx (Evd.evar_universe_context_of_binders bl) in let inst = if Global.is_polymorphic ref then Printer.pr_universe_instance sigma univs @@ -139,7 +139,7 @@ let print_renames_list prefix l = let need_expansion impl ref = let typ, _ = Global.type_of_global_in_context (Global.env ()) ref in - let ctx = prod_assum typ in + let ctx = Term.prod_assum typ in let nprods = List.count is_local_assum ctx in not (List.is_empty impl) && List.length impl >= nprods && let _,lastimpl = List.chop nprods impl in @@ -151,7 +151,7 @@ let print_impargs ref = let has_impl = not (List.is_empty impl) in (* Need to reduce since implicits are computed with products flattened *) pr_infos_list - ([ print_ref (need_expansion (select_impargs_size 0 impl) ref) ref; + ([ print_ref (need_expansion (select_impargs_size 0 impl) ref) ref None; blankline ] @ (if has_impl then print_impargs_list (mt()) impl else [str "No implicit arguments"])) @@ -257,7 +257,7 @@ let print_name_infos ref = if need_expansion (select_impargs_size 0 impls) ref then (* Need to reduce since implicits are computed with products flattened *) [str "Expanded type for implicit arguments"; - print_ref true ref; blankline] + print_ref true ref None; blankline] else [] in print_polymorphism ref @ @@ -360,13 +360,13 @@ let pr_located_qualid = function str "Notation" ++ spc () ++ pr_path (Nametab.path_of_syndef kn) | Dir dir -> let s,dir = match dir with - | DirOpenModule (dir,_) -> "Open Module", dir - | DirOpenModtype (dir,_) -> "Open Module Type", dir - | DirOpenSection (dir,_) -> "Open Section", dir - | DirModule (dir,_) -> "Module", dir + | DirOpenModule { obj_dir ; _ } -> "Open Module", obj_dir + | DirOpenModtype { obj_dir ; _ } -> "Open Module Type", obj_dir + | DirOpenSection { obj_dir ; _ } -> "Open Section", obj_dir + | DirModule { obj_dir ; _ } -> "Module", obj_dir | DirClosedSection dir -> "Closed Section", dir in - str s ++ spc () ++ pr_dirpath dir + str s ++ spc () ++ DirPath.print dir | ModuleType mp -> str "Module Type" ++ spc () ++ pr_path (Nametab.path_of_modtype mp) | Other (obj, info) -> info.name obj @@ -410,7 +410,7 @@ let locate_term qid = let locate_module qid = let all = Nametab.locate_extended_all_dir qid in let map dir = match dir with - | DirModule (_, (mp, _)) -> Some (Dir dir, Nametab.shortest_qualid_of_module mp) + | DirModule { obj_mp ; _ } -> Some (Dir dir, Nametab.shortest_qualid_of_module obj_mp) | DirOpenModule _ -> Some (Dir dir, qid) | _ -> None in @@ -487,25 +487,25 @@ let gallina_print_typed_value_in_env env sigma (trm,typ) = the pretty-print of a proposition (P:(nat->nat)->Prop)(P [u]u) synthesizes the type nat of the abstraction on u *) -let print_named_def name body typ = - let pbody = pr_lconstr body in - let ptyp = pr_ltype typ in - let pbody = if isCast body then surround pbody else pbody in +let print_named_def env sigma name body typ = + let pbody = pr_lconstr_env env sigma body in + let ptyp = pr_ltype_env env sigma typ in + let pbody = if Constr.isCast body then surround pbody else pbody in (str "*** [" ++ str name ++ str " " ++ hov 0 (str ":=" ++ brk (1,2) ++ pbody ++ spc () ++ str ":" ++ brk (1,2) ++ ptyp) ++ str "]") -let print_named_assum name typ = - str "*** [" ++ str name ++ str " : " ++ pr_ltype typ ++ str "]" +let print_named_assum env sigma name typ = + str "*** [" ++ str name ++ str " : " ++ pr_ltype_env env sigma typ ++ str "]" -let gallina_print_named_decl = +let gallina_print_named_decl env sigma = let open Context.Named.Declaration in function | LocalAssum (id, typ) -> - print_named_assum (Id.to_string id) typ + print_named_assum env sigma (Id.to_string id) typ | LocalDef (id, body, typ) -> - print_named_def (Id.to_string id) body typ + print_named_def env sigma (Id.to_string id) body typ let assumptions_for_print lna = List.fold_right (fun na env -> add_name na env) lna empty_names_context @@ -513,22 +513,22 @@ let assumptions_for_print lna = (*********************) (* *) -let gallina_print_inductive sp = +let gallina_print_inductive sp udecl = let env = Global.env() in let mib = Environ.lookup_mind sp env in let mipv = mib.mind_packets in - pr_mutual_inductive_body env sp mib ++ + pr_mutual_inductive_body env sp mib udecl ++ with_line_skip (print_primitive_record mib.mind_finite mipv mib.mind_record @ print_inductive_renames sp mipv @ print_inductive_implicit_args sp mipv @ print_inductive_argument_scopes sp mipv) -let print_named_decl id = - gallina_print_named_decl (Global.lookup_named id) ++ fnl () +let print_named_decl env sigma id = + gallina_print_named_decl env sigma (Global.lookup_named id) ++ fnl () -let gallina_print_section_variable id = - print_named_decl id ++ +let gallina_print_section_variable env sigma id = + print_named_decl env sigma id ++ with_line_skip (print_name_infos (VarRef id)) let print_body env evd = function @@ -546,7 +546,7 @@ let print_instance sigma cb = pr_universe_instance sigma univs else mt() -let print_constant with_values sep sp = +let print_constant with_values sep sp udecl = let cb = Global.lookup_constant sp in let val_0 = Global.body_of_constant_body cb in let typ = @@ -556,31 +556,34 @@ let print_constant with_values sep sp = let inst = Univ.AUContext.instance univs in Vars.subst_instance_constr inst cb.const_type in - let univs = + let univs, ulist = + let open Entries in + let open Univ in let otab = Global.opaque_tables () in match cb.const_body with | Undef _ | Def _ -> begin match cb.const_universes with - | Monomorphic_const ctx -> ctx + | Monomorphic_const ctx -> Monomorphic_const_entry ctx, [] | Polymorphic_const ctx -> - let inst = Univ.AUContext.instance ctx in - Univ.UContext.make (inst, Univ.AUContext.instantiate inst ctx) + let inst = AUContext.instance ctx in + Polymorphic_const_entry (UContext.make (inst, AUContext.instantiate inst ctx)), + Array.to_list (Instance.to_array inst) end | OpaqueDef o -> let body_uctxs = Opaqueproof.force_constraints otab o in match cb.const_universes with | Monomorphic_const ctx -> - let uctxs = Univ.ContextSet.of_context ctx in - Univ.ContextSet.to_context (Univ.ContextSet.union body_uctxs uctxs) + Monomorphic_const_entry (ContextSet.union body_uctxs ctx), [] | Polymorphic_const ctx -> - assert(Univ.ContextSet.is_empty body_uctxs); - let inst = Univ.AUContext.instance ctx in - Univ.UContext.make (inst, Univ.AUContext.instantiate inst ctx) + assert(ContextSet.is_empty body_uctxs); + let inst = AUContext.instance ctx in + Polymorphic_const_entry (UContext.make (inst, AUContext.instantiate inst ctx)), + Array.to_list (Instance.to_array inst) in let ctx = Evd.evar_universe_context_of_binders - (Universes.universe_binders_of_global (ConstRef sp)) + (Universes.universe_binders_with_opt_names (ConstRef sp) ulist udecl) in let env = Global.env () and sigma = Evd.from_ctx ctx in let pr_ltype = pr_ltype_env env sigma in @@ -590,18 +593,18 @@ let print_constant with_values sep sp = str"*** [ " ++ print_basename sp ++ print_instance sigma cb ++ str " : " ++ cut () ++ pr_ltype typ ++ str" ]" ++ - Printer.pr_universe_ctx sigma univs + Printer.pr_constant_universes sigma univs | Some (c, ctx) -> let c = Vars.subst_instance_constr (Univ.AUContext.instance ctx) c in print_basename sp ++ print_instance sigma cb ++ str sep ++ cut () ++ (if with_values then print_typed_body env sigma (Some c,typ) else pr_ltype typ)++ - Printer.pr_universe_ctx sigma univs) + Printer.pr_constant_universes sigma univs) -let gallina_print_constant_with_infos sp = - print_constant true " = " sp ++ +let gallina_print_constant_with_infos sp udecl = + print_constant true " = " sp udecl ++ with_line_skip (print_name_infos (ConstRef sp)) -let gallina_print_syntactic_def kn = +let gallina_print_syntactic_def env kn = let qid = Nametab.shortest_qualid_of_syndef Id.Set.empty kn and (vars,a) = Syntax_def.search_syntactic_definition kn in let c = Notation_ops.glob_constr_of_notation_constr a in @@ -612,20 +615,20 @@ let gallina_print_syntactic_def kn = spc () ++ str ":=") ++ spc () ++ Constrextern.without_specific_symbols - [Notation.SynDefRule kn] pr_glob_constr c) + [Notation.SynDefRule kn] (pr_glob_constr_env env) c) -let gallina_print_leaf_entry with_values ((sp,kn as oname),lobj) = +let gallina_print_leaf_entry env sigma with_values ((sp,kn as oname),lobj) = let sep = if with_values then " = " else " : " and tag = object_tag lobj in match (oname,tag) with | (_,"VARIABLE") -> (* Outside sections, VARIABLES still exist but only with universes constraints *) - (try Some(print_named_decl (basename sp)) with Not_found -> None) + (try Some(print_named_decl env sigma (basename sp)) with Not_found -> None) | (_,"CONSTANT") -> - Some (print_constant with_values sep (Constant.make1 kn)) + Some (print_constant with_values sep (Constant.make1 kn) None) | (_,"INDUCTIVE") -> - Some (gallina_print_inductive (MutInd.make1 kn)) + Some (gallina_print_inductive (MutInd.make1 kn) None) | (_,"MODULE") -> let (mp,_,l) = KerName.repr kn in Some (print_module with_values (MPdot (mp,l))) @@ -637,26 +640,26 @@ let gallina_print_leaf_entry with_values ((sp,kn as oname),lobj) = (* To deal with forgotten cases... *) | (_,s) -> None -let gallina_print_library_entry with_values ent = +let gallina_print_library_entry env sigma with_values ent = let pr_name (sp,_) = Id.print (basename sp) in match ent with | (oname,Lib.Leaf lobj) -> - gallina_print_leaf_entry with_values (oname,lobj) + gallina_print_leaf_entry env sigma with_values (oname,lobj) | (oname,Lib.OpenedSection (dir,_)) -> Some (str " >>>>>>> Section " ++ pr_name oname) | (oname,Lib.ClosedSection _) -> Some (str " >>>>>>> Closed Section " ++ pr_name oname) - | (_,Lib.CompilingLibrary (dir,_)) -> - Some (str " >>>>>>> Library " ++ pr_dirpath dir) + | (_,Lib.CompilingLibrary { obj_dir; _ }) -> + Some (str " >>>>>>> Library " ++ DirPath.print obj_dir) | (oname,Lib.OpenedModule _) -> Some (str " >>>>>>> Module " ++ pr_name oname) | (oname,Lib.ClosedModule _) -> Some (str " >>>>>>> Closed Module " ++ pr_name oname) -let gallina_print_context with_values = +let gallina_print_context env sigma with_values = let rec prec n = function | h::rest when Option.is_empty n || Option.get n > 0 -> - (match gallina_print_library_entry with_values h with + (match gallina_print_library_entry env sigma with_values h with | None -> prec n rest | Some pp -> prec (Option.map ((+) (-1)) n) rest ++ pp ++ fnl ()) | _ -> mt () @@ -718,10 +721,10 @@ let print_safe_judgment env sigma j = (*********************) (* *) -let print_full_context () = print_context true None (Lib.contents ()) -let print_full_context_typ () = print_context false None (Lib.contents ()) +let print_full_context env sigma = print_context env sigma true None (Lib.contents ()) +let print_full_context_typ env sigma = print_context env sigma false None (Lib.contents ()) -let print_full_pure_context () = +let print_full_pure_context env sigma = let rec prec = function | ((_,kn),Lib.Leaf lobj)::rest -> let pp = match object_tag lobj with @@ -733,20 +736,20 @@ let print_full_pure_context () = match cb.const_body with | Undef _ -> str "Parameter " ++ - print_basename con ++ str " : " ++ cut () ++ pr_ltype typ + print_basename con ++ str " : " ++ cut () ++ pr_ltype_env env sigma typ | OpaqueDef lc -> str "Theorem " ++ print_basename con ++ cut () ++ - str " : " ++ pr_ltype typ ++ str "." ++ fnl () ++ - str "Proof " ++ pr_lconstr (Opaqueproof.force_proof (Global.opaque_tables ()) lc) + str " : " ++ pr_ltype_env env sigma typ ++ str "." ++ fnl () ++ + str "Proof " ++ pr_lconstr_env env sigma (Opaqueproof.force_proof (Global.opaque_tables ()) lc) | Def c -> str "Definition " ++ print_basename con ++ cut () ++ - str " : " ++ pr_ltype typ ++ cut () ++ str " := " ++ - pr_lconstr (Mod_subst.force_constr c)) + str " : " ++ pr_ltype_env env sigma typ ++ cut () ++ str " := " ++ + pr_lconstr_env env sigma (Mod_subst.force_constr c)) ++ str "." ++ fnl () ++ fnl () | "INDUCTIVE" -> let mind = Global.mind_of_delta_kn kn in let mib = Global.lookup_mind mind in - pr_mutual_inductive_body (Global.env()) mind mib ++ + pr_mutual_inductive_body (Global.env()) mind mib None ++ str "." ++ fnl () ++ fnl () | "MODULE" -> (* TODO: make it reparsable *) @@ -776,8 +779,8 @@ let read_sec_context r = with Not_found -> user_err ?loc ~hdr:"read_sec_context" (str "Unknown section.") in let rec get_cxt in_cxt = function - | (_,Lib.OpenedSection ((dir',_),_) as hd)::rest -> - if DirPath.equal dir dir' then (hd::in_cxt) else get_cxt (hd::in_cxt) rest + | (_,Lib.OpenedSection ({obj_dir;_},_) as hd)::rest -> + if DirPath.equal dir obj_dir then (hd::in_cxt) else get_cxt (hd::in_cxt) rest | (_,Lib.ClosedSection _)::rest -> user_err Pp.(str "Cannot print the contents of a closed section.") (* LEM: Actually, we could if we wanted to. *) @@ -787,19 +790,28 @@ let read_sec_context r = let cxt = Lib.contents () in List.rev (get_cxt [] cxt) -let print_sec_context sec = - print_context true None (read_sec_context sec) - -let print_sec_context_typ sec = - print_context false None (read_sec_context sec) - -let print_any_name = function - | Term (ConstRef sp) -> print_constant_with_infos sp - | Term (IndRef (sp,_)) -> print_inductive sp - | Term (ConstructRef ((sp,_),_)) -> print_inductive sp - | Term (VarRef sp) -> print_section_variable sp - | Syntactic kn -> print_syntactic_def kn - | Dir (DirModule(dirpath,(mp,_))) -> print_module (printable_body dirpath) mp +let print_sec_context env sigma sec = + print_context env sigma true None (read_sec_context sec) + +let print_sec_context_typ env sigma sec = + print_context env sigma false None (read_sec_context sec) + +let maybe_error_reject_univ_decl na udecl = + match na, udecl with + | _, None | Term (ConstRef _ | IndRef _ | ConstructRef _), Some _ -> () + | (Term (VarRef _) | Syntactic _ | Dir _ | ModuleType _ | Other _ | Undefined _), Some udecl -> + (* TODO Print na somehow *) + user_err ~hdr:"reject_univ_decl" (str "This object does not support universe names.") + +let print_any_name env sigma na udecl = + maybe_error_reject_univ_decl na udecl; + match na with + | Term (ConstRef sp) -> print_constant_with_infos sp udecl + | Term (IndRef (sp,_)) -> print_inductive sp udecl + | Term (ConstructRef ((sp,_),_)) -> print_inductive sp udecl + | Term (VarRef sp) -> print_section_variable env sigma sp + | Syntactic kn -> print_syntactic_def env kn + | Dir (DirModule { obj_dir; obj_mp; _ } ) -> print_module (printable_body obj_dir) obj_mp | Dir _ -> mt () | ModuleType mp -> print_modtype mp | Other (obj, info) -> info.print obj @@ -807,31 +819,32 @@ let print_any_name = function try (* Var locale de but, pas var de section... donc pas d'implicits *) let dir,str = repr_qualid qid in if not (DirPath.is_empty dir) then raise Not_found; - str |> Global.lookup_named |> print_named_decl + str |> Global.lookup_named |> print_named_decl env sigma with Not_found -> user_err ~hdr:"print_name" (pr_qualid qid ++ spc () ++ str "not a defined object.") -let print_name = function +let print_name env sigma na udecl = + match na with | ByNotation (loc,(ntn,sc)) -> - print_any_name + print_any_name env sigma (Term (Notation.interp_notation_as_global_reference ?loc (fun _ -> true) ntn sc)) + udecl | AN ref -> - print_any_name (locate_any_name ref) + print_any_name env sigma (locate_any_name ref) udecl -let print_opaque_name qid = - let env = Global.env () in +let print_opaque_name env sigma qid = match Nametab.global qid with | ConstRef cst -> let cb = Global.lookup_constant cst in if Declareops.constant_has_body cb then - print_constant_with_infos cst + print_constant_with_infos cst None else user_err Pp.(str "Not a defined constant.") | IndRef (sp,_) -> - print_inductive sp + print_inductive sp None | ConstructRef cstr as gr -> let ty, ctx = Global.type_of_global_in_context env gr in let inst = Univ.AUContext.instance ctx in @@ -840,15 +853,16 @@ let print_opaque_name qid = let open EConstr in print_typed_value (mkConstruct cstr, ty) | VarRef id -> - env |> lookup_named id |> print_named_decl + env |> lookup_named id |> print_named_decl env sigma -let print_about_any ?loc k = +let print_about_any ?loc env sigma k udecl = + maybe_error_reject_univ_decl k udecl; match k with | Term ref -> let rb = Reductionops.ReductionBehaviour.print ref in Dumpglob.add_glob ?loc ref; pr_infos_list - (print_ref false ref :: blankline :: + (print_ref false ref udecl :: blankline :: print_name_infos ref @ (if Pp.ismt rb then [] else [rb]) @ print_opacity ref @ @@ -858,23 +872,24 @@ let print_about_any ?loc k = | [],Notation_term.NRef ref -> Dumpglob.add_glob ?loc ref | _ -> () in v 0 ( - print_syntactic_def kn ++ fnl () ++ + print_syntactic_def env kn ++ fnl () ++ hov 0 (str "Expands to: " ++ pr_located_qualid k)) | Dir _ | ModuleType _ | Undefined _ -> hov 0 (pr_located_qualid k) | Other (obj, info) -> hov 0 (info.about obj) -let print_about = function +let print_about env sigma na udecl = + match na with | ByNotation (loc,(ntn,sc)) -> - print_about_any ?loc + print_about_any ?loc env sigma (Term (Notation.interp_notation_as_global_reference ?loc (fun _ -> true) - ntn sc)) + ntn sc)) udecl | AN ref -> - print_about_any ?loc:(loc_of_reference ref) (locate_any_name ref) + print_about_any ?loc:(loc_of_reference ref) env sigma (locate_any_name ref) udecl (* for debug *) -let inspect depth = - print_context false (Some depth) (Lib.contents ()) +let inspect env sigma depth = + print_context env sigma false (Some depth) (Lib.contents ()) (*************************************************************************) @@ -882,18 +897,20 @@ let inspect depth = open Classops -let print_coercion_value v = pr_lconstr (get_coercion_value v) +let print_coercion_value env sigma v = pr_lconstr_env env sigma (get_coercion_value v) let print_class i = let cl,_ = class_info_from_index i in pr_class cl let print_path ((i,j),p) = + let sigma, env = Pfedit.get_current_context () in hov 2 ( - str"[" ++ hov 0 (prlist_with_sep pr_semicolon print_coercion_value p) ++ + str"[" ++ hov 0 (prlist_with_sep pr_semicolon (print_coercion_value env sigma) p) ++ str"] : ") ++ print_class i ++ str" >-> " ++ print_class j +(* XXX: This is suspicious!!! *) let _ = Classops.install_path_printer print_path let print_graph () = @@ -902,8 +919,8 @@ let print_graph () = let print_classes () = pr_sequence pr_class (classes()) -let print_coercions () = - pr_sequence print_coercion_value (coercions()) +let print_coercions env sigma = + pr_sequence (print_coercion_value env sigma) (coercions()) let index_of_class cl = try @@ -925,11 +942,11 @@ let print_path_between cls clt = in print_path ((i,j),p) -let print_canonical_projections () = +let print_canonical_projections env sigma = prlist_with_sep fnl (fun ((r1,r2),o) -> pr_cs_pattern r2 ++ str " <- " ++ - pr_global r1 ++ str " ( " ++ pr_lconstr o.o_DEF ++ str " )") + pr_global r1 ++ str " ( " ++ pr_lconstr_env env sigma o.o_DEF ++ str " )") (canonical_projections ()) (*************************************************************************) @@ -940,7 +957,7 @@ let print_canonical_projections () = open Typeclasses let pr_typeclass env t = - print_ref false t.cl_impl + print_ref false t.cl_impl None let print_typeclasses () = let env = Global.env () in @@ -949,7 +966,7 @@ let print_typeclasses () = let pr_instance env i = (* gallina_print_constant_with_infos i.is_impl *) (* lighter *) - print_ref false (instance_impl i) ++ + print_ref false (instance_impl i) None ++ begin match hint_priority i with | None -> mt () | Some i -> spc () ++ str "|" ++ spc () ++ int i diff --git a/printing/prettyp.mli b/printing/prettyp.mli index 31fd766ea3..8f3a6ddc47 100644 --- a/printing/prettyp.mli +++ b/printing/prettyp.mli @@ -18,37 +18,39 @@ open Misctypes val assumptions_for_print : Name.t list -> Termops.names_context val print_closed_sections : bool ref -val print_context : bool -> int option -> Lib.library_segment -> Pp.t -val print_library_entry : bool -> (object_name * Lib.node) -> Pp.t option -val print_full_context : unit -> Pp.t -val print_full_context_typ : unit -> Pp.t -val print_full_pure_context : unit -> Pp.t -val print_sec_context : reference -> Pp.t -val print_sec_context_typ : reference -> Pp.t +val print_context : env -> Evd.evar_map -> bool -> int option -> Lib.library_segment -> Pp.t +val print_library_entry : env -> Evd.evar_map -> bool -> (object_name * Lib.node) -> Pp.t option +val print_full_context : env -> Evd.evar_map -> Pp.t +val print_full_context_typ : env -> Evd.evar_map -> Pp.t +val print_full_pure_context : env -> Evd.evar_map -> Pp.t +val print_sec_context : env -> Evd.evar_map -> reference -> Pp.t +val print_sec_context_typ : env -> Evd.evar_map -> reference -> Pp.t val print_judgment : env -> Evd.evar_map -> EConstr.unsafe_judgment -> Pp.t val print_safe_judgment : env -> Evd.evar_map -> Safe_typing.judgment -> Pp.t val print_eval : reduction_function -> env -> Evd.evar_map -> Constrexpr.constr_expr -> EConstr.unsafe_judgment -> Pp.t -val print_name : reference or_by_notation -> Pp.t -val print_opaque_name : reference -> Pp.t -val print_about : reference or_by_notation -> Pp.t +val print_name : env -> Evd.evar_map -> reference or_by_notation -> + Vernacexpr.univ_name_list option -> Pp.t +val print_opaque_name : env -> Evd.evar_map -> reference -> Pp.t +val print_about : env -> Evd.evar_map -> reference or_by_notation -> + Vernacexpr.univ_name_list option -> Pp.t val print_impargs : reference or_by_notation -> Pp.t (** Pretty-printing functions for classes and coercions *) val print_graph : unit -> Pp.t val print_classes : unit -> Pp.t -val print_coercions : unit -> Pp.t +val print_coercions : env -> Evd.evar_map -> Pp.t val print_path_between : Classops.cl_typ -> Classops.cl_typ -> Pp.t -val print_canonical_projections : unit -> Pp.t +val print_canonical_projections : env -> Evd.evar_map -> Pp.t (** Pretty-printing functions for type classes and instances *) val print_typeclasses : unit -> Pp.t val print_instances : global_reference -> Pp.t val print_all_instances : unit -> Pp.t -val inspect : int -> Pp.t +val inspect : env -> Evd.evar_map -> int -> Pp.t (** {5 Locate} *) @@ -80,17 +82,17 @@ val print_located_module : reference -> Pp.t val print_located_other : string -> reference -> Pp.t type object_pr = { - print_inductive : MutInd.t -> Pp.t; - print_constant_with_infos : Constant.t -> Pp.t; - print_section_variable : variable -> Pp.t; - print_syntactic_def : KerName.t -> Pp.t; + print_inductive : MutInd.t -> Universes.univ_name_list option -> Pp.t; + print_constant_with_infos : Constant.t -> Universes.univ_name_list option -> Pp.t; + print_section_variable : env -> Evd.evar_map -> variable -> Pp.t; + print_syntactic_def : env -> KerName.t -> Pp.t; print_module : bool -> ModPath.t -> Pp.t; print_modtype : ModPath.t -> Pp.t; - print_named_decl : Context.Named.Declaration.t -> Pp.t; - print_library_entry : bool -> (object_name * Lib.node) -> Pp.t option; - print_context : bool -> int option -> Lib.library_segment -> Pp.t; + print_named_decl : env -> Evd.evar_map -> Context.Named.Declaration.t -> Pp.t; + print_library_entry : env -> Evd.evar_map -> bool -> (object_name * Lib.node) -> Pp.t option; + print_context : env -> Evd.evar_map -> bool -> int option -> Lib.library_segment -> Pp.t; print_typed_value_in_env : Environ.env -> Evd.evar_map -> EConstr.constr * EConstr.types -> Pp.t; - print_eval : reduction_function -> env -> Evd.evar_map -> Constrexpr.constr_expr -> EConstr.unsafe_judgment -> Pp.t + print_eval : Reductionops.reduction_function -> env -> Evd.evar_map -> Constrexpr.constr_expr -> EConstr.unsafe_judgment -> Pp.t; } val set_object_pr : object_pr -> unit diff --git a/printing/printer.ml b/printing/printer.ml index 075b03b7d1..6a0597860c 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -10,7 +10,6 @@ open Pp open CErrors open Util open Names -open Term open Constr open Environ open Globnames @@ -26,9 +25,6 @@ module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration module CompactedDecl = Context.Compacted.Declaration -let get_current_context () = - Pfedit.get_current_context () - let enable_unfocused_goal_printing = ref false let enable_goal_tags_printing = ref false let enable_goal_names_printing = ref false @@ -104,10 +100,10 @@ let pr_econstr_env env sigma c = pr_econstr_core false env sigma c (* NB do not remove the eta-redexes! Global.env() has side-effects... *) let pr_lconstr t = - let (sigma, env) = get_current_context () in + let (sigma, env) = Pfedit.get_current_context () in pr_lconstr_env env sigma t let pr_constr t = - let (sigma, env) = get_current_context () in + let (sigma, env) = Pfedit.get_current_context () in pr_constr_env env sigma t let pr_open_lconstr (_,c) = pr_lconstr c @@ -127,10 +123,10 @@ let pr_constr_under_binders_env = pr_constr_under_binders_env_gen pr_econstr_env let pr_lconstr_under_binders_env = pr_constr_under_binders_env_gen pr_leconstr_env let pr_constr_under_binders c = - let (sigma, env) = get_current_context () in + let (sigma, env) = Pfedit.get_current_context () in pr_constr_under_binders_env env sigma c let pr_lconstr_under_binders c = - let (sigma, env) = get_current_context () in + let (sigma, env) = Pfedit.get_current_context () in pr_lconstr_under_binders_env env sigma c let pr_etype_core goal_concl_style env sigma t = @@ -142,10 +138,10 @@ let pr_ltype_env env sigma c = pr_letype_core false env sigma (EConstr.of_constr let pr_type_env env sigma c = pr_etype_core false env sigma (EConstr.of_constr c) let pr_ltype t = - let (sigma, env) = get_current_context () in + let (sigma, env) = Pfedit.get_current_context () in pr_ltype_env env sigma t let pr_type t = - let (sigma, env) = get_current_context () in + let (sigma, env) = Pfedit.get_current_context () in pr_type_env env sigma t let pr_etype_env env sigma c = pr_etype_core false env sigma c @@ -156,7 +152,7 @@ let pr_ljudge_env env sigma j = (pr_leconstr_env env sigma j.uj_val, pr_leconstr_env env sigma j.uj_type) let pr_ljudge j = - let (sigma, env) = get_current_context () in + let (sigma, env) = Pfedit.get_current_context () in pr_ljudge_env env sigma j let pr_lglob_constr_env env c = @@ -165,10 +161,10 @@ let pr_glob_constr_env env c = pr_constr_expr (extern_glob_constr (Termops.vars_of_env env) c) let pr_lglob_constr c = - let (sigma, env) = get_current_context () in + let (sigma, env) = Pfedit.get_current_context () in pr_lglob_constr_env env c let pr_glob_constr c = - let (sigma, env) = get_current_context () in + let (sigma, env) = Pfedit.get_current_context () in pr_glob_constr_env env c let pr_closed_glob_n_env env sigma n c = @@ -176,7 +172,7 @@ let pr_closed_glob_n_env env sigma n c = let pr_closed_glob_env env sigma c = pr_constr_expr (extern_closed_glob false env sigma c) let pr_closed_glob c = - let (sigma, env) = get_current_context () in + let (sigma, env) = Pfedit.get_current_context () in pr_closed_glob_env env sigma c let pr_lconstr_pattern_env env sigma c = @@ -188,10 +184,10 @@ let pr_cases_pattern t = pr_cases_pattern_expr (extern_cases_pattern Names.Id.Set.empty t) let pr_lconstr_pattern t = - let (sigma, env) = get_current_context () in + let (sigma, env) = Pfedit.get_current_context () in pr_lconstr_pattern_env env sigma t let pr_constr_pattern t = - let (sigma, env) = get_current_context () in + let (sigma, env) = Pfedit.get_current_context () in pr_constr_pattern_env env sigma t let pr_sort sigma s = pr_glob_sort (extern_sort sigma s) @@ -253,13 +249,20 @@ let safe_gen f env sigma c = let safe_pr_lconstr_env = safe_gen pr_lconstr_env let safe_pr_constr_env = safe_gen pr_constr_env let safe_pr_lconstr t = - let (sigma, env) = get_current_context () in + let (sigma, env) = Pfedit.get_current_context () in safe_pr_lconstr_env env sigma t let safe_pr_constr t = - let (sigma, env) = get_current_context () in + let (sigma, env) = Pfedit.get_current_context () in safe_pr_constr_env env sigma t +let pr_universe_ctx_set sigma c = + if !Detyping.print_universes && not (Univ.ContextSet.is_empty c) then + fnl()++pr_in_comment (fun c -> v 0 + (Univ.pr_universe_context_set (Termops.pr_evd_level sigma) c)) c + else + mt() + let pr_universe_ctx sigma c = if !Detyping.print_universes && not (Univ.UContext.is_empty c) then fnl()++pr_in_comment (fun c -> v 0 @@ -267,6 +270,10 @@ let pr_universe_ctx sigma c = else mt() +let pr_constant_universes sigma = function + | Entries.Monomorphic_const_entry ctx -> pr_universe_ctx_set sigma ctx + | Entries.Polymorphic_const_entry ctx -> pr_universe_ctx sigma ctx + let pr_cumulativity_info sigma cumi = if !Detyping.print_universes && not (Univ.UContext.is_empty (Univ.CumulativityInfo.univ_context cumi)) then @@ -587,7 +594,7 @@ let default_pr_subgoal n sigma = in prrec n -let pr_internal_existential_key ev = str (string_of_existential ev) +let pr_internal_existential_key ev = Evar.print ev let print_evar_constraints gl sigma = let pr_env = @@ -766,7 +773,7 @@ let default_pr_subgoals ?(pr_first=true) type printer_pr = { - pr_subgoals : ?pr_first:bool -> Pp.t option -> evar_map -> evar list -> Goal.goal list -> int list -> goal list -> goal list -> Pp.t; + pr_subgoals : ?pr_first:bool -> Pp.t option -> evar_map -> Evar.t list -> Goal.goal list -> int list -> goal list -> goal list -> Pp.t; pr_subgoal : int -> evar_map -> goal list -> Pp.t; pr_goal : goal sigma -> Pp.t; } @@ -788,7 +795,7 @@ let pr_goal x = !printer_pr.pr_goal x (* End abstraction layer *) (**********************************************************************) -let pr_open_subgoals ?(proof=Proof_global.give_me_the_proof ()) () = +let pr_open_subgoals ~proof = (* spiwack: it shouldn't be the job of the printer to look up stuff in the [evar_map], I did stuff that way because it was more straightforward, but seriously, [Proof.proof] should return @@ -826,15 +833,13 @@ let pr_open_subgoals ?(proof=Proof_global.give_me_the_proof ()) () = pr_subgoals ~pr_first:true None bsigma seeds shelf [] unfocused_if_needed bgoals_focused end -let pr_nth_open_subgoal n = - let pf = Proof_global.give_me_the_proof () in - let { it=gls ; sigma=sigma } = Proof.V82.subgoals pf in +let pr_nth_open_subgoal ~proof n = + let gls,_,_,_,sigma = Proof.proof proof in pr_subgoal n sigma gls -let pr_goal_by_id id = - let p = Proof_global.give_me_the_proof () in +let pr_goal_by_id ~proof id = try - Proof.in_proof p (fun sigma -> + Proof.in_proof proof (fun sigma -> let g = Evd.evar_key id sigma in pr_selected_subgoal (pr_id id) sigma g) with Not_found -> user_err Pp.(str "No such goal.") @@ -916,7 +921,7 @@ let pr_assumptionset env s = with e when CErrors.noncritical e -> mt () in let safe_pr_ltype_relctx (rctx, typ) = - let sigma, env = get_current_context () in + let sigma, env = Pfedit.get_current_context () in let env = Environ.push_rel_context rctx env in try str " " ++ pr_ltype_env env sigma typ with e when CErrors.noncritical e -> mt () diff --git a/printing/printer.mli b/printing/printer.mli index fbba14edea..36ca1bdcca 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -27,10 +27,12 @@ val enable_goal_names_printing : bool ref val pr_lconstr_env : env -> evar_map -> constr -> Pp.t val pr_lconstr : constr -> Pp.t +[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_lconstr_goal_style_env : env -> evar_map -> constr -> Pp.t val pr_constr_env : env -> evar_map -> constr -> Pp.t val pr_constr : constr -> Pp.t +[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_constr_goal_style_env : env -> evar_map -> constr -> Pp.t val pr_constr_n_env : env -> evar_map -> Notation_term.tolerability -> constr -> Pp.t @@ -41,14 +43,18 @@ val pr_constr_n_env : env -> evar_map -> Notation_term.tolerability -> co val safe_pr_lconstr_env : env -> evar_map -> constr -> Pp.t val safe_pr_lconstr : constr -> Pp.t +[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val safe_pr_constr_env : env -> evar_map -> constr -> Pp.t val safe_pr_constr : constr -> Pp.t +[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_econstr_env : env -> evar_map -> EConstr.t -> Pp.t val pr_econstr : EConstr.t -> Pp.t +[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_leconstr_env : env -> evar_map -> EConstr.t -> Pp.t val pr_leconstr : EConstr.t -> Pp.t +[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_econstr_n_env : env -> evar_map -> Notation_term.tolerability -> EConstr.t -> Pp.t @@ -57,41 +63,53 @@ val pr_letype_env : env -> evar_map -> EConstr.types -> Pp.t val pr_open_constr_env : env -> evar_map -> open_constr -> Pp.t val pr_open_constr : open_constr -> Pp.t +[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_open_lconstr_env : env -> evar_map -> open_constr -> Pp.t val pr_open_lconstr : open_constr -> Pp.t +[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_constr_under_binders_env : env -> evar_map -> constr_under_binders -> Pp.t val pr_constr_under_binders : constr_under_binders -> Pp.t +[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_lconstr_under_binders_env : env -> evar_map -> constr_under_binders -> Pp.t val pr_lconstr_under_binders : constr_under_binders -> Pp.t +[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_goal_concl_style_env : env -> evar_map -> EConstr.types -> Pp.t val pr_ltype_env : env -> evar_map -> types -> Pp.t val pr_ltype : types -> Pp.t +[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_type_env : env -> evar_map -> types -> Pp.t val pr_type : types -> Pp.t +[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_closed_glob_n_env : env -> evar_map -> Notation_term.tolerability -> closed_glob_constr -> Pp.t val pr_closed_glob_env : env -> evar_map -> closed_glob_constr -> Pp.t val pr_closed_glob : closed_glob_constr -> Pp.t +[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_ljudge_env : env -> evar_map -> EConstr.unsafe_judgment -> Pp.t * Pp.t val pr_ljudge : EConstr.unsafe_judgment -> Pp.t * Pp.t +[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_lglob_constr_env : env -> 'a glob_constr_g -> Pp.t val pr_lglob_constr : 'a glob_constr_g -> Pp.t +[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_glob_constr_env : env -> 'a glob_constr_g -> Pp.t val pr_glob_constr : 'a glob_constr_g -> Pp.t +[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_lconstr_pattern_env : env -> evar_map -> constr_pattern -> Pp.t val pr_lconstr_pattern : constr_pattern -> Pp.t +[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_constr_pattern_env : env -> evar_map -> constr_pattern -> Pp.t val pr_constr_pattern : constr_pattern -> Pp.t +[@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_cases_pattern : cases_pattern -> Pp.t @@ -103,6 +121,8 @@ val pr_polymorphic : bool -> Pp.t val pr_cumulative : bool -> bool -> Pp.t val pr_universe_instance : evar_map -> Univ.UContext.t -> Pp.t val pr_universe_ctx : evar_map -> Univ.UContext.t -> Pp.t +val pr_universe_ctx_set : evar_map -> Univ.ContextSet.t -> Pp.t +val pr_constant_universes : evar_map -> Entries.constant_universes_entry -> Pp.t val pr_cumulativity_info : evar_map -> Univ.CumulativityInfo.t -> Pp.t (** Printing global references using names as short as possible *) @@ -111,7 +131,7 @@ val pr_global_env : Id.Set.t -> global_reference -> Pp.t val pr_global : global_reference -> Pp.t val pr_constant : env -> Constant.t -> Pp.t -val pr_existential_key : evar_map -> existential_key -> Pp.t +val pr_existential_key : evar_map -> Evar.t -> Pp.t val pr_existential : env -> evar_map -> existential -> Pp.t val pr_constructor : env -> constructor -> Pp.t val pr_inductive : env -> inductive -> Pp.t @@ -160,15 +180,15 @@ val pr_goal : goal sigma -> Pp.t focused goals unless the conrresponding option [enable_unfocused_goal_printing] is set. [seeds] is for printing dependent evars (mainly for emacs proof tree mode). *) -val pr_subgoals : ?pr_first:bool -> Pp.t option -> evar_map -> evar list -> Goal.goal list -> int list +val pr_subgoals : ?pr_first:bool -> Pp.t option -> evar_map -> Evar.t list -> Goal.goal list -> int list -> goal list -> goal list -> Pp.t val pr_subgoal : int -> evar_map -> goal list -> Pp.t val pr_concl : int -> evar_map -> goal -> Pp.t -val pr_open_subgoals : ?proof:Proof.proof -> unit -> Pp.t -val pr_nth_open_subgoal : int -> Pp.t -val pr_evar : evar_map -> (evar * evar_info) -> Pp.t +val pr_open_subgoals : proof:Proof.t -> Pp.t +val pr_nth_open_subgoal : proof:Proof.t -> int -> Pp.t +val pr_evar : evar_map -> (Evar.t * evar_info) -> Pp.t val pr_evars_int : evar_map -> int -> evar_info Evar.Map.t -> Pp.t val pr_evars : evar_map -> evar_info Evar.Map.t -> Pp.t val pr_ne_evar_set : Pp.t -> Pp.t -> evar_map -> @@ -200,13 +220,13 @@ module ContextObjectMap : CMap.ExtS val pr_assumptionset : env -> types ContextObjectMap.t -> Pp.t -val pr_goal_by_id : Id.t -> Pp.t +val pr_goal_by_id : proof:Proof.t -> Id.t -> Pp.t type printer_pr = { - pr_subgoals : ?pr_first:bool -> Pp.t option -> evar_map -> evar list -> Goal.goal list -> int list -> goal list -> goal list -> Pp.t; + pr_subgoals : ?pr_first:bool -> Pp.t option -> evar_map -> Evar.t list -> Goal.goal list -> int list -> goal list -> goal list -> Pp.t; pr_subgoal : int -> evar_map -> goal list -> Pp.t; pr_goal : goal sigma -> Pp.t; -};; +} val set_printer_pr : printer_pr -> unit diff --git a/printing/printmod.ml b/printing/printmod.ml index 0abca01602..05292b06ba 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -121,7 +121,7 @@ let instantiate_cumulativity_info cumi = in CumulativityInfo.make (expose univs, expose subtyp) -let print_mutual_inductive env mind mib = +let print_mutual_inductive env mind mib udecl = let inds = List.init (Array.length mib.mind_packets) (fun x -> (mind, x)) in let keyword = @@ -131,7 +131,14 @@ let print_mutual_inductive env mind mib = | BiFinite -> "Variant" | CoFinite -> "CoInductive" in - let bl = Universes.universe_binders_of_global (IndRef (mind, 0)) in + let univs = + let open Univ in + if Declareops.inductive_is_polymorphic mib then + Array.to_list (Instance.to_array + (AUContext.instance (Declareops.inductive_polymorphic_context mib))) + else [] + in + let bl = Universes.universe_binders_with_opt_names (IndRef (mind, 0)) univs udecl in let sigma = Evd.from_ctx (Evd.evar_universe_context_of_binders bl) in hov 0 (Printer.pr_polymorphic (Declareops.inductive_is_polymorphic mib) ++ Printer.pr_cumulative @@ -159,7 +166,7 @@ let get_fields = in prodec_rec [] [] -let print_record env mind mib = +let print_record env mind mib udecl = let u = if Declareops.inductive_is_polymorphic mib then Univ.AUContext.instance (Declareops.inductive_polymorphic_context mib) @@ -173,7 +180,8 @@ let print_record env mind mib = let cstrtype = hnf_prod_applist env cstrtypes.(0) args in let fields = get_fields cstrtype in let envpar = push_rel_context params env in - let bl = Universes.universe_binders_of_global (IndRef (mind,0)) in + let bl = Universes.universe_binders_with_opt_names (IndRef (mind,0)) + (Array.to_list (Univ.Instance.to_array u)) udecl in let sigma = Evd.from_ctx (Evd.evar_universe_context_of_binders bl) in let keyword = let open Decl_kinds in @@ -205,11 +213,11 @@ let print_record env mind mib = sigma (instantiate_cumulativity_info cumi) ) -let pr_mutual_inductive_body env mind mib = +let pr_mutual_inductive_body env mind mib udecl = if mib.mind_record <> None && not !Flags.raw_print then - print_record env mind mib + print_record env mind mib udecl else - print_mutual_inductive env mind mib + print_mutual_inductive env mind mib udecl (** Modpaths *) @@ -237,10 +245,10 @@ let print_kn locals kn = with Not_found -> print_modpath locals kn -let nametab_register_dir mp = +let nametab_register_dir obj_mp = let id = mk_fake_top () in - let dir = DirPath.make [id] in - Nametab.push_dir (Nametab.Until 1) dir (DirModule (dir,(mp,DirPath.empty))) + let obj_dir = DirPath.make [id] in + Nametab.push_dir (Nametab.Until 1) obj_dir (DirModule { obj_dir; obj_mp; obj_sec = DirPath.empty }) (** Nota: the [global_reference] we register in the nametab below might differ from internal ones, since we cannot recreate here @@ -335,7 +343,7 @@ let print_body is_impl env mp (l,body) = | SFBmind mib -> try let env = Option.get env in - pr_mutual_inductive_body env (MutInd.make2 mp l) mib + pr_mutual_inductive_body env (MutInd.make2 mp l) mib None with e when CErrors.noncritical e -> let keyword = let open Decl_kinds in @@ -374,9 +382,12 @@ let rec print_typ_expr env mp locals mty = | MEwith(me,WithDef(idl,(c, _)))-> let env' = None in (* TODO: build a proper environment if env <> None *) let s = String.concat "." (List.map Id.to_string idl) in + (* XXX: What should env and sigma be here? *) + let env = Global.env () in + let sigma = Evd.empty in hov 2 (print_typ_expr env' mp locals me ++ spc() ++ str "with" ++ spc() ++ def "Definition"++ spc() ++ str s ++ spc() ++ str ":="++ spc() - ++ Printer.pr_lconstr c) + ++ Printer.pr_lconstr_env env sigma c) | MEwith(me,WithMod(idl,mp'))-> let s = String.concat "." (List.map Id.to_string idl) in hov 2 (print_typ_expr env mp locals me ++ spc() ++ str "with" ++ spc() ++ diff --git a/printing/printmod.mli b/printing/printmod.mli index b0bbb21e05..97ed063fe3 100644 --- a/printing/printmod.mli +++ b/printing/printmod.mli @@ -11,6 +11,8 @@ open Names (** false iff the module is an element of an open module type *) val printable_body : DirPath.t -> bool -val pr_mutual_inductive_body : Environ.env -> MutInd.t -> Declarations.mutual_inductive_body -> Pp.t +val pr_mutual_inductive_body : Environ.env -> + MutInd.t -> Declarations.mutual_inductive_body -> + Vernacexpr.univ_name_list option -> Pp.t val print_module : bool -> ModPath.t -> Pp.t val print_modtype : ModPath.t -> Pp.t diff --git a/proofs/evar_refiner.mli b/proofs/evar_refiner.mli index a0e3b718a2..d90cff5722 100644 --- a/proofs/evar_refiner.mli +++ b/proofs/evar_refiner.mli @@ -14,5 +14,5 @@ open Ltac_pretype type glob_constr_ltac_closure = ltac_var_map * glob_constr -val w_refine : evar * evar_info -> +val w_refine : Evar.t * evar_info -> glob_constr_ltac_closure -> evar_map -> evar_map diff --git a/proofs/goal.ml b/proofs/goal.ml index 19f816a019..d5bc7e0ce2 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -16,7 +16,7 @@ module NamedDecl = Context.Named.Declaration evar is defined in the current evar_map, should not be accessed. *) (* type of the goals *) -type goal = Evd.evar +type goal = Evar.t let pr_goal e = str "GOAL:" ++ Pp.int (Evar.repr e) diff --git a/proofs/goal.mli b/proofs/goal.mli index ad968cdfb3..37dd9d3c0c 100644 --- a/proofs/goal.mli +++ b/proofs/goal.mli @@ -58,7 +58,7 @@ module V82 : sig (* Principal part of the progress tactical *) val progress : goal list Evd.sigma -> goal Evd.sigma -> bool - + (* Principal part of tclNOTSAMEGOAL *) val same_goal : Evd.evar_map -> goal -> Evd.evar_map -> goal -> bool diff --git a/proofs/logic.ml b/proofs/logic.ml index 13a4e4ce31..a9ad606a03 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -11,7 +11,6 @@ open CErrors open Util open Names open Nameops -open Term open Constr open Vars open Termops diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 2d4aba17cb..6b503a0112 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -51,9 +51,8 @@ end let get_nth_V82_goal i = let p = Proof_global.give_me_the_proof () in - let { it=goals ; sigma = sigma; } = Proof.V82.subgoals p in - try - { it=(List.nth goals (i-1)) ; sigma=sigma; } + let goals,_,_,_,sigma = Proof.proof p in + try { it = List.nth goals (i-1) ; sigma } with Failure _ -> raise NoSuchGoal let get_goal_context_gen i = @@ -141,7 +140,8 @@ let build_constant_by_tactic id ctx sign ?(goal_kind = Global, false, Proof Theo let status = by tac in let _,(const,univs,_) = cook_proof () in Proof_global.discard_current (); - const, status, fst univs + let univs = UState.demote_seff_univs const univs in + const, status, univs with reraise -> let reraise = CErrors.push reraise in Proof_global.discard_current (); diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index d676a0874b..5a317a956d 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -35,11 +35,11 @@ val start_proof : val cook_this_proof : Proof_global.proof_object -> (Id.t * - (Safe_typing.private_constants Entries.definition_entry * Proof_global.proof_universes * goal_kind)) + (Safe_typing.private_constants Entries.definition_entry * UState.t * goal_kind)) val cook_proof : unit -> (Id.t * - (Safe_typing.private_constants Entries.definition_entry * Proof_global.proof_universes * goal_kind)) + (Safe_typing.private_constants Entries.definition_entry * UState.t * goal_kind)) (** {6 ... } *) (** [get_goal_context n] returns the context of the [n]th subgoal of @@ -74,7 +74,7 @@ val current_proof_statement : val solve : ?with_end_tac:unit Proofview.tactic -> Vernacexpr.goal_selector -> int option -> unit Proofview.tactic -> - Proof.proof -> Proof.proof*bool + Proof.t -> Proof.t * bool (** [by tac] applies tactic [tac] to the 1st subgoal of the current focused proof or raises a UserError if there is no focused proof or diff --git a/proofs/proof.ml b/proofs/proof.ml index e24d57f088..04e707cd66 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -98,7 +98,7 @@ let done_cond ?(loose_end=false) k = CondDone (loose_end,k) (* Subpart of the type of proofs. It contains the parts of the proof which are under control of the undo mechanism *) -type proof = { +type t = { (* Current focused proofview *) proofview: Proofview.proofview; (* Entry for the proofview *) @@ -115,6 +115,8 @@ type proof = { initial_euctx : UState.t } +type proof = t + (*** General proof functions ***) let proof p = @@ -163,6 +165,7 @@ let map_structured_proof pfts process_goal: 'a pre_goals = let rec unroll_focus pv = function | (_,_,ctx)::stk -> unroll_focus (Proofview.unfocus ctx pv) stk | [] -> pv + (* spiwack: a proof is considered completed even if its still focused, if the focus doesn't hide any goal. Unfocusing is handled in {!return}. *) @@ -391,10 +394,12 @@ let pr_proof p = (*** Compatibility layer with <=v8.2 ***) module V82 = struct let subgoals p = - Proofview.V82.goals p.proofview + let it, sigma = Proofview.proofview p.proofview in + Evd.{ it; sigma } let background_subgoals p = - Proofview.V82.goals (unroll_focus p.proofview p.focus_stack) + let it, sigma = Proofview.proofview (unroll_focus p.proofview p.focus_stack) in + Evd.{ it; sigma } let top_goal p = let { Evd.it=gls ; sigma=sigma; } = diff --git a/proofs/proof.mli b/proofs/proof.mli index 48aed8225e..0b5e771ef3 100644 --- a/proofs/proof.mli +++ b/proofs/proof.mli @@ -30,7 +30,9 @@ *) (* Type of a proof. *) -type proof +type t +type proof = t +[@@ocaml.deprecated "please use [Proof.t]"] (* Returns a stylised view of a proof for use by, for instance, ide-s. *) @@ -42,7 +44,7 @@ type proof shelf (the list of goals on the shelf), a representation of the given up goals (the list of the given up goals) and the underlying evar_map *) -val proof : proof -> +val proof : t -> Goal.goal list * (Goal.goal list * Goal.goal list) list * Goal.goal list @@ -61,27 +63,26 @@ type 'a pre_goals = { (** List of the goals that have been given up *) } -val map_structured_proof : proof -> (Evd.evar_map -> Goal.goal -> 'a) -> ('a pre_goals) +val map_structured_proof : t -> (Evd.evar_map -> Goal.goal -> 'a) -> ('a pre_goals) (*** General proof functions ***) - -val start : Evd.evar_map -> (Environ.env * EConstr.types) list -> proof -val dependent_start : Proofview.telescope -> proof -val initial_goals : proof -> (EConstr.constr * EConstr.types) list -val initial_euctx : proof -> UState.t +val start : Evd.evar_map -> (Environ.env * EConstr.types) list -> t +val dependent_start : Proofview.telescope -> t +val initial_goals : t -> (EConstr.constr * EConstr.types) list +val initial_euctx : t -> UState.t (* Returns [true] if the considered proof is completed, that is if no goal remain to be considered (this does not require that all evars have been solved). *) -val is_done : proof -> bool +val is_done : t -> bool (* Like is_done, but this time it really means done (i.e. nothing left to do) *) -val is_complete : proof -> bool +val is_complete : t -> bool (* Returns the list of partial proofs to initial goals. *) -val partial_proof : proof -> EConstr.constr list +val partial_proof : t -> EConstr.constr list -val compact : proof -> proof +val compact : t -> t (* Returns the proofs (with their type) of the initial goals. Raises [UnfinishedProof] is some goals remain to be considered. @@ -92,7 +93,7 @@ exception UnfinishedProof exception HasShelvedGoals exception HasGivenUpGoals exception HasUnresolvedEvar -val return : proof -> Evd.evar_map +val return : t -> Evd.evar_map (*** Focusing actions ***) @@ -132,7 +133,7 @@ val done_cond : ?loose_end:bool -> 'a focus_kind -> 'a focus_condition (* focus command (focuses on the [i]th subgoal) *) (* spiwack: there could also, easily be a focus-on-a-range tactic, is there a need for it? *) -val focus : 'a focus_condition -> 'a -> int -> proof -> proof +val focus : 'a focus_condition -> 'a -> int -> t -> t exception FullyUnfocused exception CannotUnfocusThisWay @@ -148,58 +149,59 @@ exception NoSuchGoals of int * int Raises [FullyUnfocused] if the proof is not focused. Raises [CannotUnfocusThisWay] if the proof the unfocusing condition is not met. *) -val unfocus : 'a focus_kind -> proof -> unit -> proof +val unfocus : 'a focus_kind -> t -> unit -> t (* [unfocused p] returns [true] when [p] is fully unfocused. *) -val unfocused : proof -> bool +val unfocused : t -> bool (* [get_at_focus k] gets the information stored at the closest focus point of kind [k]. Raises [NoSuchFocus] if there is no focus point of kind [k]. *) exception NoSuchFocus -val get_at_focus : 'a focus_kind -> proof -> 'a +val get_at_focus : 'a focus_kind -> t -> 'a (* [is_last_focus k] check if the most recent focus is of kind [k] *) -val is_last_focus : 'a focus_kind -> proof -> bool +val is_last_focus : 'a focus_kind -> t -> bool (* returns [true] if there is no goal under focus. *) -val no_focused_goal : proof -> bool +val no_focused_goal : t -> bool (*** Tactics ***) (* the returned boolean signal whether an unsafe tactic has been used. In which case it is [false]. *) val run_tactic : Environ.env -> - unit Proofview.tactic -> proof -> proof*(bool*Proofview_monad.Info.tree) + unit Proofview.tactic -> t -> t * (bool*Proofview_monad.Info.tree) -val maximal_unfocus : 'a focus_kind -> proof -> proof +val maximal_unfocus : 'a focus_kind -> t -> t (*** Commands ***) -val in_proof : proof -> (Evd.evar_map -> 'a) -> 'a +val in_proof : t -> (Evd.evar_map -> 'a) -> 'a (* Remove all the goals from the shelf and adds them at the end of the focused goals. *) -val unshelve : proof -> proof +val unshelve : t -> t -val pr_proof : proof -> Pp.t +val pr_proof : t -> Pp.t (*** Compatibility layer with <=v8.2 ***) module V82 : sig - val subgoals : proof -> Goal.goal list Evd.sigma + val subgoals : t -> Goal.goal list Evd.sigma + [@@ocaml.deprecated "Use the first and fifth argument of [Proof.proof]"] (* All the subgoals of the proof, including those which are not focused. *) - val background_subgoals : proof -> Goal.goal list Evd.sigma + val background_subgoals : t -> Goal.goal list Evd.sigma - val top_goal : proof -> Goal.goal Evd.sigma + val top_goal : t -> Goal.goal Evd.sigma (* returns the existential variable used to start the proof *) - val top_evars : proof -> Evd.evar list + val top_evars : t -> Evar.t list (* Turns the unresolved evars into goals. Raises [UnfinishedProof] if there are still unsolved goals. *) - val grab_evars : proof -> proof + val grab_evars : t -> t (* Implements the Existential command *) - val instantiate_evar : int -> Constrexpr.constr_expr -> proof -> proof + val instantiate_evar : int -> Constrexpr.constr_expr -> t -> t end diff --git a/proofs/proof_bullet.ml b/proofs/proof_bullet.ml index 4f575ab4be..2149163314 100644 --- a/proofs/proof_bullet.ml +++ b/proofs/proof_bullet.ml @@ -25,8 +25,8 @@ let pr_bullet b = type behavior = { name : string; - put : proof -> t -> proof; - suggest: proof -> Pp.t + put : Proof.t -> t -> Proof.t; + suggest: Proof.t -> Pp.t } let behaviors = Hashtbl.create 4 @@ -110,7 +110,7 @@ module Strict = struct let push (b:t) pr = focus bullet_cond (b::get_bullets pr) 1 pr - let suggest_bullet (prf : proof): suggestion = + let suggest_bullet (prf : Proof.t): suggestion = if is_done prf then ProofFinished else if not (no_focused_goal prf) then (* No suggestion if a bullet is not mandatory, look for an unfinished bullet *) @@ -137,7 +137,7 @@ module Strict = struct in loop prf - let rec pop_until (prf : proof) bul : proof = + let rec pop_until (prf : Proof.t) bul : Proof.t = let prf', b = pop prf in if bullet_eq bul b then prf' else pop_until prf' bul diff --git a/proofs/proof_bullet.mli b/proofs/proof_bullet.mli index 9e924fec97..09fcabf50a 100644 --- a/proofs/proof_bullet.mli +++ b/proofs/proof_bullet.mli @@ -12,8 +12,6 @@ (* *) (**********************************************************) -open Proof - type t = Vernacexpr.bullet (** A [behavior] is the data of a put function which @@ -22,8 +20,8 @@ type t = Vernacexpr.bullet with a name to identify the behavior. *) type behavior = { name : string; - put : proof -> t -> proof; - suggest: proof -> Pp.t + put : Proof.t -> t -> Proof.t; + suggest: Proof.t -> Pp.t } (** A registered behavior can then be accessed in Coq @@ -39,8 +37,8 @@ val register_behavior : behavior -> unit (** Handles focusing/defocusing with bullets: *) -val put : proof -> t -> proof -val suggest : proof -> Pp.t +val put : Proof.t -> t -> Proof.t +val suggest : Proof.t -> Pp.t (**********************************************************) (* *) diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index fdc9a236bf..167d6bda0d 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -68,17 +68,16 @@ let _ = (* Extra info on proofs. *) type lemma_possible_guards = int list list -type proof_universes = UState.t * Universes.universe_binders option type proof_object = { id : Names.Id.t; entries : Safe_typing.private_constants Entries.definition_entry list; persistence : Decl_kinds.goal_kind; - universes: proof_universes; + universes: UState.t; } type proof_ending = - | Admitted of Names.Id.t * Decl_kinds.goal_kind * Entries.parameter_entry * proof_universes + | Admitted of Names.Id.t * Decl_kinds.goal_kind * Entries.parameter_entry * UState.t | Proved of Vernacexpr.opacity_flag * Vernacexpr.lident option * proof_object @@ -90,12 +89,15 @@ type pstate = { terminator : proof_terminator CEphemeron.key; endline_tactic : Genarg.glob_generic_argument option; section_vars : Context.Named.t option; - proof : Proof.proof; + proof : Proof.t; strength : Decl_kinds.goal_kind; mode : proof_mode CEphemeron.key; universe_decl: Univdecls.universe_decl; } +type t = pstate list +type state = t + let make_terminator f = f let apply_terminator f = f @@ -316,10 +318,6 @@ let get_open_goals () = (List.map (fun (l1,l2) -> List.length l1 + List.length l2) gll) + List.length shelf -let constrain_variables init uctx = - let levels = Univ.Instance.levels (Univ.UContext.instance init) in - UState.constrain_variables levels uctx - type closed_proof_output = (Constr.t * Safe_typing.private_constants) list * UState.t let close_proof ~keep_body_ucst_separate ?feedback_id ~now @@ -329,10 +327,11 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now let poly = pi2 strength (* Polymorphic *) in let initial_goals = Proof.initial_goals proof in let initial_euctx = Proof.initial_euctx proof in + let constrain_variables ctx = + UState.constrain_variables (fst (UState.context_set initial_euctx)) ctx + 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. *) @@ -348,20 +347,21 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now if not (keep_body_ucst_separate || not (Safe_typing.empty_private_constants = eff)) then nf t else t - in - let used_univs_body = Univops.universes_of_constr body in - let used_univs_typ = Univops.universes_of_constr typ in + in + let env = Global.env () in + let used_univs_body = Univops.universes_of_constr env body in + let used_univs_typ = Univops.universes_of_constr env typ in if keep_body_ucst_separate || not (Safe_typing.empty_private_constants = eff) then - let initunivs = Evd.evar_context_universe_context initial_euctx in - let ctx = constrain_variables initunivs universes in + let initunivs = UState.const_univ_entry ~poly initial_euctx in + let ctx = constrain_variables 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. *) - let used_univs = Univ.LSet.union used_univs_body used_univs_typ in + let used_univs = Univ.LSet.union used_univs_body used_univs_typ in 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) + let univs = UState.check_mono_univ_decl ctx_body universe_decl in + (initunivs, typ), ((body, univs), eff) else (* 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 @@ -370,30 +370,28 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now TODO: check if restrict is really necessary now. *) let used_univs = Univ.LSet.union used_univs_body used_univs_typ in let ctx = UState.restrict universes used_univs in - let _, univs = Evd.check_univ_decl (Evd.from_ctx ctx) universe_decl in + let univs = UState.check_univ_decl ~poly ctx universe_decl in (univs, typ), ((body, Univ.ContextSet.empty), eff) in fun t p -> Future.split2 (Future.chain p (make_body t)) else fun t p -> + (* Already checked the univ_decl for the type universes when starting the proof. *) + let univctx = Entries.Monomorphic_const_entry (UState.context_set universes) in Future.from_val (univctx, nf t), Future.chain p (fun (pt,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) + let bodyunivs = constrain_variables (Future.force univs) in + let univs = UState.check_mono_univ_decl bodyunivs universe_decl in + (pt,univs),eff) in 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; @@ -405,7 +403,7 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now in let entries = Future.map2 entry_fn fpl initial_goals in { id = pid; entries = entries; persistence = strength; - universes = (universes, binders) }, + universes }, fun pr_ending -> CEphemeron.get terminator pr_ending let return_proof ?(allow_partial=false) () = @@ -466,8 +464,6 @@ module V82 = struct pid, (goals, strength) end -type state = pstate list - let freeze ~marshallable = match marshallable with | `Yes -> diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index eed62f912e..27e99f218b 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -10,6 +10,10 @@ toplevel. In particular it defines the global proof environment. *) +type t +type state = t +[@@ocaml.deprecated "please use [Proof_global.t]"] + val there_are_pending_proofs : unit -> bool val check_no_pending_proof : unit -> unit @@ -21,7 +25,7 @@ val discard_current : unit -> unit val discard_all : unit -> unit exception NoCurrentProof -val give_me_the_proof : unit -> Proof.proof +val give_me_the_proof : unit -> Proof.t (** @raise NoCurrentProof when outside proof mode. *) val compact_the_proof : unit -> unit @@ -33,18 +37,17 @@ val compact_the_proof : unit -> unit (i.e. an proof ending command) and registers the appropriate values. *) type lemma_possible_guards = int list list -type proof_universes = UState.t * Universes.universe_binders option type proof_object = { id : Names.Id.t; entries : Safe_typing.private_constants Entries.definition_entry list; persistence : Decl_kinds.goal_kind; - universes: proof_universes; + universes: UState.t; } type proof_ending = | Admitted of Names.Id.t * Decl_kinds.goal_kind * Entries.parameter_entry * - proof_universes + UState.t | Proved of Vernacexpr.opacity_flag * Vernacexpr.lident option * proof_object @@ -107,9 +110,9 @@ val get_open_goals : unit -> int no current proof. The return boolean is set to [false] if an unsafe tactic has been used. *) val with_current_proof : - (unit Proofview.tactic -> Proof.proof -> Proof.proof*'a) -> 'a + (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> 'a val simple_with_current_proof : - (unit Proofview.tactic -> Proof.proof -> Proof.proof) -> unit + (unit Proofview.tactic -> Proof.t -> Proof.t) -> unit (** Sets the tactic to be used when a tactic line is closed with [...] *) val set_endline_tactic : Genarg.glob_generic_argument -> unit @@ -129,11 +132,10 @@ module V82 : sig Decl_kinds.goal_kind) end -type state -val freeze : marshallable:[`Yes | `No | `Shallow] -> state -val unfreeze : state -> unit -val proof_of_state : state -> Proof.proof -val copy_terminators : src:state -> tgt:state -> state +val freeze : marshallable:[`Yes | `No | `Shallow] -> t +val unfreeze : t -> unit +val proof_of_state : t -> Proof.t +val copy_terminators : src:t -> tgt:t -> t (**********************************************************) diff --git a/proofs/refiner.mli b/proofs/refiner.mli index 34e517aedc..52dc8bfd8c 100644 --- a/proofs/refiner.mli +++ b/proofs/refiner.mli @@ -40,7 +40,7 @@ val tclEVARUNIVCONTEXT : UState.t -> tactic val tclPUSHCONTEXT : Evd.rigid -> Univ.ContextSet.t -> tactic -> tactic val tclPUSHEVARUNIVCONTEXT : UState.t -> tactic -val tclPUSHCONSTRAINTS : Univ.constraints -> tactic +val tclPUSHCONSTRAINTS : Univ.Constraint.t -> tactic (** [tclTHEN tac1 tac2 gls] applies the tactic [tac1] to [gls] and applies [tac2] to every resulting subgoals *) diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index a8ec4d8ca3..cab8d7b52a 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -102,9 +102,6 @@ let pf_reduce_to_atomic_ind = pf_reduce reduce_to_atomic_ind let pf_hnf_type_of gls = pf_get_type_of gls %> pf_whd_all gls -let pf_is_matching gl p c = pf_apply Constr_matching.is_matching_conv gl p c -let pf_matches gl p c = pf_apply Constr_matching.matches_conv gl p c - (********************************************) (* Definition of the most primitive tactics *) (********************************************) @@ -223,8 +220,6 @@ module New = struct let pf_hnf_type_of gl t = pf_whd_all gl (pf_get_type_of gl t) - let pf_matches gl pat t = pf_apply Constr_matching.matches_conv gl pat t - let pf_whd_all gl t = pf_apply whd_all gl t let pf_compute gl t = pf_apply compute gl t diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index d9496d2b4f..e0fb8fbc5d 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -12,9 +12,7 @@ open Environ open EConstr open Proof_type open Redexpr -open Pattern open Locus -open Ltac_pretype (** Operations for handling terms under a local typing context. *) @@ -79,10 +77,6 @@ val pf_const_value : goal sigma -> pconstant -> constr val pf_conv_x : goal sigma -> constr -> constr -> bool val pf_conv_x_leq : goal sigma -> constr -> constr -> bool -val pf_matches : goal sigma -> constr_pattern -> constr -> patvar_map -val pf_is_matching : goal sigma -> constr_pattern -> constr -> bool - - (** {6 The most primitive tactics. } *) val refiner : rule -> tactic @@ -138,8 +132,6 @@ module New : sig val pf_whd_all : 'a Proofview.Goal.t -> constr -> constr val pf_compute : 'a Proofview.Goal.t -> constr -> constr - val pf_matches : 'a Proofview.Goal.t -> constr_pattern -> constr -> patvar_map - val pf_nf_evar : 'a Proofview.Goal.t -> constr -> constr end diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index e2bce1a96c..cd22a71835 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -14,13 +14,15 @@ let stm_pr_err pp = Format.eprintf "%s] @[%a@]\n%!" (System.process_id ()) Pp.pp let stm_prerr_endline s = if !Flags.debug then begin stm_pr_err (str s) end else () -type 'a worker_status = [ `Fresh | `Old of 'a ] +type cancel_switch = bool ref module type Task = sig type task type competence + type worker_status = Fresh | Old of competence + (* Marshallable *) type request type response @@ -29,15 +31,14 @@ module type Task = sig val extra_env : unit -> string array (* run by the master, on a thread *) - val request_of_task : competence worker_status -> task -> request option - val task_match : competence worker_status -> task -> bool - val use_response : - competence worker_status -> task -> response -> - [ `Stay of competence * task list | `End ] + val request_of_task : worker_status -> task -> request option + val task_match : worker_status -> task -> bool + val use_response : worker_status -> task -> response -> + [ `Stay of competence * task list | `End ] val on_marshal_error : string -> task -> unit val on_task_cancellation_or_expiration_or_slave_death : task option -> unit val forward_feedback : Feedback.feedback -> unit - + (* run by the worker *) val perform : request -> response @@ -47,8 +48,6 @@ module type Task = sig end -type expiration = bool ref - module Make(T : Task) () = struct exception Die @@ -59,45 +58,45 @@ module Make(T : Task) () = struct type request = Request of T.request type more_data = - | MoreDataUnivLevel of Univ.Level.t list + | MoreDataUnivLevel of Universes.universe_id list let slave_respond (Request r) = let res = T.perform r in Response res exception MarshalError of string - + let marshal_to_channel oc data = Marshal.to_channel oc data []; flush oc - + let marshal_err s = raise (MarshalError s) - + let marshal_request oc (req : request) = try marshal_to_channel oc req with Failure s | Invalid_argument s | Sys_error s -> marshal_err ("marshal_request: "^s) - + let unmarshal_request ic = try (CThread.thread_friendly_input_value ic : request) with Failure s | Invalid_argument s | Sys_error s -> marshal_err ("unmarshal_request: "^s) - + let marshal_response oc (res : response) = try marshal_to_channel oc res with Failure s | Invalid_argument s | Sys_error s -> marshal_err ("marshal_response: "^s) - + let unmarshal_response ic = try (CThread.thread_friendly_input_value ic : response) with Failure s | Invalid_argument s | Sys_error s -> marshal_err ("unmarshal_response: "^s) - + let marshal_more_data oc (res : more_data) = try marshal_to_channel oc res with Failure s | Invalid_argument s | Sys_error s -> marshal_err ("marshal_more_data: "^s) - + let unmarshal_more_data ic = try (CThread.thread_friendly_input_value ic : more_data) with Failure s | Invalid_argument s | Sys_error s -> @@ -112,7 +111,7 @@ module Make(T : Task) () = struct module Model = struct type process = Worker.process - type extra = (T.task * expiration) TQueue.t + type extra = (T.task * cancel_switch) TQueue.t let spawn id = let name = Printf.sprintf "%s:%d" !T.name id in @@ -140,7 +139,7 @@ module Make(T : Task) () = struct let { WorkerPool.extra = queue; exit; cancelled } = cpanel in let exit () = report_status ~id "Dead"; exit () in let last_task = ref None in - let worker_age = ref `Fresh in + let worker_age = ref T.Fresh in let got_token = ref false in let giveback_exec_token () = if !got_token then (CoqworkmgrApi.giveback 1; got_token := false) in @@ -170,8 +169,7 @@ module Make(T : Task) () = struct | Unix.WSIGNALED sno -> Printf.sprintf "signalled(%d)" sno | Unix.WSTOPPED sno -> Printf.sprintf "stopped(%d)" sno) in let more_univs n = - CList.init n (fun _ -> - Universes.new_univ_level (Global.current_dirpath ())) in + CList.init n (fun _ -> Universes.new_univ_id ()) in let rec kill_if () = if not (Worker.is_alive proc) then () @@ -213,7 +211,7 @@ module Make(T : Task) () = struct | `Stay(competence, new_tasks) -> last_task := None; giveback_exec_token (); - worker_age := `Old competence; + worker_age := T.Old competence; add_tasks new_tasks in continue () @@ -236,7 +234,7 @@ module Make(T : Task) () = struct type queue = { active : Pool.pool; - queue : (T.task * expiration) TQueue.t; + queue : (T.task * cancel_switch) TQueue.t; cleaner : Thread.t option; } @@ -252,16 +250,16 @@ module Make(T : Task) () = struct queue; cleaner = if size > 0 then Some (Thread.create cleaner queue) else None; } - + let destroy { active; queue } = Pool.destroy active; TQueue.destroy queue let broadcast { queue } = TQueue.broadcast queue - let enqueue_task { queue; active } (t, _ as item) = + let enqueue_task { queue; active } t ~cancel_switch = stm_prerr_endline ("Enqueue task "^T.name_of_task t); - TQueue.push queue item + TQueue.push queue (t, cancel_switch) let cancel_worker { active } n = Pool.cancel n active @@ -310,7 +308,7 @@ module Make(T : Task) () = struct Marshal.to_channel oc (RespFeedback (debug_with_pid fb)) []; flush oc in ignore (Feedback.add_feeder (fun x -> slave_feeder (Option.get !slave_oc) x)); (* We ask master to allocate universe identifiers *) - Universes.set_remote_new_univ_level (bufferize (fun () -> + Universes.set_remote_new_univ_id (bufferize (fun () -> marshal_response (Option.get !slave_oc) RespGetCounterNewUnivLevel; match unmarshal_more_data (Option.get !slave_ic) with | MoreDataUnivLevel l -> l)); @@ -339,14 +337,14 @@ module Make(T : Task) () = struct let clear { queue; active } = assert(Pool.is_empty active); (* We allow that only if no slaves *) TQueue.clear queue - + let snapshot { queue; active } = List.map fst (TQueue.wait_until_n_are_waiting_then_snapshot (Pool.n_workers active) queue) let with_n_workers n f = - let q = create n in + let q = create n in try let rc = f q in destroy q; rc with e -> let e = CErrors.push e in destroy q; iraise e diff --git a/stm/asyncTaskQueue.mli b/stm/asyncTaskQueue.mli index 1044e668b6..ccd643deba 100644 --- a/stm/asyncTaskQueue.mli +++ b/stm/asyncTaskQueue.mli @@ -6,79 +6,211 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -type 'a worker_status = [ `Fresh | `Old of 'a ] +(** This file provides an API for defining and managing a queue of + tasks to be done by external workers. + A queue of items of type [task] is maintained, then for each task, + a request is generated, then sent to a worker using marshalling. + + The workers will then eventually return a result, using marshalling + again: + ____ ____ ____ ________ + | T1 | T2 | T3 | => [request ] => | Worker | + |____|____|____| <= [response] <= |________| + | Master Proc. | + \--------------/ + + Thus [request] and [response] must be safely marshallable. + + Operations for managing the task queue are provide, see below + for more details. + + *) + +(** The [Task] module type defines an abstract message-processing + queue. *) module type Task = sig + (** Main description of a task. Elements are stored in the "master" + process, and then converted into a request. + *) type task + + (** [competence] stores the information about what kind of work a + worker has completed / has available. *) type competence - (* Marshallable *) + (** A worker_status is: + + - [`Fresh] when a worker is born. + + - [`Old of competence]: When a worker ends a job it can either die + (and be replaced by a fresh new worker) or hang there as an [`Old] + worker. In such case some data can be carried by the [`Old] + constructor, typically used to implement [request_of_task]. + + This allows to implement both one-shot workers and "persistent" + ones. E.g. par: is implement using workers that don't + "reboot". Proof workers do reboot mainly because the vm has some + C state that cannot be cleared, so you have a real memory leak if + you don't reboot the worker. *) + type worker_status = Fresh | Old of competence + + (** Type of input and output data for workers. + + The data must be marshallable as it send through the network + using [Marshal] . *) type request type response - val name : string ref (* UID of the task kind, for -toploop *) + (** UID of the task kind, for -toploop *) + val name : string ref + (** Extra arguments of the task kind, for -toploop *) val extra_env : unit -> string array - (* run by the master, on a thread *) - val request_of_task : competence worker_status -> task -> request option - val task_match : competence worker_status -> task -> bool - val use_response : - competence worker_status -> task -> response -> - [ `Stay of competence * task list | `End ] + (** {5} Master API, it is run by the master, on a thread *) + + (** [request_of_task status t] takes the [status] of the worker + and a task [t] and creates the corresponding [Some request] to be + sent to the worker or it is not valid anymore [None]. *) + val request_of_task : worker_status -> task -> request option + + (** [task_match status tid] Allows to discard tasks based on the + worker status. *) + val task_match : worker_status -> task -> bool + + (** [use_response status t out] + + For a response [out] to a task [t] with [status] we can choose + to end the worker of to keep it alive with some data and + immediately inject extra tasks in the queue. + + For example, the proof worker runs a proof and finds an error, + the response signals that, e.g. + + [ReponseError {state = 34; msg = "oops"}] + + When the manager uses such a response he can tell the worker to + stay there and inject into the queue an extra task requesting + state 33 (to implement efficient proof repair). *) + val use_response : worker_status -> task -> response -> + [ `Stay of competence * task list | `End ] + + (** [on_marshal_error err_msg tid] notifies of marshaling failure. *) val on_marshal_error : string -> task -> unit + + (** [on_task_cancellation_or_expiration_or_slave_death tid] + + These functions are meant to parametrize the worker manager on + the actions to be taken when things go wrong or are cancelled + (you can kill a worker in CoqIDE, or using kill -9...) + + E.g. master can decide to inhabit the (delegate) Future.t with a + closure (to be run in master), i.e. make the document still + checkable. This is what I do for marshaling errors. *) val on_task_cancellation_or_expiration_or_slave_death : task option -> unit + + (** [forward_feedback fb] sends fb to all the workers. *) val forward_feedback : Feedback.feedback -> unit - - (* run by the worker *) + + (** {5} Worker API, it is run by worker, on a different fresh + process *) + + (** [perform in] synchronously processes a request [in] *) val perform : request -> response - (* debugging *) + (** debugging *) val name_of_task : task -> string val name_of_request : request -> string end -type expiration = bool ref +(** [cancel_switch] to be flipped to true by anyone to signal the task + is not relevant anymore. When the STM performs an undo/edit-at, it + crawls the document and flips these flags (the Qed node carries a + pointer to the flag IIRC). +*) +type cancel_switch = bool ref +(** Client-side functor. [MakeQueue T] creates a task queue for task [T] *) module MakeQueue(T : Task) () : sig + (** [queue] is the abstract queue type. *) type queue - (* Number of workers, 0 = lazy local *) + (** [create n] will initialize the queue with [n] workers. If [n] is + 0, the queue won't spawn any process, working in a lazy local + manner. [not imposed by the this API] *) val create : int -> queue + + (** [destroy q] Deallocates [q], cancelling all pending tasks. *) val destroy : queue -> unit + (** [n_workers q] returns the number of workers of [q] *) val n_workers : queue -> int - val enqueue_task : queue -> T.task * expiration -> unit + (** [enqueue_task q t ~cancel_switch] schedules [t] for execution in + [q]. [cancel_switch] can be flipped to true to cancel the task. *) + val enqueue_task : queue -> T.task -> cancel_switch:cancel_switch -> unit - (* blocking function that waits for the task queue to be empty *) + (** [join q] blocks until the task queue is empty *) val join : queue -> unit + + (** [cancel_all q] Cancels all tasks *) val cancel_all : queue -> unit + (** [cancel_worker q wid] cancels a particular worker [wid] *) val cancel_worker : queue -> WorkerPool.worker_id -> unit + (** [set_order q cmp] reorders [q] using ordering [cmp] *) val set_order : queue -> (T.task -> T.task -> int) -> unit + (** [broadcast q] + + This is nasty. Workers can be picky, e.g. pick tasks only when + they are "on screen". Of course the screen is scrolled, and that + changes the potential choice of workers to pick up a task or + not. + + This function wakes up the workers (the managers) that give a + look (again) to the tasks in the queue. + + The STM calls it when the perspective (as in PIDE) changes. + + A problem here is that why task_match has access to the + competence data in order to decide if the task is palatable to + the worker or not... such data is local to the worker (manager). + The perspective is global, so it does not quite fit this + picture. This API to make all managers reconsider the tasks in + the queue is the best I could came up with. + + This API is crucial to Coqoon (or any other UI that invokes + Stm.finish eagerly but wants the workers to "focus" on the visible + part of the document). + *) val broadcast : queue -> unit - (* Take a snapshot (non destructive but waits until all workers are - * enqueued) *) + (** [snapshot q] Takes a snapshot (non destructive but waits until + all workers are enqueued) *) val snapshot : queue -> T.task list - (* Clears the queue, only if the worker prool is empty *) - val clear : queue -> unit - - (* create a queue, run the function, destroy the queue. - * the user should call join *) + (** [clear q] Clears [q], only if the worker prool is empty *) + val clear : queue -> unit + + (** [with_n_workers n f] create a queue, run the function, destroy + the queue. The user should call join *) val with_n_workers : int -> (queue -> 'a) -> 'a end +(** Server-side functor. [MakeWorker T] creates the server task + dispatcher. *) module MakeWorker(T : Task) () : sig - val main_loop : unit -> unit + (** [init_stdout ()] is called at [Coqtop.toploop_init] time. *) val init_stdout : unit -> unit - + + (** [main_loop ()] is called at [Coqtop.toploop_run] time. *) + val main_loop : unit -> unit + end diff --git a/stm/proofBlockDelimiter.ml b/stm/proofBlockDelimiter.ml index 01b75e4964..77642946cd 100644 --- a/stm/proofBlockDelimiter.ml +++ b/stm/proofBlockDelimiter.ml @@ -46,7 +46,7 @@ let simple_goal sigma g gs = let is_focused_goal_simple ~doc id = match state_of_id ~doc id with | `Expired | `Error _ | `Valid None -> `Not - | `Valid (Some { Vernacentries.proof }) -> + | `Valid (Some { Vernacstate.proof }) -> let proof = Proof_global.proof_of_state proof in let focused, r1, r2, r3, sigma = Proof.proof proof in let rest = List.(flatten (map (fun (x,y) -> x @ y) r1)) @ r2 @ r3 in diff --git a/stm/stm.ml b/stm/stm.ml index b394c3a135..0dbe168b73 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -25,14 +25,14 @@ open Vernacexpr (* Protect against state changes *) let stm_purify f x = - let st = Vernacentries.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state `No in try let res = f x in - Vernacentries.unfreeze_interp_state st; + Vernacstate.unfreeze_interp_state st; res with e -> let e = CErrors.push e in - Vernacentries.unfreeze_interp_state st; + Vernacstate.unfreeze_interp_state st; Exninfo.iraise e let execution_error ?loc state_id msg = @@ -48,7 +48,7 @@ let state_computed, state_computed_hook = Hook.make let state_ready, state_ready_hook = Hook.make ~default:(fun state_id -> ()) () -let forward_feedback, forward_feedback_hook = +let forward_feedback, forward_feedback_hook = let m = Mutex.create () in Hook.make ~default:(function | { doc_id = did; span_id = id; route; contents } -> @@ -108,7 +108,6 @@ module Vcs_ = Vcs.Make(Stateid.Self) type future_proof = Proof_global.closed_proof_output Future.computation type proof_mode = string type depth = int -type cancel_switch = bool ref type branch_type = [ `Master | `Proof of proof_mode * depth @@ -122,14 +121,14 @@ type cmd_t = { cids : Names.Id.t list; cblock : proof_block_name option; cqueue : [ `MainQueue - | `TacQueue of solving_tac * anon_abstracting_tac * cancel_switch - | `QueryQueue of cancel_switch + | `TacQueue of solving_tac * anon_abstracting_tac * AsyncTaskQueue.cancel_switch + | `QueryQueue of AsyncTaskQueue.cancel_switch | `SkipQueue ] } type fork_t = aast * Vcs_.Branch.t * Vernacexpr.opacity_guarantee * Names.Id.t list type qed_t = { qast : aast; keep : vernac_qed_type; - mutable fproof : (future_proof * cancel_switch) option; + mutable fproof : (future_proof * AsyncTaskQueue.cancel_switch) option; brname : Vcs_.Branch.t; brinfo : branch_type Vcs_.branch_info } @@ -159,13 +158,14 @@ let mkTransCmd cast cids ceff cqueue = Cmd { ctac = false; cast; cblock = None; cqueue; cids; ceff } (* Parts of the system state that are morally part of the proof state *) -let summary_pstate = [ Evarutil.meta_counter_summary_name; - Evd.evar_counter_summary_name; - "program-tcc-table" ] +let summary_pstate = Evarutil.meta_counter_summary_tag, + Evd.evar_counter_summary_tag, + Obligations.program_tcc_summary_tag + type cached_state = | Empty | Error of Exninfo.iexn - | Valid of Vernacentries.interp_state + | Valid of Vernacstate.t type branch = Vcs_.Branch.t * branch_type Vcs_.branch_info type backup = { mine : branch; others : branch list } @@ -318,7 +318,7 @@ module VCS : sig (* cuts from start -> stop, raising Expired if some nodes are not there *) val slice : block_start:id -> block_stop:id -> vcs val nodes_in_slice : block_start:id -> block_stop:id -> Stateid.t list - + val create_proof_task_box : id list -> qed:id -> block_start:id -> unit val create_proof_block : static_block_declaration -> string -> unit val box_of : id -> box list @@ -367,7 +367,7 @@ end = struct (* {{{ *) | Noop -> " " | Alias (id,_) -> sprintf "Alias(%s)" (Stateid.to_string id) | Qed { qast } -> Pp.string_of_ppcmds (pr_ast qast) in - let is_green id = + let is_green id = match get_info vcs id with | Some { state = Valid _ } -> true | _ -> false in @@ -435,7 +435,7 @@ end = struct (* {{{ *) let outerboxes boxes = List.filter (fun b -> not (List.exists (fun b1 -> - not (same_box b1 b) && contains b1 b) boxes) + not (same_box b1 b) && contains b1 b) boxes) ) boxes in let rec rec_print b = boxes := CList.remove same_box b !boxes; @@ -565,7 +565,7 @@ end = struct (* {{{ *) let id = new_node () in merge id ~ours:(Sideff action) ~into:b Branch.master) (List.filter (fun b -> not (Branch.equal b Branch.master)) (branches ())) - + let visit id = Vcs_aux.visit !vcs id let nodes_in_slice ~block_start ~block_stop = @@ -664,7 +664,7 @@ end = struct (* {{{ *) val command : now:bool -> (unit -> unit) -> unit end = struct - + let m = Mutex.create () let c = Condition.create () let job = ref None @@ -735,16 +735,16 @@ module State : sig val exn_on : Stateid.t -> valid:Stateid.t -> Exninfo.iexn -> Exninfo.iexn (* to send states across worker/master *) - val get_cached : Stateid.t -> Vernacentries.interp_state - val same_env : Vernacentries.interp_state -> Vernacentries.interp_state -> bool + val get_cached : Stateid.t -> Vernacstate.t + val same_env : Vernacstate.t -> Vernacstate.t -> bool type proof_part type partial_state = - [ `Full of Vernacentries.interp_state + [ `Full of Vernacstate.t | `ProofOnly of Stateid.t * proof_part ] - val proof_part_of_frozen : Vernacentries.interp_state -> proof_part + val proof_part_of_frozen : Vernacstate.t -> proof_part val assign : Stateid.t -> partial_state -> unit (* Handlers for initial state, prior to document creation. *) @@ -757,26 +757,30 @@ module State : sig end = struct (* {{{ *) - open Vernacentries - (* cur_id holds Stateid.dummy in case the last attempt to define a state * failed, so the global state may contain garbage *) let cur_id = ref Stateid.dummy let fix_exn_ref = ref (fun x -> x) type proof_part = - Proof_global.state * Summary.frozen_bits (* only meta counters *) + Proof_global.t * + int * (* Evarutil.meta_counter_summary_tag *) + int * (* Evd.evar_counter_summary_tag *) + Obligations.program_info Names.Id.Map.t (* Obligations.program_tcc_summary_tag *) type partial_state = - [ `Full of Vernacentries.interp_state + [ `Full of Vernacstate.t | `ProofOnly of Stateid.t * proof_part ] - let proof_part_of_frozen { Vernacentries.proof; system } = + let proof_part_of_frozen { Vernacstate.proof; system } = + let st = States.summary_of_state system in proof, - Summary.project_summary (States.summary_of_state system) summary_pstate + Summary.project_from_summary st Util.(pi1 summary_pstate), + Summary.project_from_summary st Util.(pi2 summary_pstate), + Summary.project_from_summary st Util.(pi3 summary_pstate) let freeze marshallable id = - VCS.set_state id (Valid (Vernacentries.freeze_interp_state marshallable)) + VCS.set_state id (Valid (Vernacstate.freeze_interp_state marshallable)) let freeze_invalid id iexn = VCS.set_state id (Error iexn) @@ -800,7 +804,7 @@ end = struct (* {{{ *) let install_cached id = match VCS.get_info id with | { state = Valid s } -> - Vernacentries.unfreeze_interp_state s; + Vernacstate.unfreeze_interp_state s; cur_id := id | { state = Error ie } -> @@ -819,6 +823,7 @@ end = struct (* {{{ *) with VCS.Expired -> anomaly Pp.(str "not a cached state (expired).") let assign id what = + let open Vernacstate in if VCS.get_state id <> Empty then () else try match what with | `Full s -> @@ -826,22 +831,27 @@ end = struct (* {{{ *) try let prev = (VCS.visit id).next in if is_cached_and_valid prev - then { s with Vernacentries.proof = + then { s with proof = Proof_global.copy_terminators ~src:(get_cached prev).proof ~tgt:s.proof } else s with VCS.Expired -> s in VCS.set_state id (Valid s) - | `ProofOnly(ontop,(pstate,counters)) -> + | `ProofOnly(ontop,(pstate,c1,c2,c3)) -> if is_cached_and_valid ontop then let s = get_cached ontop in let s = { s with proof = Proof_global.copy_terminators ~src:s.proof ~tgt:pstate } in let s = { s with system = States.replace_summary s.system - (Summary.surgery_summary - (States.summary_of_state s.system) - counters) } in + begin + let st = States.summary_of_state s.system in + let st = Summary.modify_summary st Util.(pi1 summary_pstate) c1 in + let st = Summary.modify_summary st Util.(pi2 summary_pstate) c2 in + let st = Summary.modify_summary st Util.(pi3 summary_pstate) c3 in + st + end + } in VCS.set_state id (Valid s) with VCS.Expired -> () @@ -854,12 +864,12 @@ end = struct (* {{{ *) execution_error ?loc id (iprint (e, info)); (e, Stateid.add info ~valid id) - let same_env { system = s1 } { system = s2 } = + let same_env { Vernacstate.system = s1 } { Vernacstate.system = s2 } = let s1 = States.summary_of_state s1 in - let e1 = Summary.project_summary s1 [Global.global_env_summary_name] in + let e1 = Summary.project_from_summary s1 Global.global_env_summary_tag in let s2 = States.summary_of_state s2 in - let e2 = Summary.project_summary s2 [Global.global_env_summary_name] in - Summary.pointer_equal e1 e2 + let e2 = Summary.project_from_summary s2 Global.global_env_summary_tag in + e1 == e2 let define ?safe_id ?(redefine=false) ?(cache=`No) ?(feedback_processed=true) f id @@ -902,11 +912,11 @@ end = struct (* {{{ *) let init_state = ref None let register_root_state () = - init_state := Some (Vernacentries.freeze_interp_state `No) + init_state := Some (Vernacstate.freeze_interp_state `No) let restore_root_state () = cur_id := Stateid.dummy; - Vernacentries.unfreeze_interp_state (Option.get !init_state); + Vernacstate.unfreeze_interp_state (Option.get !init_state); end (* }}} *) @@ -973,7 +983,7 @@ let get_script prf = find ((x.expr, (VCS.get_info id).n_goals)::acc) view.next | `Sideff (CherryPickEnv, id) -> find acc id | `Cmd {cast = x; ctac} when ctac -> (* skip non-tactics *) - find ((x.expr, (VCS.get_info id).n_goals)::acc) view.next + find ((x.expr, (VCS.get_info id).n_goals)::acc) view.next | `Cmd _ -> find acc view.next | `Alias (id,_) -> find acc id | `Fork _ -> find acc view.next @@ -1001,7 +1011,7 @@ end (* Wrapper for Vernacentries.interp to set the feedback id *) (* It is currently called 19 times, this number should be certainly reduced... *) -let stm_vernac_interp ?proof ?route id st { verbose; loc; expr } : Vernacentries.interp_state = +let stm_vernac_interp ?proof ?route id st { verbose; loc; expr } : Vernacstate.t = (* The Stm will gain the capability to interpret commmads affecting the whole document state, such as backtrack, etc... so we start to design the stm command interpreter now *) @@ -1025,7 +1035,7 @@ let stm_vernac_interp ?proof ?route id st { verbose; loc; expr } : Vernacentries | VernacShow ShowScript -> ShowScript.show_script (); st | expr -> stm_pperr_endline Pp.(fun () -> str "interpreting " ++ Ppvernac.pr_vernac expr); - try Vernacentries.interp ?verbosely:(Some verbose) ?proof st (Loc.tag ?loc expr) + try Vernacentries.interp ?verbosely:(Some verbose) ?proof ~st (Loc.tag ?loc expr) with e -> let e = CErrors.push e in Exninfo.iraise Hooks.(call_process_error_once e) @@ -1139,7 +1149,7 @@ end = struct (* {{{ *) let m = match e with VernacUndoTo m -> m | _ -> 0 in let id = VCS.get_branch_pos (VCS.current_branch ()) in let vcs = - match (VCS.get_info id).vcs_backup with + match (VCS.get_info id).vcs_backup with | None, _ -> anomaly Pp.(str"Backtrack: tip with no vcs_backup.") | Some vcs, _ -> vcs in let cb, _ = @@ -1192,7 +1202,7 @@ let record_pb_time ?loc proof_name time = Aux_file.record_in_aux_at proof_name proof_build_time; hints := Aux_file.set !hints proof_name proof_build_time end - + exception RemoteException of Pp.t let _ = CErrors.register_handler (function | RemoteException ppcmd -> ppcmd @@ -1249,7 +1259,7 @@ let is_block_name_enabled name = | `Only l -> List.mem name l let detect_proof_block id name = - let name = match name with None -> "indent" | Some x -> x in + let name = match name with None -> "indent" | Some x -> x in if is_block_name_enabled name && (Flags.async_proofs_is_master () || Flags.async_proofs_is_worker ()) then ( @@ -1272,7 +1282,7 @@ let detect_proof_block id name = (* Unused module warning doesn't understand [module rec] *) [@@@ocaml.warning "-60"] module rec ProofTask : sig - + type competence = Stateid.t list type task_build_proof = { t_exn_info : Stateid.t * Stateid.t; @@ -1295,8 +1305,8 @@ module rec ProofTask : sig include AsyncTaskQueue.Task with type task := task - and type competence := competence - and type request := request + and type competence := competence + and type request := request val build_proof_here : ?loc:Loc.t -> @@ -1305,7 +1315,7 @@ module rec ProofTask : sig Proof_global.closed_proof_output Future.computation (* If set, only tasks overlapping with this list are processed *) - val set_perspective : Stateid.t list -> unit + val set_perspective : Stateid.t list -> unit end = struct (* {{{ *) @@ -1327,10 +1337,12 @@ end = struct (* {{{ *) | BuildProof of task_build_proof | States of Stateid.t list + type worker_status = Fresh | Old of competence + type request = | ReqBuildProof of (Future.UUID.t,VCS.vcs) Stateid.request * bool * competence | ReqStates of Stateid.t list - + type error = { e_error_at : Stateid.t; e_safe_id : Stateid.t; @@ -1350,10 +1362,10 @@ end = struct (* {{{ *) let task_match age t = match age, t with - | `Fresh, BuildProof { t_states } -> + | Fresh, BuildProof { t_states } -> not !Flags.async_proofs_full || List.exists (fun x -> CList.mem_f Stateid.equal x !perspective) t_states - | `Old my_states, States l -> + | Old my_states, States l -> List.for_all (fun x -> CList.mem_f Stateid.equal x my_states) l | _ -> false @@ -1369,7 +1381,7 @@ end = struct (* {{{ *) | BuildProof { t_exn_info;t_start;t_stop;t_loc;t_uuid;t_name;t_states;t_drop } -> - assert(age = `Fresh); + assert(age = Fresh); try Some (ReqBuildProof ({ Stateid.exn_info = t_exn_info; stop = t_stop; @@ -1379,11 +1391,11 @@ end = struct (* {{{ *) name = t_name }, t_drop, t_states)) with VCS.Expired -> None - let use_response (s : competence AsyncTaskQueue.worker_status) t r = + let use_response (s : worker_status) t r = match s, t, r with - | `Old c, States _, RespStates l -> + | Old c, States _, RespStates l -> List.iter (fun (id,s) -> State.assign id s) l; `End - | `Fresh, BuildProof { t_assign; t_loc; t_name; t_states; t_drop }, + | Fresh, BuildProof { t_assign; t_loc; t_name; t_states; t_drop }, RespBuiltProof (pl, time) -> feedback (InProgress ~-1); t_assign (`Val pl); @@ -1391,7 +1403,7 @@ end = struct (* {{{ *) if !Flags.async_proofs_full || t_drop then `Stay(t_states,[States t_states]) else `End - | `Fresh, BuildProof { t_assign; t_loc; t_name; t_states }, + | Fresh, BuildProof { t_assign; t_loc; t_name; t_states }, RespError { e_error_at; e_safe_id = valid; e_msg; e_safe_states } -> feedback (InProgress ~-1); let info = Stateid.add ~valid Exninfo.null e_error_at in @@ -1437,19 +1449,19 @@ end = struct (* {{{ *) * a bad fixpoint *) let fix_exn = Future.fix_exn_of future_proof in (* STATE: We use the current installed imperative state *) - let st = Vernacentries.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state `No in if not drop then begin let checked_proof = Future.chain future_proof (fun p -> (* Unfortunately close_future_proof and friends are not pure so we need to set the state manually here *) - Vernacentries.unfreeze_interp_state st; + Vernacstate.unfreeze_interp_state st; let pobject, _ = Proof_global.close_future_proof ~feedback_id:stop (Future.from_val ~fix_exn p) in let terminator = (* The one sent by master is an InvalidKey *) Lemmas.(standard_proof_terminator [] (mk_hook (fun _ _ -> ()))) in - let st = Vernacentries.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state `No in stm_vernac_interp stop ~proof:(pobject, terminator) st { verbose = false; loc; indentation = 0; strlen = 0; @@ -1457,7 +1469,7 @@ end = struct (* {{{ *) ignore(Future.join checked_proof); end; (* STATE: Restore the state XXX: handle exn *) - Vernacentries.unfreeze_interp_state st; + Vernacstate.unfreeze_interp_state st; RespBuiltProof(proof,time) with | e when CErrors.noncritical e || e = Stack_overflow -> @@ -1478,7 +1490,7 @@ end = struct (* {{{ *) | VtProofStep _, _ -> true | _ -> false in - let initial = + let initial = let rec aux id = try match VCS.visit id with { next } -> aux next with VCS.Expired -> id in @@ -1491,7 +1503,7 @@ end = struct (* {{{ *) then Some (prev, State.get_cached prev, step) else None with VCS.Expired -> None in - let this = + let this = if State.is_cached_and_valid id then Some (State.get_cached id) else None in match prev, this with | _, None -> None @@ -1533,11 +1545,11 @@ and Slaves : sig val build_proof : ?loc:Loc.t -> drop_pt:bool -> exn_info:(Stateid.t * Stateid.t) -> block_start:Stateid.t -> block_stop:Stateid.t -> - name:string -> future_proof * cancel_switch + name:string -> future_proof * AsyncTaskQueue.cancel_switch (* blocking function that waits for the task queue to be empty *) val wait_all_done : unit -> unit - + (* initialize the whole machinery (optional) *) val init : unit -> unit @@ -1559,7 +1571,7 @@ and Slaves : sig end = struct (* {{{ *) module TaskQueue = AsyncTaskQueue.MakeQueue(ProofTask) () - + let queue = ref None let init () = if Flags.async_proofs_is_master () then @@ -1598,7 +1610,7 @@ end = struct (* {{{ *) * => takes nothing from the itermediate states. *) (* STATE We use the state resulting from reaching start. *) - let st = Vernacentries.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state `No in ignore(stm_vernac_interp stop ~proof st { verbose = false; loc; indentation = 0; strlen = 0; expr = (VernacEndProof (Proved (Opaque,None))) }); @@ -1614,8 +1626,8 @@ end = struct (* {{{ *) | Some (_, cur) -> match VCS.visit cur with | { step = `Cmd { cast = { loc } } } - | { step = `Fork (( { loc }, _, _, _), _) } - | { step = `Qed ( { qast = { loc } }, _) } + | { step = `Fork (( { loc }, _, _, _), _) } + | { step = `Qed ( { qast = { loc } }, _) } | { step = `Sideff (ReplayCommand { loc }, _) } -> let start, stop = Option.cata Loc.unloc (0,0) loc in msg_error Pp.( @@ -1665,7 +1677,7 @@ end = struct (* {{{ *) u.(bucket) <- uc; p.(bucket) <- pr; u, Univ.ContextSet.union cst extra, false - + let check_task name l i = match check_task_aux "" name l i with | `OK _ | `OK_ADMITTED -> true @@ -1710,11 +1722,11 @@ end = struct (* {{{ *) t_exn_info; t_start = block_start; t_stop = block_stop; t_drop = drop_pt; t_assign = assign; t_loc = loc; t_uuid; t_name = pname; t_states = VCS.nodes_in_slice ~block_start ~block_stop }) in - TaskQueue.enqueue_task (Option.get !queue) (task,cancel_switch); + TaskQueue.enqueue_task (Option.get !queue) task ~cancel_switch; f, cancel_switch end else ProofTask.build_proof_here ?loc ~drop_pt t_exn_info block_stop, cancel_switch - else + else let f, t_assign = Future.create_delegate ~name:pname (State.exn_on id ~valid) in let t_uuid = Future.uuid f in feedback (InProgress 1); @@ -1722,7 +1734,7 @@ end = struct (* {{{ *) t_exn_info; t_start = block_start; t_stop = block_stop; t_assign; t_drop = drop_pt; t_loc = loc; t_uuid; t_name = pname; t_states = VCS.nodes_in_slice ~block_start ~block_stop }) in - TaskQueue.enqueue_task (Option.get !queue) (task,cancel_switch); + TaskQueue.enqueue_task (Option.get !queue) task ~cancel_switch; f, cancel_switch let wait_all_done () = TaskQueue.join (Option.get !queue) @@ -1736,7 +1748,7 @@ end = struct (* {{{ *) let reqs = CList.map_filter ProofTask.(fun x -> - match request_of_task `Fresh x with + match request_of_task Fresh x with | Some (ReqBuildProof (r, b, _)) -> Some(r, b) | _ -> None) tasks in @@ -1757,14 +1769,14 @@ and TacTask : sig t_ast : int * aast; t_goal : Goal.goal; t_kill : unit -> unit; - t_name : string } + t_name : string } include AsyncTaskQueue.Task with type task := task end = struct (* {{{ *) type output = (Constr.constr * UState.t) option - + let forward_feedback msg = Hooks.(call forward_feedback msg) type task = { @@ -1774,7 +1786,7 @@ end = struct (* {{{ *) t_ast : int * aast; t_goal : Goal.goal; t_kill : unit -> unit; - t_name : string } + t_name : string } type request = { r_state : Stateid.t; @@ -1792,6 +1804,8 @@ end = struct (* {{{ *) let name = ref "tacworker" let extra_env () = [||] type competence = unit + type worker_status = Fresh | Old of competence + let task_match _ _ = true (* run by the master, on a thread *) @@ -1800,13 +1814,13 @@ end = struct (* {{{ *) r_state = t_state; r_state_fb = t_state_fb; r_document = - if age <> `Fresh then None + if age <> Fresh then None else Some (VCS.slice ~block_start:t_state ~block_stop:t_state); r_ast = t_ast; r_goal = t_goal; r_name = t_name } with VCS.Expired -> None - + let use_response _ { t_assign; t_state; t_state_fb; t_kill } resp = match resp with | RespBuiltSubProof o -> t_assign (`Val (Some o)); `Stay ((),[]) @@ -1819,7 +1833,7 @@ end = struct (* {{{ *) t_assign (`Exn e); t_kill (); `Stay ((),[]) - + let on_marshal_error err { t_name } = stm_pr_err ("Fatal marshal error: " ^ t_name ); flush_all (); exit 1 @@ -1827,7 +1841,7 @@ end = struct (* {{{ *) let on_task_cancellation_or_expiration_or_slave_death = function | Some { t_kill } -> t_kill () | _ -> () - + let command_focus = Proof.new_focus_kind () let focus_cond = Proof.no_cond command_focus @@ -1855,7 +1869,7 @@ end = struct (* {{{ *) * => captures state id in a future closure, which will discard execution state but for the proof + univs. *) - let st = Vernacentries.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state `No in ignore(stm_vernac_interp r_state_fb st ast); let _,_,_,_,sigma = Proof.proof (Proof_global.give_me_the_proof ()) in match Evd.(evar_body (find sigma r_goal)) with @@ -1872,21 +1886,20 @@ end = struct (* {{{ *) let name_of_task { t_name } = t_name let name_of_request { r_name } = r_name - + end (* }}} *) and Partac : sig val vernac_interp : - solve:bool -> abstract:bool -> cancel_switch -> - int -> Stateid.t -> Stateid.t -> aast -> - unit + solve:bool -> abstract:bool -> cancel_switch:AsyncTaskQueue.cancel_switch -> + int -> Stateid.t -> Stateid.t -> aast -> unit end = struct (* {{{ *) - + module TaskQueue = AsyncTaskQueue.MakeQueue(TacTask) () - let vernac_interp ~solve ~abstract cancel nworkers safe_id id + let vernac_interp ~solve ~abstract ~cancel_switch nworkers safe_id id { indentation; verbose; loc; expr = e; strlen } = let e, time, fail = @@ -1895,7 +1908,7 @@ end = struct (* {{{ *) | VernacRedirect (_,(_,e)) -> find ~time ~fail e | VernacFail e -> find ~time ~fail:true e | e -> e, time, fail in find ~time:false ~fail:false e in - let st = Vernacentries.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state `No in Vernacentries.with_fail st fail (fun () -> (if time then System.with_time !Flags.time else (fun x -> x)) (fun () -> ignore(TaskQueue.with_n_workers nworkers (fun queue -> @@ -1910,10 +1923,10 @@ end = struct (* {{{ *) let t_ast = (i, { indentation; verbose; loc; expr = e; strlen }) in let t_name = Goal.uid g in TaskQueue.enqueue_task queue - ({ t_state = safe_id; t_state_fb = id; + { t_state = safe_id; t_state_fb = id; t_assign = assign; t_ast; t_goal = g; t_name; - t_kill = (fun () -> if solve then TaskQueue.cancel_all queue) }, - cancel); + t_kill = (fun () -> if solve then TaskQueue.cancel_all queue) } + ~cancel_switch; g,f) 1 goals in TaskQueue.join queue; @@ -1932,9 +1945,10 @@ end = struct (* {{{ *) let open Notations in match Future.join f with | Some (pt, uc) -> + let sigma, env = Pfedit.get_current_context () in stm_pperr_endline (fun () -> hov 0 ( str"g=" ++ int (Evar.repr gid) ++ spc () ++ - str"t=" ++ (Printer.pr_constr pt) ++ spc () ++ + str"t=" ++ (Printer.pr_constr_env env sigma pt) ++ spc () ++ str"uc=" ++ Termops.pr_evar_universe_context uc)); (if abstract then Tactics.tclABSTRACT None else (fun x -> x)) (V82.tactic (Refiner.tclPUSHEVARUNIVCONTEXT uc) <*> @@ -1944,7 +1958,7 @@ end = struct (* {{{ *) end) in Proof.run_tactic (Global.env()) assign_tac p)))) ()) - + end (* }}} *) and QueryTask : sig @@ -1953,10 +1967,10 @@ and QueryTask : sig include AsyncTaskQueue.Task with type task := task end = struct (* {{{ *) - + type task = { t_where : Stateid.t; t_for : Stateid.t ; t_what : aast } - + type request = { r_where : Stateid.t ; r_for : Stateid.t ; r_what : aast; r_doc : VCS.vcs } type response = unit @@ -1964,6 +1978,8 @@ end = struct (* {{{ *) let name = ref "queryworker" let extra_env _ = [||] type competence = unit + type worker_status = Fresh | Old of competence + let task_match _ _ = true let request_of_task _ { t_where; t_what; t_for } = @@ -1973,7 +1989,7 @@ end = struct (* {{{ *) r_doc = VCS.slice ~block_start:t_where ~block_stop:t_where; r_what = t_what } with VCS.Expired -> None - + let use_response _ _ _ = `End let on_marshal_error _ _ = @@ -1981,7 +1997,7 @@ end = struct (* {{{ *) flush_all (); exit 1 let on_task_cancellation_or_expiration_or_slave_death _ = () - + let forward_feedback msg = Hooks.(call forward_feedback msg) let perform { r_where; r_doc; r_what; r_for } = @@ -1989,7 +2005,7 @@ end = struct (* {{{ *) VCS.print (); Reach.known_state ~cache:`No r_where; (* STATE *) - let st = Vernacentries.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state `No in try (* STATE SPEC: * - start: r_where @@ -2001,16 +2017,16 @@ end = struct (* {{{ *) let e = CErrors.push e in let msg = iprint e in feedback ~id:r_for (Message (Error, None, msg)) - + let name_of_task { t_what } = string_of_ppcmds (pr_ast t_what) let name_of_request { r_what } = string_of_ppcmds (pr_ast r_what) end (* }}} *) -and Query : sig +and Query : sig val init : unit -> unit - val vernac_interp : cancel_switch -> Stateid.t -> Stateid.t -> aast -> unit + val vernac_interp : cancel_switch:AsyncTaskQueue.cancel_switch -> Stateid.t -> Stateid.t -> aast -> unit end = struct (* {{{ *) @@ -2018,10 +2034,10 @@ end = struct (* {{{ *) let queue = ref None - let vernac_interp switch prev id q = + let vernac_interp ~cancel_switch prev id q = assert(TaskQueue.n_workers (Option.get !queue) > 0); TaskQueue.enqueue_task (Option.get !queue) - QueryTask.({ t_where = prev; t_for = id; t_what = q }, switch) + QueryTask.({ t_where = prev; t_for = id; t_what = q }) ~cancel_switch let init () = queue := Some (TaskQueue.create (if !Flags.async_proofs_full then 1 else 0)) @@ -2036,8 +2052,6 @@ and Reach : sig end = struct (* {{{ *) -let pstate = summary_pstate - let async_policy () = let open Flags in if is_universe_polymorphism () then false @@ -2050,7 +2064,7 @@ let delegate name = get_hint_bp_time name >= !Flags.async_proofs_delegation_threshold || VCS.is_vio_doc () || !Flags.async_proofs_full - + let warn_deprecated_nested_proofs = CWarnings.create ~name:"deprecated-nested-proofs" ~category:"deprecated" (fun () -> @@ -2065,6 +2079,7 @@ 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,_)) -> true | VernacTime (_, e) -> is_defined_expr e | VernacRedirect (_, (_, e)) -> is_defined_expr e | VernacTimeout (_, e) -> is_defined_expr e @@ -2175,7 +2190,7 @@ let log_processing_sync id name reason = log_string Printf.(sprintf let wall_clock_last_fork = ref 0.0 let known_state ?(redefine_qed=false) ~cache id = - + let error_absorbing_tactic id blockname exn = (* We keep the static/dynamic part of block detection separate, since the static part could be performed earlier. As of today there is @@ -2203,7 +2218,7 @@ let known_state ?(redefine_qed=false) ~cache id = Proofview.give_up else Proofview.tclUNIT () end in match (VCS.get_info base_state).state with - | Valid { Vernacentries.proof } -> + | Valid { Vernacstate.proof } -> Proof_global.unfreeze proof; Proof_global.with_current_proof (fun _ p -> feedback ~id:id Feedback.AddedAxiom; @@ -2213,7 +2228,7 @@ let known_state ?(redefine_qed=false) ~cache id = * - end : maybe after recovery command. *) (* STATE: We use an updated state with proof *) - let st = Vernacentries.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state `No in Option.iter (fun expr -> ignore(stm_vernac_interp id st { verbose = true; loc = None; expr; indentation = 0; strlen = 0 } )) @@ -2249,10 +2264,14 @@ let known_state ?(redefine_qed=false) ~cache id = (* ugly functions to process nested lemmas, i.e. hard to reproduce * side effects *) let cherry_pick_non_pstate () = - Summary.freeze_summary ~marshallable:`No ~complement:true pstate, - Lib.freeze ~marshallable:`No in + let st = Summary.freeze_summaries ~marshallable:`No in + let st = Summary.remove_from_summary st Util.(pi1 summary_pstate) in + let st = Summary.remove_from_summary st Util.(pi2 summary_pstate) in + let st = Summary.remove_from_summary st Util.(pi3 summary_pstate) in + st, Lib.freeze ~marshallable:`No in + let inject_non_pstate (s,l) = - Summary.unfreeze_summary s; Lib.unfreeze l; update_global_env () + Summary.unfreeze_summaries ~partial:true s; Lib.unfreeze l; update_global_env () in let rec pure_cherry_pick_non_pstate safe_id id = stm_purify (fun id -> @@ -2277,23 +2296,23 @@ let known_state ?(redefine_qed=false) ~cache id = ), cache, true | `Cmd { cast = x; cqueue = `SkipQueue } -> (fun () -> reach view.next), cache, true - | `Cmd { cast = x; cqueue = `TacQueue (solve,abstract,cancel); cblock } -> + | `Cmd { cast = x; cqueue = `TacQueue (solve,abstract,cancel_switch); cblock } -> (fun () -> resilient_tactic id cblock (fun () -> reach ~cache:`Shallow view.next; - Partac.vernac_interp ~solve ~abstract - cancel !Flags.async_proofs_n_tacworkers view.next id x) + Partac.vernac_interp ~solve ~abstract ~cancel_switch + !Flags.async_proofs_n_tacworkers view.next id x) ), cache, true - | `Cmd { cast = x; cqueue = `QueryQueue cancel } + | `Cmd { cast = x; cqueue = `QueryQueue cancel_switch } when Flags.async_proofs_is_master () -> (fun () -> reach view.next; - Query.vernac_interp cancel view.next id x + Query.vernac_interp ~cancel_switch view.next id x ), cache, false | `Cmd { cast = x; ceff = eff; ctac = true; cblock } -> (fun () -> resilient_tactic id cblock (fun () -> reach view.next; (* State resulting from reach *) - let st = Vernacentries.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state `No in ignore(stm_vernac_interp id st x) ); if eff then update_global_env () @@ -2303,13 +2322,13 @@ let known_state ?(redefine_qed=false) ~cache id = | Flags.APon | Flags.APonLazy -> resilient_command reach view.next | Flags.APoff -> reach view.next); - let st = Vernacentries.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state `No in ignore(stm_vernac_interp id st x); if eff then update_global_env () ), (if eff then `Yes else cache), true | `Fork ((x,_,_,_), None) -> (fun () -> resilient_command reach view.next; - let st = Vernacentries.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state `No in ignore(stm_vernac_interp id st x); wall_clock_last_fork := Unix.gettimeofday () ), `Yes, true @@ -2318,7 +2337,7 @@ let known_state ?(redefine_qed=false) ~cache id = reach view.next; (try - let st = Vernacentries.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state `No in ignore(stm_vernac_interp id st x); with e when CErrors.noncritical e -> let (e, info) = CErrors.push e in @@ -2369,16 +2388,16 @@ let known_state ?(redefine_qed=false) ~cache id = Proof_global.close_future_proof ~feedback_id:id fp in if not delegate then ignore(Future.compute fp); reach view.next; - let st = Vernacentries.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state `No in ignore(stm_vernac_interp id ~proof st x); feedback ~id:id Incomplete | { VCS.kind = `Master }, _ -> assert false end; Proof_global.discard_all () ), (if redefine_qed then `No else `Yes), true - | `Sync (name, `Immediate) -> (fun () -> + | `Sync (name, `Immediate) -> (fun () -> reach eop; - let st = Vernacentries.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state `No in ignore(stm_vernac_interp id st x); Proof_global.discard_all () ), `Yes, true @@ -2401,7 +2420,7 @@ let known_state ?(redefine_qed=false) ~cache id = if keep != VtKeepAsAxiom then reach view.next; let wall_clock2 = Unix.gettimeofday () in - let st = Vernacentries.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state `No in ignore(stm_vernac_interp id ?proof st x); let wall_clock3 = Unix.gettimeofday () in Aux_file.record_in_aux_at ?loc:x.loc "proof_check_time" @@ -2419,7 +2438,7 @@ let known_state ?(redefine_qed=false) ~cache id = aux (collect_proof keep (view.next, x) brname brinfo eop) | `Sideff (ReplayCommand x,_) -> (fun () -> reach view.next; - let st = Vernacentries.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state `No in ignore(stm_vernac_interp id st x); update_global_env () ), cache, true @@ -2478,12 +2497,16 @@ let new_doc { doc_type ; require_libs } = begin match doc_type with | Interactive ln -> + Safe_typing.allow_delayed_constants := true; Declaremods.start_library ln + | VoDoc ln -> let ldir = Flags.verbosely Library.start_library ln in VCS.set_ldir ldir; set_compilation_hints ln + | VioDoc ln -> + Safe_typing.allow_delayed_constants := true; let ldir = Flags.verbosely Library.start_library ln in VCS.set_ldir ldir; set_compilation_hints ln @@ -2688,7 +2711,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ?(part_of_script=true) | VtQuery (false,route), VtNow -> let query_sid = VCS.cur_tip () in (try - let st = Vernacentries.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state `No in ignore(stm_vernac_interp ~route query_sid st x) with e -> let e = CErrors.push e in @@ -2762,7 +2785,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ?(part_of_script=true) (* Side effect on all branches *) | VtUnknown, _ when expr = VernacToplevelControl Drop -> - let st = Vernacentries.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state `No in ignore(stm_vernac_interp (VCS.get_branch_pos head) st x); `Ok @@ -2790,7 +2813,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ?(part_of_script=true) VCS.checkout VCS.Branch.master; let mid = VCS.get_branch_pos VCS.Branch.master in let _st' = Reach.known_state ~cache:(VCS.is_interactive ()) mid in - let st = Vernacentries.freeze_interp_state `No in + let st = Vernacstate.freeze_interp_state `No in ignore(stm_vernac_interp id st x); (* Vernac x may or may not start a proof *) if not in_proof && Proof_global.there_are_pending_proofs () then @@ -2831,7 +2854,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ?(part_of_script=true) let get_ast ~doc id = match VCS.visit id with | { step = `Cmd { cast = { loc; expr } } } - | { step = `Fork (({ loc; expr }, _, _, _), _) } + | { step = `Fork (({ loc; expr }, _, _, _), _) } | { step = `Qed ({ qast = { loc; expr } }, _) } -> Some (Loc.tag ?loc expr) | _ -> None diff --git a/stm/stm.mli b/stm/stm.mli index 31f4599d36..9fd35a0d38 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -220,7 +220,7 @@ val forward_feedback_hook : (Feedback.feedback -> unit) Hook.t val get_doc : Feedback.doc_id -> doc val state_of_id : doc:doc -> - Stateid.t -> [ `Valid of Vernacentries.interp_state option | `Expired | `Error of exn ] + Stateid.t -> [ `Valid of Vernacstate.t option | `Expired | `Error of exn ] (* Queries for backward compatibility *) val current_proof_depth : doc:doc -> int diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 3aa2cd707e..c5ae27a110 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -103,8 +103,7 @@ let rec classify_vernac e = | VernacUnsetOption (["Default";"Proof";"Using"]) | VernacSetOption (["Default";"Proof";"Using"],_) -> VtSideff [], VtNow (* StartProof *) - | VernacDefinition ( - (Some Decl_kinds.Discharge,Decl_kinds.Definition),((_,i),_),ProveBody _) -> + | VernacDefinition ((Decl_kinds.DoDischarge,_),((_,i),_),ProveBody _) -> VtStartProof(default_proof_mode (),Doesn'tGuaranteeOpacity,[i]), VtLater | VernacDefinition (_,((_,i),_),ProveBody _) -> VtStartProof(default_proof_mode (),GuaranteesOpacity,[i]), VtLater @@ -113,19 +112,29 @@ let rec classify_vernac e = CList.map_filter (function (Some ((_,i),pl), _) -> Some i | _ -> None) l in VtStartProof (default_proof_mode (),GuaranteesOpacity,ids), VtLater | VernacGoal _ -> VtStartProof (default_proof_mode (),GuaranteesOpacity,[]), VtLater - | VernacFixpoint (_,l) -> + | VernacFixpoint (discharge,l) -> + let guarantee = + match discharge with + | Decl_kinds.NoDischarge -> GuaranteesOpacity + | Decl_kinds.DoDischarge -> Doesn'tGuaranteeOpacity + in let ids, open_proof = List.fold_left (fun (l,b) ((((_,id),_),_,_,_,p),_) -> id::l, b || p = None) ([],false) l in if open_proof - then VtStartProof (default_proof_mode (),GuaranteesOpacity,ids), VtLater + then VtStartProof (default_proof_mode (),guarantee,ids), VtLater else VtSideff ids, VtLater - | VernacCoFixpoint (_,l) -> + | VernacCoFixpoint (discharge,l) -> + let guarantee = + match discharge with + | Decl_kinds.NoDischarge -> GuaranteesOpacity + | Decl_kinds.DoDischarge -> Doesn'tGuaranteeOpacity + in let ids, open_proof = List.fold_left (fun (l,b) ((((_,id),_),_,_,p),_) -> id::l, b || p = None) ([],false) l in if open_proof - then VtStartProof (default_proof_mode (),GuaranteesOpacity,ids), VtLater + then VtStartProof (default_proof_mode (),guarantee,ids), VtLater else VtSideff ids, VtLater (* Sideff: apply to all open branches. usually run on master only *) | VernacAssumption (_,_,l) -> @@ -176,12 +185,12 @@ let rec classify_vernac e = (* These commands alter the parser *) | VernacOpenCloseScope _ | VernacDelimiters _ | VernacBindScope _ | VernacInfix _ | VernacNotation _ | VernacNotationAddFormat _ - | VernacSyntaxExtension _ + | VernacSyntaxExtension _ | VernacSyntacticDefinition _ | VernacRequire _ | VernacImport _ | VernacInclude _ | VernacDeclareMLModule _ | VernacContext _ (* TASSI: unsure *) - | VernacProofMode _ + | VernacProofMode _ -> VtSideff [], VtNow (* These are ambiguous *) | VernacInstance _ -> VtUnknown, VtNow (* Stm will install a new classifier to handle these *) @@ -192,7 +201,7 @@ let rec classify_vernac e = (* What are these? *) | VernacToplevelControl _ | VernacRestoreState _ - | VernacWriteState _ -> VtUnknown, VtNow + | VernacWriteState _ -> VtSideff [], VtNow (* Plugins should classify their commands *) | VernacExtend (s,l) -> try List.assoc s !classifiers l () diff --git a/tactics/auto.ml b/tactics/auto.ml index d0424eb892..fa8435d1ff 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -388,7 +388,7 @@ and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly;db= Tacticals.New.tclPROGRESS (reduce (Unfold [AllOccurrences,c]) Locusops.onConcl) else Tacticals.New.tclFAIL 0 (str"Unbound reference") end - | Extern tacast -> + | Extern tacast -> conclPattern concl p tacast in let pr_hint () = @@ -396,7 +396,8 @@ and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly;db= | None -> mt () | Some n -> str " (in " ++ str n ++ str ")" in - pr_hint t ++ origin + let sigma, env = Pfedit.get_current_context () in + pr_hint env sigma t ++ origin in tclLOG dbg pr_hint (run_hint t tactic) diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index e68087f140..de98f63823 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -9,7 +9,6 @@ open Equality open Names open Pp -open Term open Constr open Termops open CErrors @@ -74,12 +73,12 @@ let find_matches bas pat = let res = HintDN.search_pattern base pat in List.map snd res -let print_rewrite_hintdb bas = +let print_rewrite_hintdb env sigma bas = (str "Database " ++ str bas ++ fnl () ++ prlist_with_sep fnl (fun h -> str (if h.rew_l2r then "rewrite -> " else "rewrite <- ") ++ - Printer.pr_lconstr h.rew_lemma ++ str " of type " ++ Printer.pr_lconstr h.rew_type ++ + Printer.pr_lconstr_env env sigma h.rew_lemma ++ str " of type " ++ Printer.pr_lconstr_env env sigma h.rew_type ++ Option.cata (fun tac -> str " then use tactic " ++ Pputils.pr_glb_generic (Global.env()) tac) (mt ()) h.rew_tac) (find_rewrites bas)) diff --git a/tactics/autorewrite.mli b/tactics/autorewrite.mli index d2b5e070bd..44acf3c018 100644 --- a/tactics/autorewrite.mli +++ b/tactics/autorewrite.mli @@ -40,7 +40,7 @@ val auto_multi_rewrite : ?conds:conditions -> string list -> Locus.clause -> uni val auto_multi_rewrite_with : ?conds:conditions -> unit Proofview.tactic -> string list -> Locus.clause -> unit Proofview.tactic -val print_rewrite_hintdb : string -> Pp.t +val print_rewrite_hintdb : Environ.env -> Evd.evar_map -> string -> Pp.t open Clenv diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index b98b103158..cee6d4bea7 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -464,15 +464,16 @@ and e_my_find_search db_list local_db secvars hdc complete only_classes sigma co in let tac = run_hint t tac in let tac = if complete then Tacticals.New.tclCOMPLETE tac else tac in + let _, env = Pfedit.get_current_context () in let pp = match p with | Some pat when get_typeclasses_filtered_unification () -> - str " with pattern " ++ Printer.pr_constr_pattern pat + str " with pattern " ++ Printer.pr_constr_pattern_env env sigma pat | _ -> mt () in match repr_hint t with - | Extern _ -> (tac, b, true, name, lazy (pr_hint t ++ pp)) - | _ -> (tac, b, false, name, lazy (pr_hint t ++ pp)) + | Extern _ -> (tac, b, true, name, lazy (pr_hint env sigma t ++ pp)) + | _ -> (tac, b, false, name, lazy (pr_hint env sigma t ++ pp)) in List.map tac_of_hint hintl and e_trivial_resolve db_list local_db secvars only_classes sigma concl = diff --git a/tactics/eauto.ml b/tactics/eauto.ml index 239661498b..f5c6ab8799 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -178,7 +178,8 @@ and e_my_find_search sigma db_list local_db secvars hdc concl = | Extern tacast -> conclPattern concl p tacast in let tac = run_hint t tac in - (tac, lazy (pr_hint t))) + let sigma, env = Pfedit.get_current_context () in + (tac, lazy (pr_hint env sigma t))) in List.map tac_of_hint hintl diff --git a/tactics/equality.ml b/tactics/equality.ml index c36ad980ef..0d6263246e 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -739,7 +739,7 @@ let keep_proof_equalities = function let find_positions env sigma ~keep_proofs ~no_discr t1 t2 = let project env sorts posn t1 t2 = let ty1 = get_type_of env sigma t1 in - let s = get_sort_family_of env sigma ty1 in + let s = get_sort_family_of ~truncation_style:true env sigma ty1 in if Sorts.List.mem s sorts then [(List.rev posn,t1,t2)] else [] in diff --git a/tactics/hints.ml b/tactics/hints.ml index c7c53b3930..70e84013ba 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -1392,14 +1392,14 @@ let make_db_list dbnames = (* Functions for printing the hints *) (**************************************************************************) -let pr_hint_elt (c, _, _) = pr_econstr c +let pr_hint_elt env sigma (c, _, _) = pr_econstr_env env sigma c -let pr_hint h = match h.obj with - | Res_pf (c, _) -> (str"simple apply " ++ pr_hint_elt c) - | ERes_pf (c, _) -> (str"simple eapply " ++ pr_hint_elt c) - | Give_exact (c, _) -> (str"exact " ++ pr_hint_elt c) +let pr_hint env sigma h = match h.obj with + | Res_pf (c, _) -> (str"simple apply " ++ pr_hint_elt env sigma c) + | ERes_pf (c, _) -> (str"simple eapply " ++ pr_hint_elt env sigma c) + | Give_exact (c, _) -> (str"exact " ++ pr_hint_elt env sigma c) | Res_pf_THEN_trivial_fail (c, _) -> - (str"simple apply " ++ pr_hint_elt c ++ str" ; trivial") + (str"simple apply " ++ pr_hint_elt env sigma c ++ str" ; trivial") | Unfold_nth c -> (str"unfold " ++ pr_evaluable_reference c) | Extern tac -> let env = @@ -1410,21 +1410,21 @@ let pr_hint h = match h.obj with in (str "(*external*) " ++ Pputils.pr_glb_generic env tac) -let pr_id_hint (id, v) = - let pr_pat p = str", pattern " ++ pr_lconstr_pattern p in - (pr_hint v.code ++ str"(level " ++ int v.pri ++ pr_opt_no_spc pr_pat v.pat +let pr_id_hint env sigma (id, v) = + let pr_pat p = str", pattern " ++ pr_lconstr_pattern_env env sigma p in + (pr_hint env sigma v.code ++ str"(level " ++ int v.pri ++ pr_opt_no_spc pr_pat v.pat ++ str", id " ++ int id ++ str ")" ++ spc ()) -let pr_hint_list hintlist = - (str " " ++ hov 0 (prlist pr_id_hint hintlist) ++ fnl ()) +let pr_hint_list env sigma hintlist = + (str " " ++ hov 0 (prlist (pr_id_hint env sigma) hintlist) ++ fnl ()) -let pr_hints_db (name,db,hintlist) = +let pr_hints_db env sigma (name,db,hintlist) = (str "In the database " ++ str name ++ str ":" ++ if List.is_empty hintlist then (str " nothing" ++ fnl ()) - else (fnl () ++ pr_hint_list hintlist)) + else (fnl () ++ pr_hint_list env sigma hintlist)) (* Print all hints associated to head c in any database *) -let pr_hint_list_for_head c = +let pr_hint_list_for_head env sigma c = let dbs = current_db () in let validate (name, db) = let hints = List.map (fun v -> 0, v) (Hint_db.map_all ~secvars:Id.Pred.full c db) in @@ -1436,13 +1436,13 @@ let pr_hint_list_for_head c = else hov 0 (str"For " ++ pr_global c ++ str" -> " ++ fnl () ++ - hov 0 (prlist pr_hints_db valid_dbs)) + hov 0 (prlist (pr_hints_db env sigma) valid_dbs)) let pr_hint_ref ref = pr_hint_list_for_head ref (* Print all hints associated to head id in any database *) -let pr_hint_term sigma cl = +let pr_hint_term env sigma cl = try let dbs = current_db () in let valid_dbs = @@ -1460,18 +1460,19 @@ let pr_hint_term sigma cl = (str "No hint applicable for current goal") else (str "Applicable Hints :" ++ fnl () ++ - hov 0 (prlist pr_hints_db valid_dbs)) + hov 0 (prlist (pr_hints_db env sigma) valid_dbs)) with Match_failure _ | Failure _ -> (str "No hint applicable for current goal") (* print all hints that apply to the concl of the current goal *) let pr_applicable_hint () = + let env = Global.env () in let pts = Proof_global.give_me_the_proof () in - let glss = Proof.V82.subgoals pts in - match glss.Evd.it with + let glss,_,_,_,sigma = Proof.proof pts in + match glss with | [] -> CErrors.user_err Pp.(str "No focused goal.") | g::_ -> - pr_hint_term glss.Evd.sigma (Goal.V82.concl glss.Evd.sigma g) + pr_hint_term env sigma (Goal.V82.concl sigma g) let pp_hint_mode = function | ModeInput -> str"+" @@ -1479,9 +1480,9 @@ let pp_hint_mode = function | ModeOutput -> str"-" (* displays the whole hint database db *) -let pr_hint_db db = +let pr_hint_db_env env sigma db = let pr_mode = prvect_with_sep spc pp_hint_mode in - let pr_modes l = + let pr_modes l = if List.is_empty l then mt () else str" (modes " ++ prlist_with_sep pr_comma pr_mode l ++ str")" in @@ -1491,7 +1492,7 @@ let pr_hint_db db = | None -> str "For any goal" | Some head -> str "For " ++ pr_global head ++ pr_modes modes in - let hints = pr_hint_list (List.map (fun x -> (0, x)) hintlist) in + let hints = pr_hint_list env sigma (List.map (fun x -> (0, x)) hintlist) in let hint_descr = hov 0 (goal_descr ++ str " -> " ++ hints) in accu ++ hint_descr in @@ -1506,17 +1507,21 @@ let pr_hint_db db = hov 2 (str"Cut: " ++ pp_hints_path (Hint_db.cut db)) ++ fnl () ++ content -let pr_hint_db_by_name dbname = +let pr_hint_db db = + let sigma, env = Pfedit.get_current_context () in + pr_hint_db_env env sigma db + +let pr_hint_db_by_name env sigma dbname = try - let db = searchtable_map dbname in pr_hint_db db + let db = searchtable_map dbname in pr_hint_db_env env sigma db with Not_found -> error_no_such_hint_database dbname (* displays all the hints of all databases *) -let pr_searchtable () = +let pr_searchtable env sigma = let fold name db accu = accu ++ str "In the database " ++ str name ++ str ":" ++ fnl () ++ - pr_hint_db db ++ fnl () + pr_hint_db_env env sigma db ++ fnl () in Hintdbmap.fold fold !searchtable (mt ()) @@ -1534,10 +1539,13 @@ let warn_non_imported_hint = strbrk "Hint used but not imported: " ++ hint ++ print_mp mp) let warn h x = - let hint = pr_hint h in - let (mp, _, _) = KerName.repr h.uid in - warn_non_imported_hint (hint,mp); - Proofview.tclUNIT x + let open Proofview in + tclBIND tclENV (fun env -> + tclBIND tclEVARMAP (fun sigma -> + let hint = pr_hint env sigma h in + let (mp, _, _) = KerName.repr h.uid in + warn_non_imported_hint (hint,mp); + Proofview.tclUNIT x)) let run_hint tac k = match !warn_hint with | `LAX -> k tac.obj diff --git a/tactics/hints.mli b/tactics/hints.mli index 22df29b803..cbf204981e 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -260,14 +260,15 @@ val rewrite_db : hint_db_name (** Printing hints *) -val pr_searchtable : unit -> Pp.t +val pr_searchtable : env -> evar_map -> Pp.t val pr_applicable_hint : unit -> Pp.t -val pr_hint_ref : global_reference -> Pp.t -val pr_hint_db_by_name : hint_db_name -> Pp.t +val pr_hint_ref : env -> evar_map -> global_reference -> Pp.t +val pr_hint_db_by_name : env -> evar_map -> hint_db_name -> Pp.t +val pr_hint_db_env : env -> evar_map -> Hint_db.t -> Pp.t val pr_hint_db : Hint_db.t -> Pp.t -val pr_hint : hint -> Pp.t +[@@ocaml.deprecated "please used pr_hint_db_env"] +val pr_hint : env -> evar_map -> hint -> Pp.t (** Hook for changing the initialization of auto *) - val add_hints_init : (unit -> unit) -> unit diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index 75fae6647d..2c8ca19722 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -39,7 +39,6 @@ type testing_function = Evd.evar_map -> EConstr.constr -> bool let mkmeta n = Nameops.make_ident "X" (Some n) let meta1 = mkmeta 1 let meta2 = mkmeta 2 -let meta3 = mkmeta 3 let op2bool = function Some _ -> true | None -> false @@ -160,7 +159,7 @@ let test_strict_disjunction n lc = let open Term in Array.for_all_i (fun i c -> match (prod_assum (snd (decompose_prod_n_assum n c))) with - | [LocalAssum (_,c)] -> isRel c && Int.equal (destRel c) (n - i) + | [LocalAssum (_,c)] -> Constr.isRel c && Int.equal (Constr.destRel c) (n - i) | _ -> false) 0 lc let match_with_disjunction ?(strict=false) ?(onlybinary=false) sigma t = @@ -460,22 +459,6 @@ let find_this_eq_data_decompose gl eqn = user_err Pp.(str "Don't know what to do with JMeq on arguments not of same type.") in (lbeq,u,eq_args) -let match_eq_nf gls eqn (ref, hetero) = - let n = if hetero then 4 else 3 in - let args = List.init n (fun i -> mkGPatVar ("X" ^ string_of_int (i + 1))) in - let pat = mkPattern (mkGAppRef ref args) in - match Id.Map.bindings (pf_matches gls pat eqn) with - | [(m1,t);(m2,x);(m3,y)] -> - assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3); - (t,pf_whd_all gls x,pf_whd_all gls y) - | _ -> anomaly ~label:"match_eq" (Pp.str "an eq pattern should match 3 terms.") - -let dest_nf_eq gls eqn = - try - snd (first_match (match_eq_nf gls eqn) equalities) - with PatternMatchingFailure -> - user_err Pp.(str "Not an equality.") - (*** Sigma-types *) let match_sigma env sigma ex = diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli index 8ff6fe95c6..237ed42d55 100644 --- a/tactics/hipattern.mli +++ b/tactics/hipattern.mli @@ -144,9 +144,6 @@ val is_matching_sigma : Environ.env -> evar_map -> constr -> bool [t,u,T] and a boolean telling if equality is on the left side *) val match_eqdec : Environ.env -> evar_map -> constr -> bool * Globnames.global_reference * constr * constr * constr -(** Match an equality up to conversion; returns [(eq,t1,t2)] in normal form *) -val dest_nf_eq : 'a Proofview.Goal.t -> constr -> (constr * constr * constr) - (** Match a negation *) val is_matching_not : Environ.env -> evar_map -> constr -> bool val is_matching_imp_False : Environ.env -> evar_map -> constr -> bool diff --git a/tactics/ind_tables.ml b/tactics/ind_tables.ml index e7fa555c2b..e1bf32f3ce 100644 --- a/tactics/ind_tables.ml +++ b/tactics/ind_tables.ml @@ -123,10 +123,9 @@ let define internal id c p univs = let ctx = Evd.normalize_evar_universe_context univs in let c = Vars.subst_univs_fn_constr (Universes.make_opt_subst (Evd.evar_universe_context_subst ctx)) c in - let univs = Evd.evar_context_universe_context ctx in let univs = - if p then Polymorphic_const_entry univs - else Monomorphic_const_entry univs + if p then Polymorphic_const_entry (UState.context ctx) + else Monomorphic_const_entry (UState.context_set ctx) in let entry = { const_entry_body = diff --git a/tactics/inv.ml b/tactics/inv.ml index 8648dfb90c..cb0bbfd0e7 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -282,10 +282,11 @@ let generalizeRewriteIntros as_mode tac depids id = let error_too_many_names pats = let loc = Loc.merge_opt (fst (List.hd pats)) (fst (List.last pats)) in Proofview.tclENV >>= fun env -> + Proofview.tclEVARMAP >>= fun sigma -> tclZEROMSG ?loc ( str "Unexpected " ++ str (String.plural (List.length pats) "introduction pattern") ++ - str ": " ++ pr_enum (Miscprint.pr_intro_pattern (fun c -> Printer.pr_constr (EConstr.Unsafe.to_constr (snd (c env Evd.empty))))) pats ++ + str ": " ++ pr_enum (Miscprint.pr_intro_pattern (fun c -> Printer.pr_constr_env env sigma (EConstr.Unsafe.to_constr (snd (c env Evd.empty))))) pats ++ str ".") let get_names (allow_conj,issimple) (loc, pat as x) = match pat with @@ -333,6 +334,16 @@ let remember_first_eq id x = if !x == MoveLast then x := MoveAfter id If it can discriminate then the goal is proved, if not tries to use it as a rewrite rule. It erases the clause which is given as input *) +let dest_nf_eq env sigma t = match EConstr.kind sigma t with +| App (r, [| t; x; y |]) -> + let open Reductionops in + let lazy eq = Coqlib.coq_eq_ref in + if EConstr.is_global sigma eq r then + (t, whd_all env sigma x, whd_all env sigma y) + else user_err Pp.(str "Not an equality.") +| _ -> + user_err Pp.(str "Not an equality.") + let projectAndApply as_mode thin avoid id eqname names depids = let subst_hyp l2r id = tclTHEN (tclTRY(rewriteInConcl l2r (EConstr.mkVar id))) @@ -343,7 +354,7 @@ let projectAndApply as_mode thin avoid id eqname names depids = let sigma = project gl in (** We only look at the type of hypothesis "id" *) let hyp = pf_nf_evar gl (pf_get_hyp_typ id (Proofview.Goal.assume gl)) in - let (t,t1,t2) = Hipattern.dest_nf_eq gl hyp in + let (t,t1,t2) = dest_nf_eq (pf_env gl) sigma hyp in match (EConstr.kind sigma t1, EConstr.kind sigma t2) with | Var id1, _ -> generalizeRewriteIntros as_mode (subst_hyp true id) depids id1 | _, Var id2 -> generalizeRewriteIntros as_mode (subst_hyp false id) depids id2 diff --git a/tactics/leminv.ml b/tactics/leminv.ml index cc9d98f6fe..1ae3577edb 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -215,7 +215,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = invEnv ~init:Context.Named.empty end in let avoid = ref Id.Set.empty in - let { sigma=sigma } = Proof.V82.subgoals pf in + let _,_,_,_,sigma = Proof.proof pf in let sigma = Evd.nf_constraints sigma in let rec fill_holes c = match EConstr.kind sigma c with @@ -232,12 +232,15 @@ 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 ~names:[] ~extensible:true sigma + p, 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 - let entry = definition_entry ~poly:(Flags.use_polymorphic_flag ()) - ~univs:(snd ctx) invProof in + let invProof, sigma = inversion_scheme env sigma t sort dep inv_op in + let univs = + let poly = Flags.use_polymorphic_flag () in + Evd.const_univ_entry ~poly sigma + in + let entry = definition_entry ~univs invProof in let _ = declare_constant name (DefinitionEntry entry, IsProof Lemma) in () diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 15c25b3467..e072bd95f6 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -945,10 +945,14 @@ let reduction_clause redexp cl = (None, bind_red_expr_occurrences occs nbcl redexp)) cl let reduce redexp cl = - let trace () = + let trace env sigma = let open Printer in - let pr = (pr_econstr, pr_leconstr, pr_evaluable_reference, pr_constr_pattern) in - Pp.(hov 2 (Pputils.pr_red_expr pr str redexp)) + let pr = (pr_econstr_env, pr_leconstr_env, pr_evaluable_reference, pr_constr_pattern_env) in + Pp.(hov 2 (Pputils.pr_red_expr_env env sigma pr str redexp)) + in + let trace () = + let sigma, env = Pfedit.get_current_context () in + trace env sigma in Proofview.Trace.name_tactic trace begin Proofview.Goal.enter begin fun gl -> @@ -3128,11 +3132,11 @@ let expand_hyp id = Tacticals.New.tclTRY (unfold_body id) <*> clear [id] let warn_unused_intro_pattern env sigma = CWarnings.create ~name:"unused-intro-pattern" ~category:"tactics" - (fun names -> - strbrk"Unused introduction " ++ str (String.plural (List.length names) "pattern") - ++ str": " ++ prlist_with_sep spc - (Miscprint.pr_intro_pattern - (fun c -> Printer.pr_econstr (snd (c env sigma)))) names) + (fun names -> + strbrk"Unused introduction " ++ str (String.plural (List.length names) "pattern") ++ + str": " ++ prlist_with_sep spc + (Miscprint.pr_intro_pattern + (fun c -> Printer.pr_econstr_env env sigma (snd (c env sigma)))) names) let check_unused_names env sigma names = if not (List.is_empty names) then diff --git a/tactics/term_dnet.ml b/tactics/term_dnet.ml index 6c8130d793..7567cfa304 100644 --- a/tactics/term_dnet.ml +++ b/tactics/term_dnet.ml @@ -95,13 +95,20 @@ struct let compare cmp t1 t2 = match t1, t2 with | DRel, DRel -> 0 + | DRel, _ -> -1 | _, DRel -> 1 | DSort, DSort -> 0 + | DSort, _ -> -1 | _, DSort -> 1 | DRef gr1, DRef gr2 -> RefOrdered.compare gr1 gr2 + | DRef _, _ -> -1 | _, DRef _ -> 1 + | DCtx (tl1, tr1), DCtx (tl2, tr2) | DLambda (tl1, tr1), DLambda (tl2, tr2) | DApp (tl1, tr1), DApp (tl2, tr2) -> let c = cmp tl1 tl2 in if c = 0 then cmp tr1 tr2 else c + | DCtx _, _ -> -1 | _, DCtx _ -> 1 + | DLambda _, _ -> -1 | _, DLambda _ -> 1 + | DApp _, _ -> -1 | _, DApp _ -> 1 | DCase (ci1, c1, t1, p1), DCase (ci2, c2, t2, p2) -> let c = cmp c1 c2 in @@ -113,6 +120,7 @@ struct else c else c else c + | DCase _, _ -> -1 | _, DCase _ -> 1 | DFix (i1, j1, tl1, pl1), DFix (i2, j2, tl2, pl2) -> let c = Int.compare j1 j2 in @@ -124,6 +132,8 @@ struct else c else c else c + | DFix _, _ -> -1 | _, DFix _ -> 1 + | DCoFix (i1, tl1, pl1), DCoFix (i2, tl2, pl2) -> let c = Int.compare i1 i2 in if c = 0 then @@ -131,7 +141,18 @@ struct if c = 0 then Array.compare cmp pl1 pl2 else c else c - | _ -> Pervasives.compare t1 t2 (** OK **) + | DCoFix _, _ -> -1 | _, DCoFix _ -> 1 + + | DCons ((t1, ot1), u1), DCons ((t2, ot2), u2) -> + let c = cmp t1 t2 in + if Int.equal c 0 then + let c = Option.compare cmp ot1 ot2 in + if Int.equal c 0 then cmp u1 u2 + else c + else c + | DCons _, _ -> -1 | _, DCons _ -> 1 + + | DNil, DNil -> 0 let fold f acc = function | (DRel | DNil | DSort | DRef _) -> acc @@ -174,7 +195,8 @@ struct Array.fold_left2 f (Array.fold_left2 f acc ta1 ta2) ca1 ca2 | DCons ((t1,topt1),u1), DCons ((t2,topt2),u2) -> f (Option.fold_left2 f (f acc t1 t2) topt1 topt2) u1 u2 - | _ -> assert false + | (DRel | DNil | DSort | DRef _ | DCtx _ | DApp _ | DLambda _ | DCase _ + | DFix _ | DCoFix _ | DCons _), _ -> assert false let map2 (f:'a -> 'b -> 'c) (c1:'a t) (c2:'b t) : 'c t = let head w = map (fun _ -> ()) w in @@ -194,11 +216,13 @@ struct DCoFix (i,Array.map2 f ta1 ta2,Array.map2 f ca1 ca2) | DCons ((t1,topt1),u1), DCons ((t2,topt2),u2) -> DCons ((f t1 t2,Option.lift2 f topt1 topt2), f u1 u2) - | _ -> assert false + | (DRel | DNil | DSort | DRef _ | DCtx _ | DApp _ | DLambda _ | DCase _ + | DFix _ | DCoFix _ | DCons _), _ -> assert false let terminal = function | (DRel | DSort | DNil | DRef _) -> true - | _ -> false + | DLambda _ | DApp _ | DCase _ | DFix _ | DCoFix _ | DCtx _ | DCons _ -> + false let compare t1 t2 = compare dummy_cmp t1 t2 diff --git a/test-suite/Makefile b/test-suite/Makefile index 7a204bfd81..6865dcc768 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -95,7 +95,8 @@ VSUBSYSTEMS := prerequisite success failure $(BUGS) output \ SUBSYSTEMS := $(VSUBSYSTEMS) misc bugs ide vio coqchk coqwc coq-makefile PREREQUISITELOG = prerequisite/admit.v.log \ - prerequisite/make_local.v.log prerequisite/make_notation.v.log + prerequisite/make_local.v.log prerequisite/make_notation.v.log \ + prerequisite/bind_univs.v.log ####################################################################### # Phony targets @@ -174,7 +175,7 @@ summary.log: # if not on travis we can get the log files (they're just there for a # local build, and downloadable on GitLab) report: summary.log - $(HIDE)./save-logs.sh + $(HIDE)bash save-logs.sh $(HIDE)if [ -n "${TRAVIS}" ]; then find logs/ -name '*.log' -not -name 'summary.log' -exec 'bash' '-c' 'echo "travis_fold:start:coq.logs.$$(echo '{}' | sed s,/,.,g)"' ';' -exec cat '{}' ';' -exec 'bash' '-c' 'echo "travis_fold:end:coq.logs.$$(echo '{}' | sed s,/,.,g)"' ';'; fi $(HIDE)if [ -n "${APPVEYOR}" ]; then find logs/ -name '*.log' -not -name 'summary.log' -exec 'bash' '-c' 'echo {}' ';' -exec cat '{}' ';' -exec 'bash' '-c' 'echo' ';'; fi $(HIDE)if grep -q -F 'Error!' summary.log ; then echo FAILURES; grep -F 'Error!' summary.log; false; else echo NO FAILURES; fi @@ -528,7 +529,7 @@ coq-makefile/%.log : coq-makefile/%/run.sh $(HIDE)(\ export COQBIN=$(BIN);\ cd coq-makefile/$* && \ - ./run.sh 2>&1; \ + bash run.sh 2>&1; \ if [ $$? = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ diff --git a/test-suite/bugs/closed/3125.v b/test-suite/bugs/closed/3125.v new file mode 100644 index 0000000000..797146174d --- /dev/null +++ b/test-suite/bugs/closed/3125.v @@ -0,0 +1,27 @@ +(* Not considering singleton template-polymorphic inductive types as + propositions for injection/inversion *) + +(* This is also #4560 and #6273 *) + +Inductive foo := foo_1. + +Goal forall (a b : foo), Some a = Some b -> a = b. +Proof. + intros a b H. + inversion H. + reflexivity. +Qed. + +(* Check that Prop is not concerned *) + +Inductive bar : Prop := bar_1. + +Goal + forall (a b : bar), + Some a = Some b -> + a = b. +Proof. + intros a b H. + inversion H. + Fail reflexivity. +Abort. diff --git a/test-suite/bugs/closed/3559.v b/test-suite/bugs/closed/3559.v index da12b68689..5210b27032 100644 --- a/test-suite/bugs/closed/3559.v +++ b/test-suite/bugs/closed/3559.v @@ -65,6 +65,7 @@ Axiom path_iff_hprop_uncurried : forall `{IsHProp A, IsHProp B}, (A <-> B) -> A = B. Inductive V : Type@{U'} := | set {A : Type@{U}} (f : A -> V) : V. Axiom is0trunc_V : IsTrunc (trunc_S (trunc_S minus_two)) V. +Existing Instance is0trunc_V. Axiom bisimulation : V@{U' U} -> V@{U' U} -> hProp@{U'}. Axiom bisimulation_refl : forall (v : V), bisimulation v v. Axiom bisimulation_eq : forall (u v : V), bisimulation u v -> u = v. diff --git a/test-suite/bugs/closed/3690.v b/test-suite/bugs/closed/3690.v index fd9640b890..fa30132ab5 100644 --- a/test-suite/bugs/closed/3690.v +++ b/test-suite/bugs/closed/3690.v @@ -3,49 +3,44 @@ Set Printing Universes. Set Universe Polymorphism. Definition foo (a := Type) (b := Type) (c := Type) := Type. Print foo. -(* foo = -let a := Type@{Top.1} in -let b := Type@{Top.2} in let c := Type@{Top.3} in Type@{Top.4} - : Type@{Top.4+1} -(* Top.1 - Top.2 - Top.3 - Top.4 |= *) *) -Check @foo. (* foo@{Top.5 Top.6 Top.7 -Top.8} - : Type@{Top.8+1} -(* Top.5 - Top.6 - Top.7 - Top.8 |= *) *) +(* foo@{Top.2 Top.3 Top.5 Top.6 Top.8 Top.9 Top.10} = +let a := Type@{Top.2} in let b := Type@{Top.5} in let c := Type@{Top.8} in Type@{Top.10} + : Type@{Top.10+1} +(* Top.2 Top.3 Top.5 Top.6 Top.8 Top.9 Top.10 |= Top.2 < Top.3 + Top.5 < Top.6 + Top.8 < Top.9 + *) + *) +Check @foo. (* foo@{Top.11 Top.12 Top.13 Top.14 Top.15 Top.16 +Top.17} + : Type@{Top.17+1} +(* Top.11 Top.12 Top.13 Top.14 Top.15 Top.16 Top.17 |= Top.11 < Top.12 + Top.13 < Top.14 + Top.15 < Top.16 + *) + *) Definition bar := ltac:(let t := eval compute in foo in exact t). -Check @bar. (* bar@{Top.13 Top.14 Top.15 -Top.16} - : Type@{Top.16+1} -(* Top.13 - Top.14 - Top.15 - Top.16 |= *) *) -(* The following should fail, since [bar] should only need one universe. *) -Check @bar@{i j}. +Check @bar. (* bar@{Top.27} + : Type@{Top.27+1} +(* Top.27 |= *) *) + +Check @bar@{i}. Definition baz (a := Type) (b := Type : a) (c := Type : b) := a -> c. Definition qux := Eval compute in baz. -Check @qux. (* qux@{Top.24 Top.25 -Top.26} - : Type@{max(Top.24+1, Top.26+1)} -(* Top.24 - Top.25 - Top.26 |= Top.25 < Top.24 - Top.26 < Top.25 - *) *) -Print qux. (* qux = -Type@{Top.21} -> Type@{Top.23} - : Type@{max(Top.21+1, Top.23+1)} -(* Top.21 - Top.22 - Top.23 |= Top.22 < Top.21 - Top.23 < Top.22 - *) *) +Check @qux. (* qux@{Top.38 Top.39 Top.40 +Top.41} + : Type@{max(Top.38+1, Top.41+1)} +(* Top.38 Top.39 Top.40 Top.41 |= Top.38 < Top.39 + Top.40 < Top.38 + Top.41 < Top.40 + *) *) +Print qux. (* qux@{Top.34 Top.35 Top.36 Top.37} = +Type@{Top.34} -> Type@{Top.37} + : Type@{max(Top.34+1, Top.37+1)} +(* Top.34 Top.35 Top.36 Top.37 |= Top.34 < Top.35 + Top.36 < Top.34 + Top.37 < Top.36 + *) *) Fail Check @qux@{Set Set}. Check @qux@{Type Type Type Type}. (* [qux] should only need two universes *) diff --git a/test-suite/bugs/closed/4390.v b/test-suite/bugs/closed/4390.v index a96a137001..c069b2d9dc 100644 --- a/test-suite/bugs/closed/4390.v +++ b/test-suite/bugs/closed/4390.v @@ -8,16 +8,16 @@ Universe i. End foo. End M. -Check Type@{i}. +Check Type@{M.i}. (* Succeeds *) Fail Check Type@{j}. (* Error: Undeclared universe: j *) -Definition foo@{j} : Type@{i} := Type@{j}. +Definition foo@{j} : Type@{M.i} := Type@{j}. (* ok *) End A. - +Import A. Import M. Set Universe Polymorphism. Fail Universes j. Monomorphic Universe j. diff --git a/test-suite/bugs/closed/4717.v b/test-suite/bugs/closed/4717.v new file mode 100644 index 0000000000..1507fa4bf0 --- /dev/null +++ b/test-suite/bugs/closed/4717.v @@ -0,0 +1,37 @@ +(* Omega being smarter on recognizing nat and Z *) + +Require Import Omega. + +Definition nat' := nat. + +Theorem le_not_eq_lt : forall (n m:nat), + n <= m -> + n <> m :> nat' -> + n < m. +Proof. + intros. + omega. +Qed. + +Goal forall (x n : nat'), x = x + n - n. +Proof. + intros. + omega. +Qed. + +Require Import ZArith ROmega. + +Open Scope Z_scope. + +Definition Z' := Z. + +Theorem Zle_not_eq_lt : forall n m, + n <= m -> + n <> m :> Z' -> + n < m. +Proof. + intros. + omega. + Undo. + romega. +Qed. diff --git a/test-suite/bugs/closed/5215.v b/test-suite/bugs/closed/5215.v new file mode 100644 index 0000000000..ecf5291596 --- /dev/null +++ b/test-suite/bugs/closed/5215.v @@ -0,0 +1,286 @@ +Require Import Coq.Logic.FunctionalExtensionality. +Require Import Coq.Program.Tactics. + +Global Set Primitive Projections. + +Global Set Universe Polymorphism. + +Global Unset Universe Minimization ToSet. + +Class Category : Type := +{ + Obj : Type; + Hom : Obj -> Obj -> Type; + compose : forall {a b c : Obj}, (Hom a b) -> (Hom b c) -> (Hom a c); + id : forall {a : Obj}, Hom a a; +}. + +Arguments Obj {_}, _. +Arguments id {_ _}, {_} _, _ _. +Arguments Hom {_} _ _, _ _ _. +Arguments compose {_} {_ _ _} _ _, _ {_ _ _} _ _, _ _ _ _ _ _. + +Coercion Obj : Category >-> Sortclass. + +Definition Opposite (C : Category) : Category := +{| + + Obj := Obj C; + Hom := fun a b => Hom b a; + compose := + fun a b c (f : Hom b a) (g : Hom c b) => compose C c b a g f; + id := fun c => id C c; +|}. + +Record Functor (C C' : Category) : Type := +{ + FO : C -> C'; + FA : forall {a b}, Hom a b -> Hom (FO a) (FO b); +}. + +Arguments FO {_ _} _ _. +Arguments FA {_ _} _ {_ _} _, {_ _} _ _ _ _. + +Section Opposite_Functor. + Context {C D : Category} (F : Functor C D). + + Program Definition Opposite_Functor : (Functor (Opposite C) (Opposite D)) := + {| + FO := FO F; + FA := fun _ _ h => FA F h; + |}. + +End Opposite_Functor. + +Section Functor_Compose. + Context {C C' C'' : Category} (F : Functor C C') (F' : Functor C' C''). + + Program Definition Functor_compose : Functor C C'' := + {| + FO := fun c => FO F' (FO F c); + FA := fun c d f => FA F' (FA F f) + |}. + +End Functor_Compose. + +Section Algebras. + Context {C : Category} (T : Functor C C). + Record Algebra : Type := + { + Alg_Carrier : C; + Constructors : Hom (FO T Alg_Carrier) Alg_Carrier + }. + + Record Algebra_Hom (alg alg' : Algebra) : Type := + { + Alg_map : Hom (Alg_Carrier alg) (Alg_Carrier alg'); + + Alg_map_com : compose (FA T Alg_map) (Constructors alg') + = compose (Constructors alg) Alg_map + }. + + Arguments Alg_map {_ _} _. + Arguments Alg_map_com {_ _} _. + Program Definition Algebra_Hom_compose + {alg alg' alg'' : Algebra} + (h : Algebra_Hom alg alg') + (h' : Algebra_Hom alg' alg'') + : Algebra_Hom alg alg'' + := + {| + Alg_map := compose (Alg_map h) (Alg_map h') + |}. + + Next Obligation. Proof. Admitted. + + Lemma Algebra_Hom_eq_simplify (alg alg' : Algebra) + (ah ah' : Algebra_Hom alg alg') + : (Alg_map ah) = (Alg_map ah') -> ah = ah'. + Proof. Admitted. + + Program Definition Algebra_Hom_id (alg : Algebra) : Algebra_Hom alg alg := + {| + Alg_map := id + |}. + + Next Obligation. Admitted. + + Definition Algebra_Cat : Category := + {| + Obj := Algebra; + Hom := Algebra_Hom; + compose := @Algebra_Hom_compose; + id := Algebra_Hom_id; + |}. + +End Algebras. + +Arguments Alg_Carrier {_ _} _. +Arguments Constructors {_ _} _. +Arguments Algebra_Hom {_ _} _ _. +Arguments Alg_map {_ _ _ _} _. +Arguments Alg_map_com {_ _ _ _} _. +Arguments Algebra_Hom_id {_ _} _. + +Section CoAlgebras. + Context {C : Category}. + + Definition CoAlgebra (T : Functor C C) := + @Algebra (Opposite C) (Opposite_Functor T). + + Definition CoAlgebra_Hom {T : Functor C C} := + @Algebra_Hom (Opposite C) (Opposite_Functor T). + + Definition CoAlgebra_Hom_id {T : Functor C C} := + @Algebra_Hom_id (Opposite C) (Opposite_Functor T). + + Definition CoAlgebra_Cat (T : Functor C C) := + @Algebra_Cat (Opposite C) (Opposite_Functor T). + +End CoAlgebras. + +Program Definition Type_Cat : Category := +{| + Obj := Type; + Hom := (fun A B => A -> B); + compose := fun A B C (g : A -> B) (h : B -> C) => fun (x : A) => h (g x); + id := fun A => fun x => x +|}. + +Local Obligation Tactic := idtac. + +Program Definition Prod_Cat (C C' : Category) : Category := +{| + Obj := C * C'; + Hom := + fun a b => + ((Hom (fst a) (fst b)) * (Hom (snd a) (snd b)))%type; + compose := + fun a b c f g => + ((compose (fst f) (fst g)), (compose (snd f)(snd g))); + id := fun c => (id, id) +|}. + +Class Terminal (C : Category) : Type := +{ + terminal : C; + t_morph : forall (d : Obj), Hom d terminal; + t_morph_unique : forall (d : Obj) (f g : (Hom d terminal)), f = g +}. + +Arguments terminal {_} _. +Arguments t_morph {_} _ _. +Arguments t_morph_unique {_} _ _ _ _. + +Coercion terminal : Terminal >-> Obj. + +Definition Initial (C : Category) := Terminal (Opposite C). +Existing Class Initial. + +Record Product {C : Category} (c d : C) : Type := +{ + product : C; + Pi_1 : Hom product c; + Pi_2 : Hom product d; + Prod_morph_ex : forall (p' : Obj) (r1 : Hom p' c) (r2 : Hom p' d), (Hom p' product); +}. + +Arguments Product _ _ _, {_} _ _. + +Arguments Pi_1 {_ _ _ _}, {_ _ _} _. +Arguments Pi_2 {_ _ _ _}, {_ _ _} _. +Arguments Prod_morph_ex {_ _ _} _ _ _ _. + +Coercion product : Product >-> Obj. + +Definition Has_Products (C : Category) : Type := forall a b, Product a b. + +Existing Class Has_Products. + +Program Definition Prod_Func (C : Category) {HP : Has_Products C} + : Functor (Prod_Cat C C) C := +{| + FO := fun x => HP (fst x) (snd x); + FA := fun a b f => Prod_morph_ex _ _ (compose Pi_1 (fst f)) (compose Pi_2 (snd f)) +|}. + +Arguments Prod_Func _ _, _ {_}. + +Definition Sum (C : Category) := @Product (Opposite C). + +Arguments Sum _ _ _, {_} _ _. + +Definition Has_Sums (C : Category) : Type := forall (a b : C), (Sum a b). + +Existing Class Has_Sums. + +Program Definition sum_Sum (A B : Type) : (@Sum Type_Cat A B) := +{| + product := (A + B)%type; + Prod_morph_ex := + fun (p' : Type) + (r1 : A -> p') + (r2 : B -> p') + (X : A + B) => + match X return p' with + | inl a => r1 a + | inr b => r2 b + end +|}. +Next Obligation. simpl; auto. Defined. +Next Obligation. simpl; auto. Defined. + +Program Instance Type_Cat_Has_Sums : Has_Sums Type_Cat := sum_Sum. + +Definition Sum_Func {C : Category} {HS : Has_Sums C} : + Functor (Prod_Cat C C) C := Opposite_Functor (Prod_Func (Opposite C) HS). + +Arguments Sum_Func _ _, _ {_}. + +Program Instance unit_Type_term : Terminal Type_Cat := +{ + terminal := unit; + t_morph := fun _ _=> tt +}. + +Next Obligation. Proof. Admitted. + +Program Definition term_id : Functor Type_Cat (Prod_Cat Type_Cat Type_Cat) := +{| + FO := fun a => (@terminal Type_Cat _, a); + FA := fun a b f => (@id _ (@terminal Type_Cat _), f) +|}. + +Definition S_nat_func : Functor Type_Cat Type_Cat := + Functor_compose term_id (Sum_Func Type_Cat _). + +Definition S_nat_alg_cat := Algebra_Cat S_nat_func. + +CoInductive CoNat : Set := + | CoO : CoNat + | CoS : CoNat -> CoNat +. + +Definition S_nat_coalg_cat := @CoAlgebra_Cat Type_Cat S_nat_func. + +Set Printing Universes. +Program Definition CoNat_alg_term : Initial S_nat_coalg_cat := +{| + terminal := _; + t_morph := _ +|}. + +Next Obligation. Admitted. +Next Obligation. Admitted. + +Axiom Admit : False. + +Next Obligation. +Proof. + intros d f g. + assert(H1 := (@Alg_map_com _ _ _ _ f)). clear. + assert (inl tt = inr tt) by (exfalso; apply Admit). + discriminate. + all: exfalso; apply Admit. + Show Universes. +Qed. diff --git a/test-suite/bugs/closed/5215_2.v b/test-suite/bugs/closed/5215_2.v new file mode 100644 index 0000000000..399947f00f --- /dev/null +++ b/test-suite/bugs/closed/5215_2.v @@ -0,0 +1,8 @@ +Require Import Coq.Program.Tactics. +Set Universe Polymorphism. +Set Printing Universes. +Definition typ := Type. + +Program Definition foo : typ := _ -> _. +Next Obligation. Admitted. +Next Obligation. exact typ. Show Proof. Show Universes. Defined. diff --git a/test-suite/bugs/closed/5347.v b/test-suite/bugs/closed/5347.v new file mode 100644 index 0000000000..9267b3eb69 --- /dev/null +++ b/test-suite/bugs/closed/5347.v @@ -0,0 +1,10 @@ +Set Universe Polymorphism. + +Axiom X : Type. +(* Used to declare [x0@{u1 u2} : X@{u1}] and [x1@{} : X@{u2}] leaving + the type of x1 with undeclared universes. After PR #891 this should + error at declaration time. *) +Axiom xâ‚€ xâ‚ : X. +Axiom Xáµ¢ : X -> Type. + +Check Xáµ¢ xâ‚. (* conversion test raised anomaly universe undefined *) diff --git a/test-suite/bugs/closed/5717.v b/test-suite/bugs/closed/5717.v new file mode 100644 index 0000000000..1bfd917d25 --- /dev/null +++ b/test-suite/bugs/closed/5717.v @@ -0,0 +1,5 @@ +Definition foo@{i} (A : Type@{i}) (l : list A) := + match l with + | nil => nil + | cons _ t => t + end. diff --git a/test-suite/bugs/closed/5761.v b/test-suite/bugs/closed/5761.v new file mode 100644 index 0000000000..6f28d1981a --- /dev/null +++ b/test-suite/bugs/closed/5761.v @@ -0,0 +1,126 @@ +Set Primitive Projections. +Record mix := { a : nat ; b : a = a ; c : nat ; d : a = c ; e : nat ; f : nat }. +Ltac strip_args T ctor := + lazymatch type of ctor with + | context[T] + => match eval cbv beta in ctor with + | ?ctor _ => strip_args T ctor + | _ => ctor + end + end. +Ltac get_ctor T := + let full_ctor := constr:(ltac:(let x := fresh in intro x; econstructor; apply +x) : T -> T) in + let ctor := constr:(fun x : T => ltac:(let v := strip_args T (full_ctor x) in +exact v)) in + lazymatch ctor with + | fun _ => ?ctor => ctor + end. +Ltac uncurry_domain f := + lazymatch type of f with + | forall (a : ?A) (b : @ ?B a), _ + => uncurry_domain (fun ab : { a : A & B a } => f (projT1 ab) (projT2 ab)) + | _ => eval cbv beta in f + end. +Ltac get_of_sigma T := + let ctor := get_ctor T in + uncurry_domain ctor. +Ltac repeat_existT := + lazymatch goal with + | [ |- sigT _ ] => simple refine (existT _ _ _); [ repeat_existT | shelve ] + | _ => shelve + end. + Ltac prove_to_of_sigma_goal of_sigma := + let v := fresh "v" in + simple refine (exist _ _ (fun v => _ : id _ (of_sigma v) = v)); + try unfold of_sigma; + [ intro v; destruct v; repeat_existT + | cbv beta; + repeat match goal with + | [ |- context[projT2 ?k] ] + => let x := fresh "x" in + is_var k; + destruct k as [k x]; cbn [projT1 projT2] + end; + unfold id; reflexivity ]. +Ltac prove_to_of_sigma of_sigma := + constr:( + ltac:(prove_to_of_sigma_goal of_sigma) + : { to_sigma : _ | forall v, id to_sigma (of_sigma v) = v }). +Ltac get_to_sigma_gen of_sigma := + let v := prove_to_of_sigma of_sigma in + eval hnf in (proj1_sig v). +Ltac get_to_sigma T := + let of_sigma := get_of_sigma T in + get_to_sigma_gen of_sigma. +Definition to_sigma := ltac:(let v := get_to_sigma mix in exact v). +(* Error: +In nested Ltac calls to "get_to_sigma", "get_to_sigma_gen", +"prove_to_of_sigma", +"(_ : {to_sigma : _ | forall v, id to_sigma (of_sigma v) = v})" (with +of_sigma:=fun + ab : {_ + : {_ + : {ab : {_ : {a : nat & a = a} & nat} & + projT1 (projT1 ab) = projT2 ab} & nat} & nat} => + {| + a := projT1 (projT1 (projT1 (projT1 (projT1 ab)))); + b := projT2 (projT1 (projT1 (projT1 (projT1 ab)))); + c := projT2 (projT1 (projT1 (projT1 ab))); + d := projT2 (projT1 (projT1 ab)); + e := projT2 (projT1 ab); + f := projT2 ab |}) and "prove_to_of_sigma_goal", last call failed. +Anomaly "Uncaught exception Not_found." Please report at +http://coq.inria.fr/bugs/. +frame @ file "toplevel/coqtop.ml", line 640, characters 6-22 +frame @ file "list.ml", line 73, characters 12-15 +frame @ file "toplevel/vernac.ml", line 344, characters 2-13 +frame @ file "toplevel/vernac.ml", line 308, characters 14-75 +raise @ file "lib/exninfo.ml", line 63, characters 8-15 +frame @ file "lib/flags.ml", line 141, characters 19-40 +raise @ file "lib/exninfo.ml", line 63, characters 8-15 +frame @ file "lib/flags.ml", line 11, characters 15-18 +raise @ file "lib/exninfo.ml", line 63, characters 8-15 +frame @ file "toplevel/vernac.ml", line 167, characters 6-16 +frame @ file "toplevel/vernac.ml", line 151, characters 26-39 +frame @ file "stm/stm.ml", line 2365, characters 2-35 +raise @ file "lib/exninfo.ml", line 63, characters 8-15 +frame @ file "stm/stm.ml", line 2355, characters 4-48 +frame @ file "stm/stm.ml", line 2321, characters 4-100 +raise @ file "lib/exninfo.ml", line 63, characters 8-15 +frame @ file "stm/stm.ml", line 832, characters 6-10 +frame @ file "stm/stm.ml", line 2206, characters 10-32 +raise @ file "lib/exninfo.ml", line 63, characters 8-15 +frame @ file "stm/stm.ml", line 975, characters 8-81 +raise @ file "lib/exninfo.ml", line 63, characters 8-15 +frame @ file "vernac/vernacentries.ml", line 2216, characters 10-389 +frame @ file "lib/flags.ml", line 141, characters 19-40 +raise @ file "lib/exninfo.ml", line 63, characters 8-15 +frame @ file "lib/flags.ml", line 11, characters 15-18 +frame @ file "vernac/command.ml", line 150, characters 4-56 +frame @ file "interp/constrintern.ml", line 2046, characters 2-73 +frame @ file "pretyping/pretyping.ml", line 1194, characters 19-77 +frame @ file "pretyping/pretyping.ml", line 1155, characters 8-72 +frame @ file "pretyping/pretyping.ml", line 628, characters 23-65 +frame @ file "plugins/ltac/tacinterp.ml", line 2095, characters 21-61 +frame @ file "proofs/pfedit.ml", line 178, characters 6-22 +raise @ file "lib/exninfo.ml", line 63, characters 8-15 +frame @ file "proofs/pfedit.ml", line 174, characters 8-36 +frame @ file "proofs/proof.ml", line 351, characters 4-30 +raise @ file "lib/exninfo.ml", line 63, characters 8-15 +frame @ file "engine/proofview.ml", line 1222, characters 8-12 +frame @ file "plugins/ltac/tacinterp.ml", line 2020, characters 19-36 +frame @ file "plugins/ltac/tacinterp.ml", line 618, characters 4-70 +raise @ file "lib/exninfo.ml", line 63, characters 8-15 +frame @ file "plugins/ltac/tacinterp.ml", line 214, characters 6-9 +frame @ file "pretyping/pretyping.ml", line 1198, characters 19-62 +frame @ file "pretyping/pretyping.ml", line 1155, characters 8-72 +raise @ unknown +frame @ file "pretyping/pretyping.ml", line 628, characters 23-65 +frame @ file "plugins/ltac/tacinterp.ml", line 2095, characters 21-61 +frame @ file "proofs/pfedit.ml", line 178, characters 6-22 +raise @ file "lib/exninfo.ml", line 63, characters 8-15 +frame @ file "proofs/pfedit.ml", line 174, characters 8-36 +frame @ file "proofs/proof.ml", line 351, characters 4-30 +raise @ file "lib/exninfo.ml", line 63, characters 8-15 + *) diff --git a/test-suite/bugs/closed/5762.v b/test-suite/bugs/closed/5762.v index edd5c8d73d..55d36bd722 100644 --- a/test-suite/bugs/closed/5762.v +++ b/test-suite/bugs/closed/5762.v @@ -26,3 +26,9 @@ Reserved Notation "%% a" (at level 70). Record R := {g : forall {A} (a:A), a=a where "%% x" := (g x); k : %% 0 = eq_refl}. + +(* An extra example *) + +Module A. +Inductive I {A:Type} := C : # 0 -> I where "# I" := (I = I) : I_scope. +End A. diff --git a/test-suite/bugs/closed/5790.v b/test-suite/bugs/closed/5790.v new file mode 100644 index 0000000000..6c93a3906e --- /dev/null +++ b/test-suite/bugs/closed/5790.v @@ -0,0 +1,7 @@ +Set Universe Polymorphism. +Section foo. +Context (v : Type). +Axiom a : True <-> False. + +Hint Resolve -> a. +End foo. diff --git a/test-suite/bugs/closed/6191.v b/test-suite/bugs/closed/6191.v new file mode 100644 index 0000000000..e0d912509b --- /dev/null +++ b/test-suite/bugs/closed/6191.v @@ -0,0 +1,16 @@ +(* Check a 8.7.1 regression in ring_simplify *) + +Require Import ArithRing BinNat. +Goal forall f x, (2+x+f (N.to_nat 2)+3=4). +intros. +ring_simplify (2+x+f (N.to_nat 2)+3). +match goal with |- x + f (N.to_nat 2) + 5 = 4 => idtac end. +Abort. + +Require Import ZArithRing BinInt. +Open Scope Z_scope. +Goal forall x, (2+x+3=4). +intros. +ring_simplify (2+x+3). +match goal with |- x+5 = 4 => idtac end. +Abort. diff --git a/test-suite/bugs/closed/6323.v b/test-suite/bugs/closed/6323.v new file mode 100644 index 0000000000..fdc33befc6 --- /dev/null +++ b/test-suite/bugs/closed/6323.v @@ -0,0 +1,9 @@ +Goal True. + simple refine (let X : Type := _ in _); + [ abstract exact Set using Set' + | let X' := (eval cbv delta [X] in X) in + clear X; + simple refine (let id' : { x : X' | True } -> X' := _ in _); + [ abstract refine (@proj1_sig _ _) | ] + ]. +Abort. diff --git a/test-suite/bugs/closed/HoTT_coq_064.v b/test-suite/bugs/closed/HoTT_coq_064.v index b4c745375f..d02a5f120c 100644 --- a/test-suite/bugs/closed/HoTT_coq_064.v +++ b/test-suite/bugs/closed/HoTT_coq_064.v @@ -178,6 +178,7 @@ Definition IsColimit `{Funext} C D (F : Functor D C) Generalizable All Variables. Axiom fs : Funext. +Existing Instance fs. Section bar. diff --git a/test-suite/bugs/closed/gh6165.v b/test-suite/bugs/closed/gh6165.v new file mode 100644 index 0000000000..b87a7caaf2 --- /dev/null +++ b/test-suite/bugs/closed/gh6165.v @@ -0,0 +1,5 @@ +(* -*- mode: coq; coq-prog-args: ("-quick") -*- *) + +Goal True. + abstract exact I. +Timeout 1 Defined. diff --git a/test-suite/bugs/opened/4717.v b/test-suite/bugs/opened/4717.v deleted file mode 100644 index 9ad4746723..0000000000 --- a/test-suite/bugs/opened/4717.v +++ /dev/null @@ -1,19 +0,0 @@ -(*See below. They sometimes work, and sometimes do not. Is this a bug?*) - -Require Import Omega Psatz. - -Definition foo := nat. - -Goal forall (n : foo), 0 = n - n. -Proof. intros. omega. (* works *) Qed. - -Goal forall (x n : foo), x = x + n - n. -Proof. - intros. - Fail omega. (* Omega can't solve this system *) - Fail lia. (* Cannot find witness. *) - unfold foo in *. - omega. (* works *) -Qed. - -(* Guillaume Melquiond: What matters is the equality. In the first case, it is @eq nat. In the second case, it is @eq foo. The same issue exists for ring and field. So it is not a bug, but it is worth fixing.*) diff --git a/test-suite/coq-makefile/.gitignore b/test-suite/coq-makefile/.gitignore new file mode 100644 index 0000000000..e866161ceb --- /dev/null +++ b/test-suite/coq-makefile/.gitignore @@ -0,0 +1 @@ +/*/_test diff --git a/test-suite/coq-makefile/plugin-reach-outside-API-and-fail/run.sh b/test-suite/coq-makefile/plugin-reach-outside-API-and-fail/run.sh index 378573957e..e48f704a2d 100755 --- a/test-suite/coq-makefile/plugin-reach-outside-API-and-fail/run.sh +++ b/test-suite/coq-makefile/plugin-reach-outside-API-and-fail/run.sh @@ -10,7 +10,7 @@ cat > _CoqProject <<EOT ./src/test.mli EOT -mkdir src +mkdir -p src cat > src/test_plugin.mllib <<EOT Test diff --git a/test-suite/coq-makefile/plugin-reach-outside-API-and-succeed-by-bypassing-the-API/run.sh b/test-suite/coq-makefile/plugin-reach-outside-API-and-succeed-by-bypassing-the-API/run.sh index 1b57a356ba..4a8f58655a 100755 --- a/test-suite/coq-makefile/plugin-reach-outside-API-and-succeed-by-bypassing-the-API/run.sh +++ b/test-suite/coq-makefile/plugin-reach-outside-API-and-succeed-by-bypassing-the-API/run.sh @@ -11,7 +11,7 @@ cat > _CoqProject <<EOT ./src/test.mli EOT -mkdir src +mkdir -p src cat > src/test_plugin.mllib <<EOT Test diff --git a/test-suite/coq-makefile/template/init.sh b/test-suite/coq-makefile/template/init.sh index c4bd11c57d..e19d168cf6 100755 --- a/test-suite/coq-makefile/template/init.sh +++ b/test-suite/coq-makefile/template/init.sh @@ -1,19 +1,17 @@ -set -e -set -o pipefail +. ../template/path-init.sh -export PATH=$COQBIN:$PATH -export LC_ALL=C - -rm -rf theories src Makefile Makefile.conf tmp -git clean -dfx || true +rm -rf _test +mkdir _test +find . -maxdepth 1 -not -name . -not -name _test -exec cp -r '{}' -t _test ';' +cd _test mkdir -p src mkdir -p theories/sub -cp ../template/theories/sub/testsub.v theories/sub -cp ../template/theories/test.v theories -cp ../template/src/test.ml4 src -cp ../template/src/test_aux.mli src -cp ../template/src/test.mli src -cp ../template/src/test_plugin.mlpack src -cp ../template/src/test_aux.ml src +cp ../../template/theories/sub/testsub.v theories/sub +cp ../../template/theories/test.v theories +cp ../../template/src/test.ml4 src +cp ../../template/src/test_aux.mli src +cp ../../template/src/test.mli src +cp ../../template/src/test_plugin.mlpack src +cp ../../template/src/test_aux.ml src diff --git a/test-suite/coq-makefile/template/path-init.sh b/test-suite/coq-makefile/template/path-init.sh new file mode 100755 index 0000000000..dd19ab2b14 --- /dev/null +++ b/test-suite/coq-makefile/template/path-init.sh @@ -0,0 +1,5 @@ +set -e +set -o pipefail + +export PATH="$COQBIN:$PATH" +export LC_ALL=C diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/.gitattributes b/test-suite/coq-makefile/timing/precomputed-time-tests/.gitattributes new file mode 100644 index 0000000000..e0596e614b --- /dev/null +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/.gitattributes @@ -0,0 +1,2 @@ +*.log.in -whitespace +*.log.expected -whitespace diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/run.sh b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/run.sh new file mode 100755 index 0000000000..4a50759bdb --- /dev/null +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/run.sh @@ -0,0 +1,10 @@ +#!/usr/bin/env bash + +set -x +set -e + +cd "$(dirname "${BASH_SOURCE[0]}")" + +"$COQLIB"/tools/make-both-time-files.py time-of-build-after.log.in time-of-build-before.log.in time-of-build-both.log + +diff -u time-of-build-both.log.expected time-of-build-both.log || exit $? diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-after.log.in b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-after.log.in new file mode 100644 index 0000000000..5757018e9b --- /dev/null +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-after.log.in @@ -0,0 +1,1760 @@ +COQDEP src/Compilers/Z/Bounds/Pipeline/ReflectiveTactics.v +COQDEP src/Compilers/Z/Bounds/Pipeline/Definition.v +/home/jgross/.local64/coq/coq-master/bin/coq_makefile -f _CoqProject INSTALLDEFAULTROOT = Crypto -o Makefile-old +COQ_MAKEFILE -f _CoqProject > Makefile.coq +make --no-print-directory -C coqprime +make[1]: Nothing to be done for 'all'. +ECHO > _CoqProject +COQC src/Compilers/Z/Bounds/Pipeline/Definition.v +src/Compilers/Z/Bounds/Pipeline/Definition (real: 7.33, user: 7.18, sys: 0.14, mem: 574388 ko) +COQC src/Compilers/Z/Bounds/Pipeline/ReflectiveTactics.v +src/Compilers/Z/Bounds/Pipeline/ReflectiveTactics (real: 1.93, user: 1.72, sys: 0.20, mem: 544172 ko) +COQC src/Compilers/Z/Bounds/Pipeline.v +src/Compilers/Z/Bounds/Pipeline (real: 1.38, user: 1.19, sys: 0.16, mem: 539808 ko) +COQC src/Specific/Framework/SynthesisFramework.v +src/Specific/Framework/SynthesisFramework (real: 1.85, user: 1.67, sys: 0.17, mem: 646300 ko) +COQC src/Specific/X25519/C64/Synthesis.v +src/Specific/X25519/C64/Synthesis (real: 11.15, user: 10.37, sys: 0.18, mem: 687760 ko) +COQC src/Specific/NISTP256/AMD64/Synthesis.v +src/Specific/NISTP256/AMD64/Synthesis (real: 13.45, user: 12.55, sys: 0.19, mem: 668216 ko) +COQC src/Specific/X25519/C64/feadd.v +Finished transaction in 2.814 secs (2.624u,0.s) (successful) +total time: 2.576s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.2% 97.4% 1 2.508s +─ReflectiveTactics.do_reflective_pipelin 0.0% 66.9% 1 1.724s +─ReflectiveTactics.solve_side_conditions 0.0% 65.5% 1 1.688s +─ReflectiveTactics.solve_post_reified_si 1.2% 37.0% 1 0.952s +─Glue.refine_to_reflective_glue' ------- 0.0% 30.3% 1 0.780s +─ReflectiveTactics.do_reify ------------ 0.0% 28.6% 1 0.736s +─Reify.Reify_rhs_gen ------------------- 2.2% 26.6% 1 0.684s +─UnifyAbstractReflexivity.unify_transfor 20.3% 24.1% 7 0.164s +─Glue.zrange_to_reflective ------------- 0.0% 20.3% 1 0.524s +─Glue.zrange_to_reflective_goal -------- 9.5% 15.2% 1 0.392s +─Reify.do_reify_abs_goal --------------- 13.7% 13.8% 2 0.356s +─Reify.do_reifyf_goal ------------------ 12.4% 12.6% 16 0.324s +─ReflectiveTactics.unify_abstract_cbv_in 8.4% 11.2% 1 0.288s +─unify (constr) (constr) --------------- 5.7% 5.7% 6 0.072s +─Glue.pattern_sig_sig_assoc ------------ 0.0% 5.4% 1 0.140s +─assert (H : is_bounded_by' bounds (map' 4.8% 5.1% 2 0.072s +─Glue.pattern_proj1_sig_in_sig --------- 1.7% 5.1% 1 0.132s +─pose proof (pf : Interpretation.Bo 3.7% 3.7% 1 0.096s +─Glue.split_BoundedWordToZ ------------- 0.3% 3.7% 1 0.096s +─destruct_sig -------------------------- 0.2% 3.3% 4 0.044s +─destruct x ---------------------------- 3.1% 3.1% 4 0.036s +─eexact -------------------------------- 3.0% 3.0% 18 0.008s +─clearbody (ne_var_list) --------------- 3.0% 3.0% 4 0.060s +─prove_interp_compile_correct ---------- 0.0% 2.8% 1 0.072s +─synthesize ---------------------------- 0.0% 2.6% 1 0.068s +─rewrite ?EtaInterp.InterpExprEta ------ 2.5% 2.5% 1 0.064s +─ClearbodyAll.clearbody_all ------------ 0.0% 2.3% 2 0.060s +─rewrite H ----------------------------- 2.2% 2.2% 1 0.056s +─reflexivity --------------------------- 2.2% 2.2% 7 0.032s +─Reify.transitivity_tt ----------------- 0.0% 2.2% 2 0.032s +─transitivity -------------------------- 2.0% 2.0% 5 0.024s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.2% 97.4% 1 2.508s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 66.9% 1 1.724s + │└ReflectiveTactics.solve_side_conditio 0.0% 65.5% 1 1.688s + │ ├─ReflectiveTactics.solve_post_reifie 1.2% 37.0% 1 0.952s + │ │ ├─UnifyAbstractReflexivity.unify_tr 20.3% 24.1% 7 0.164s + │ │ │└unify (constr) (constr) --------- 3.0% 3.0% 5 0.028s + │ │ └─ReflectiveTactics.unify_abstract_ 8.4% 11.2% 1 0.288s + │ │ â””unify (constr) (constr) --------- 2.8% 2.8% 1 0.072s + │ └─ReflectiveTactics.do_reify -------- 0.0% 28.6% 1 0.736s + │ â””Reify.Reify_rhs_gen --------------- 2.2% 26.6% 1 0.684s + │ ├─Reify.do_reify_abs_goal --------- 13.7% 13.8% 2 0.356s + │ │└Reify.do_reifyf_goal ------------ 12.4% 12.6% 16 0.324s + │ │└eexact -------------------------- 2.6% 2.6% 16 0.008s + │ ├─prove_interp_compile_correct ---- 0.0% 2.8% 1 0.072s + │ │└rewrite ?EtaInterp.InterpExprEta 2.5% 2.5% 1 0.064s + │ ├─rewrite H ----------------------- 2.2% 2.2% 1 0.056s + │ └─Reify.transitivity_tt ----------- 0.0% 2.2% 2 0.032s + └─Glue.refine_to_reflective_glue' ----- 0.0% 30.3% 1 0.780s + ├─Glue.zrange_to_reflective --------- 0.0% 20.3% 1 0.524s + │ ├─Glue.zrange_to_reflective_goal -- 9.5% 15.2% 1 0.392s + │ │└pose proof (pf : Interpretat 3.7% 3.7% 1 0.096s + │ └─assert (H : is_bounded_by' bounds 4.8% 5.1% 2 0.072s + ├─Glue.pattern_sig_sig_assoc -------- 0.0% 5.4% 1 0.140s + │└Glue.pattern_proj1_sig_in_sig ----- 1.7% 5.1% 1 0.132s + │└ClearbodyAll.clearbody_all -------- 0.0% 2.3% 2 0.060s + │└clearbody (ne_var_list) ----------- 2.3% 2.3% 1 0.060s + └─Glue.split_BoundedWordToZ --------- 0.3% 3.7% 1 0.096s + â””destruct_sig ---------------------- 0.2% 3.3% 4 0.044s + â””destruct x ------------------------ 2.5% 2.5% 2 0.036s +─synthesize ---------------------------- 0.0% 2.6% 1 0.068s + +Finished transaction in 5.021 secs (4.636u,0.s) (successful) +Closed under the global context +total time: 2.576s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.2% 97.4% 1 2.508s +─ReflectiveTactics.do_reflective_pipelin 0.0% 66.9% 1 1.724s +─ReflectiveTactics.solve_side_conditions 0.0% 65.5% 1 1.688s +─ReflectiveTactics.solve_post_reified_si 1.2% 37.0% 1 0.952s +─Glue.refine_to_reflective_glue' ------- 0.0% 30.3% 1 0.780s +─ReflectiveTactics.do_reify ------------ 0.0% 28.6% 1 0.736s +─Reify.Reify_rhs_gen ------------------- 2.2% 26.6% 1 0.684s +─UnifyAbstractReflexivity.unify_transfor 20.3% 24.1% 7 0.164s +─Glue.zrange_to_reflective ------------- 0.0% 20.3% 1 0.524s +─Glue.zrange_to_reflective_goal -------- 9.5% 15.2% 1 0.392s +─Reify.do_reify_abs_goal --------------- 13.7% 13.8% 2 0.356s +─Reify.do_reifyf_goal ------------------ 12.4% 12.6% 16 0.324s +─ReflectiveTactics.unify_abstract_cbv_in 8.4% 11.2% 1 0.288s +─unify (constr) (constr) --------------- 5.7% 5.7% 6 0.072s +─Glue.pattern_sig_sig_assoc ------------ 0.0% 5.4% 1 0.140s +─assert (H : is_bounded_by' bounds (map' 4.8% 5.1% 2 0.072s +─Glue.pattern_proj1_sig_in_sig --------- 1.7% 5.1% 1 0.132s +─pose proof (pf : Interpretation.Bo 3.7% 3.7% 1 0.096s +─Glue.split_BoundedWordToZ ------------- 0.3% 3.7% 1 0.096s +─destruct_sig -------------------------- 0.2% 3.3% 4 0.044s +─destruct x ---------------------------- 3.1% 3.1% 4 0.036s +─eexact -------------------------------- 3.0% 3.0% 18 0.008s +─clearbody (ne_var_list) --------------- 3.0% 3.0% 4 0.060s +─prove_interp_compile_correct ---------- 0.0% 2.8% 1 0.072s +─synthesize ---------------------------- 0.0% 2.6% 1 0.068s +─rewrite ?EtaInterp.InterpExprEta ------ 2.5% 2.5% 1 0.064s +─ClearbodyAll.clearbody_all ------------ 0.0% 2.3% 2 0.060s +─rewrite H ----------------------------- 2.2% 2.2% 1 0.056s +─reflexivity --------------------------- 2.2% 2.2% 7 0.032s +─Reify.transitivity_tt ----------------- 0.0% 2.2% 2 0.032s +─transitivity -------------------------- 2.0% 2.0% 5 0.024s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.2% 97.4% 1 2.508s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 66.9% 1 1.724s + │└ReflectiveTactics.solve_side_conditio 0.0% 65.5% 1 1.688s + │ ├─ReflectiveTactics.solve_post_reifie 1.2% 37.0% 1 0.952s + │ │ ├─UnifyAbstractReflexivity.unify_tr 20.3% 24.1% 7 0.164s + │ │ │└unify (constr) (constr) --------- 3.0% 3.0% 5 0.028s + │ │ └─ReflectiveTactics.unify_abstract_ 8.4% 11.2% 1 0.288s + │ │ â””unify (constr) (constr) --------- 2.8% 2.8% 1 0.072s + │ └─ReflectiveTactics.do_reify -------- 0.0% 28.6% 1 0.736s + │ â””Reify.Reify_rhs_gen --------------- 2.2% 26.6% 1 0.684s + │ ├─Reify.do_reify_abs_goal --------- 13.7% 13.8% 2 0.356s + │ │└Reify.do_reifyf_goal ------------ 12.4% 12.6% 16 0.324s + │ │└eexact -------------------------- 2.6% 2.6% 16 0.008s + │ ├─prove_interp_compile_correct ---- 0.0% 2.8% 1 0.072s + │ │└rewrite ?EtaInterp.InterpExprEta 2.5% 2.5% 1 0.064s + │ ├─rewrite H ----------------------- 2.2% 2.2% 1 0.056s + │ └─Reify.transitivity_tt ----------- 0.0% 2.2% 2 0.032s + └─Glue.refine_to_reflective_glue' ----- 0.0% 30.3% 1 0.780s + ├─Glue.zrange_to_reflective --------- 0.0% 20.3% 1 0.524s + │ ├─Glue.zrange_to_reflective_goal -- 9.5% 15.2% 1 0.392s + │ │└pose proof (pf : Interpretat 3.7% 3.7% 1 0.096s + │ └─assert (H : is_bounded_by' bounds 4.8% 5.1% 2 0.072s + ├─Glue.pattern_sig_sig_assoc -------- 0.0% 5.4% 1 0.140s + │└Glue.pattern_proj1_sig_in_sig ----- 1.7% 5.1% 1 0.132s + │└ClearbodyAll.clearbody_all -------- 0.0% 2.3% 2 0.060s + │└clearbody (ne_var_list) ----------- 2.3% 2.3% 1 0.060s + └─Glue.split_BoundedWordToZ --------- 0.3% 3.7% 1 0.096s + â””destruct_sig ---------------------- 0.2% 3.3% 4 0.044s + â””destruct x ------------------------ 2.5% 2.5% 2 0.036s +─synthesize ---------------------------- 0.0% 2.6% 1 0.068s + +src/Specific/X25519/C64/feadd (real: 22.81, user: 20.93, sys: 0.25, mem: 766300 ko) +COQC src/Specific/X25519/C64/fecarry.v +Finished transaction in 4.343 secs (4.016u,0.004s) (successful) +total time: 3.976s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 99.0% 1 3.936s +─ReflectiveTactics.do_reflective_pipelin 0.0% 87.9% 1 3.496s +─ReflectiveTactics.solve_side_conditions 0.0% 86.9% 1 3.456s +─ReflectiveTactics.do_reify ------------ 0.0% 56.9% 1 2.264s +─Reify.Reify_rhs_gen ------------------- 1.8% 56.2% 1 2.236s +─Reify.do_reify_abs_goal --------------- 36.1% 36.5% 2 1.452s +─Reify.do_reifyf_goal ------------------ 34.8% 35.1% 29 1.396s +─ReflectiveTactics.solve_post_reified_si 0.6% 30.0% 1 1.192s +─UnifyAbstractReflexivity.unify_transfor 17.7% 21.7% 7 0.240s +─Glue.refine_to_reflective_glue' ------- 0.0% 11.1% 1 0.440s +─eexact -------------------------------- 10.9% 10.9% 31 0.024s +─ReflectiveTactics.unify_abstract_cbv_in 5.2% 7.3% 1 0.292s +─Glue.zrange_to_reflective ------------- 0.0% 7.1% 1 0.284s +─prove_interp_compile_correct ---------- 0.0% 5.7% 1 0.228s +─Glue.zrange_to_reflective_goal -------- 4.3% 5.5% 1 0.220s +─unify (constr) (constr) --------------- 5.3% 5.3% 6 0.084s +─rewrite ?EtaInterp.InterpExprEta ------ 5.2% 5.2% 1 0.208s +─rewrite H ----------------------------- 3.5% 3.5% 1 0.140s +─tac ----------------------------------- 1.9% 2.6% 2 0.104s +─reflexivity --------------------------- 2.2% 2.2% 7 0.028s +─Reify.transitivity_tt ----------------- 0.0% 2.2% 2 0.056s +─transitivity -------------------------- 2.0% 2.0% 5 0.048s +─Glue.split_BoundedWordToZ ------------- 0.1% 2.0% 1 0.080s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 99.0% 1 3.936s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 87.9% 1 3.496s + │└ReflectiveTactics.solve_side_conditio 0.0% 86.9% 1 3.456s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 56.9% 1 2.264s + │ │└Reify.Reify_rhs_gen --------------- 1.8% 56.2% 1 2.236s + │ │ ├─Reify.do_reify_abs_goal --------- 36.1% 36.5% 2 1.452s + │ │ │└Reify.do_reifyf_goal ------------ 34.8% 35.1% 29 1.396s + │ │ │└eexact -------------------------- 10.1% 10.1% 29 0.024s + │ │ ├─prove_interp_compile_correct ---- 0.0% 5.7% 1 0.228s + │ │ │└rewrite ?EtaInterp.InterpExprEta 5.2% 5.2% 1 0.208s + │ │ ├─rewrite H ----------------------- 3.5% 3.5% 1 0.140s + │ │ ├─tac ----------------------------- 1.9% 2.6% 1 0.104s + │ │ └─Reify.transitivity_tt ----------- 0.0% 2.2% 2 0.056s + │ │ â””transitivity -------------------- 2.0% 2.0% 4 0.048s + │ └─ReflectiveTactics.solve_post_reifie 0.6% 30.0% 1 1.192s + │ ├─UnifyAbstractReflexivity.unify_tr 17.7% 21.7% 7 0.240s + │ │└unify (constr) (constr) --------- 3.2% 3.2% 5 0.048s + │ └─ReflectiveTactics.unify_abstract_ 5.2% 7.3% 1 0.292s + │ â””unify (constr) (constr) --------- 2.1% 2.1% 1 0.084s + └─Glue.refine_to_reflective_glue' ----- 0.0% 11.1% 1 0.440s + ├─Glue.zrange_to_reflective --------- 0.0% 7.1% 1 0.284s + │└Glue.zrange_to_reflective_goal ---- 4.3% 5.5% 1 0.220s + └─Glue.split_BoundedWordToZ --------- 0.1% 2.0% 1 0.080s + +Finished transaction in 7.078 secs (6.728u,0.s) (successful) +Closed under the global context +total time: 3.976s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 99.0% 1 3.936s +─ReflectiveTactics.do_reflective_pipelin 0.0% 87.9% 1 3.496s +─ReflectiveTactics.solve_side_conditions 0.0% 86.9% 1 3.456s +─ReflectiveTactics.do_reify ------------ 0.0% 56.9% 1 2.264s +─Reify.Reify_rhs_gen ------------------- 1.8% 56.2% 1 2.236s +─Reify.do_reify_abs_goal --------------- 36.1% 36.5% 2 1.452s +─Reify.do_reifyf_goal ------------------ 34.8% 35.1% 29 1.396s +─ReflectiveTactics.solve_post_reified_si 0.6% 30.0% 1 1.192s +─UnifyAbstractReflexivity.unify_transfor 17.7% 21.7% 7 0.240s +─Glue.refine_to_reflective_glue' ------- 0.0% 11.1% 1 0.440s +─eexact -------------------------------- 10.9% 10.9% 31 0.024s +─ReflectiveTactics.unify_abstract_cbv_in 5.2% 7.3% 1 0.292s +─Glue.zrange_to_reflective ------------- 0.0% 7.1% 1 0.284s +─prove_interp_compile_correct ---------- 0.0% 5.7% 1 0.228s +─Glue.zrange_to_reflective_goal -------- 4.3% 5.5% 1 0.220s +─unify (constr) (constr) --------------- 5.3% 5.3% 6 0.084s +─rewrite ?EtaInterp.InterpExprEta ------ 5.2% 5.2% 1 0.208s +─rewrite H ----------------------------- 3.5% 3.5% 1 0.140s +─tac ----------------------------------- 1.9% 2.6% 2 0.104s +─reflexivity --------------------------- 2.2% 2.2% 7 0.028s +─Reify.transitivity_tt ----------------- 0.0% 2.2% 2 0.056s +─transitivity -------------------------- 2.0% 2.0% 5 0.048s +─Glue.split_BoundedWordToZ ------------- 0.1% 2.0% 1 0.080s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 99.0% 1 3.936s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 87.9% 1 3.496s + │└ReflectiveTactics.solve_side_conditio 0.0% 86.9% 1 3.456s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 56.9% 1 2.264s + │ │└Reify.Reify_rhs_gen --------------- 1.8% 56.2% 1 2.236s + │ │ ├─Reify.do_reify_abs_goal --------- 36.1% 36.5% 2 1.452s + │ │ │└Reify.do_reifyf_goal ------------ 34.8% 35.1% 29 1.396s + │ │ │└eexact -------------------------- 10.1% 10.1% 29 0.024s + │ │ ├─prove_interp_compile_correct ---- 0.0% 5.7% 1 0.228s + │ │ │└rewrite ?EtaInterp.InterpExprEta 5.2% 5.2% 1 0.208s + │ │ ├─rewrite H ----------------------- 3.5% 3.5% 1 0.140s + │ │ ├─tac ----------------------------- 1.9% 2.6% 1 0.104s + │ │ └─Reify.transitivity_tt ----------- 0.0% 2.2% 2 0.056s + │ │ â””transitivity -------------------- 2.0% 2.0% 4 0.048s + │ └─ReflectiveTactics.solve_post_reifie 0.6% 30.0% 1 1.192s + │ ├─UnifyAbstractReflexivity.unify_tr 17.7% 21.7% 7 0.240s + │ │└unify (constr) (constr) --------- 3.2% 3.2% 5 0.048s + │ └─ReflectiveTactics.unify_abstract_ 5.2% 7.3% 1 0.292s + │ â””unify (constr) (constr) --------- 2.1% 2.1% 1 0.084s + └─Glue.refine_to_reflective_glue' ----- 0.0% 11.1% 1 0.440s + ├─Glue.zrange_to_reflective --------- 0.0% 7.1% 1 0.284s + │└Glue.zrange_to_reflective_goal ---- 4.3% 5.5% 1 0.220s + └─Glue.split_BoundedWordToZ --------- 0.1% 2.0% 1 0.080s + +src/Specific/X25519/C64/fecarry (real: 27.11, user: 24.99, sys: 0.21, mem: 786052 ko) +COQC src/Specific/solinas32_2e255m765_12limbs/Synthesis.v +src/Specific/solinas32_2e255m765_12limbs/Synthesis (real: 40.13, user: 36.92, sys: 0.26, mem: 728464 ko) +COQC src/Specific/solinas32_2e255m765_13limbs/Synthesis.v +src/Specific/solinas32_2e255m765_13limbs/Synthesis (real: 49.44, user: 45.75, sys: 0.18, mem: 744240 ko) +COQC src/Specific/X25519/C64/femul.v +Finished transaction in 8.415 secs (7.664u,0.015s) (successful) +total time: 7.616s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 94.8% 1 7.220s +─ReflectiveTactics.do_reflective_pipelin 0.0% 85.0% 1 6.476s +─ReflectiveTactics.solve_side_conditions 0.0% 84.2% 1 6.416s +─ReflectiveTactics.do_reify ------------ 0.0% 50.3% 1 3.832s +─Reify.Reify_rhs_gen ------------------- 1.8% 49.4% 1 3.760s +─ReflectiveTactics.solve_post_reified_si 0.5% 33.9% 1 2.584s +─Reify.do_reify_abs_goal --------------- 31.1% 31.4% 2 2.392s +─Reify.do_reifyf_goal ------------------ 30.0% 30.3% 58 1.528s +─UnifyAbstractReflexivity.unify_transfor 22.1% 27.3% 7 0.600s +─Glue.refine_to_reflective_glue' ------- 0.0% 9.8% 1 0.744s +─eexact -------------------------------- 8.2% 8.2% 60 0.024s +─Glue.zrange_to_reflective ------------- 0.1% 6.8% 1 0.516s +─unify (constr) (constr) --------------- 5.9% 5.9% 6 0.124s +─prove_interp_compile_correct ---------- 0.0% 5.8% 1 0.444s +─ReflectiveTactics.unify_abstract_cbv_in 3.9% 5.7% 1 0.432s +─rewrite ?EtaInterp.InterpExprEta ------ 5.4% 5.4% 1 0.408s +─synthesize ---------------------------- 0.0% 5.2% 1 0.396s +─Glue.zrange_to_reflective_goal -------- 3.0% 5.0% 1 0.384s +─IntegrationTestTemporaryMiscCommon.do_r 0.1% 4.8% 1 0.364s +─change G' ----------------------------- 3.9% 3.9% 1 0.300s +─rewrite H ----------------------------- 3.0% 3.0% 1 0.232s +─tac ----------------------------------- 1.5% 2.3% 2 0.176s +─Reify.transitivity_tt ----------------- 0.0% 2.1% 2 0.092s +─reflexivity --------------------------- 2.0% 2.0% 7 0.052s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 94.8% 1 7.220s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 85.0% 1 6.476s + │└ReflectiveTactics.solve_side_conditio 0.0% 84.2% 1 6.416s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 50.3% 1 3.832s + │ │└Reify.Reify_rhs_gen --------------- 1.8% 49.4% 1 3.760s + │ │ ├─Reify.do_reify_abs_goal --------- 31.1% 31.4% 2 2.392s + │ │ │└Reify.do_reifyf_goal ------------ 30.0% 30.3% 58 1.528s + │ │ │└eexact -------------------------- 7.6% 7.6% 58 0.020s + │ │ ├─prove_interp_compile_correct ---- 0.0% 5.8% 1 0.444s + │ │ │└rewrite ?EtaInterp.InterpExprEta 5.4% 5.4% 1 0.408s + │ │ ├─rewrite H ----------------------- 3.0% 3.0% 1 0.232s + │ │ ├─tac ----------------------------- 1.5% 2.3% 1 0.176s + │ │ └─Reify.transitivity_tt ----------- 0.0% 2.1% 2 0.092s + │ └─ReflectiveTactics.solve_post_reifie 0.5% 33.9% 1 2.584s + │ ├─UnifyAbstractReflexivity.unify_tr 22.1% 27.3% 7 0.600s + │ │└unify (constr) (constr) --------- 4.3% 4.3% 5 0.096s + │ └─ReflectiveTactics.unify_abstract_ 3.9% 5.7% 1 0.432s + └─Glue.refine_to_reflective_glue' ----- 0.0% 9.8% 1 0.744s + â””Glue.zrange_to_reflective ----------- 0.1% 6.8% 1 0.516s + â””Glue.zrange_to_reflective_goal ------ 3.0% 5.0% 1 0.384s +─synthesize ---------------------------- 0.0% 5.2% 1 0.396s +â””IntegrationTestTemporaryMiscCommon.do_r 0.1% 4.8% 1 0.364s +â””change G' ----------------------------- 3.9% 3.9% 1 0.300s + +Finished transaction in 14.616 secs (13.528u,0.008s) (successful) +Closed under the global context +total time: 7.616s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 94.8% 1 7.220s +─ReflectiveTactics.do_reflective_pipelin 0.0% 85.0% 1 6.476s +─ReflectiveTactics.solve_side_conditions 0.0% 84.2% 1 6.416s +─ReflectiveTactics.do_reify ------------ 0.0% 50.3% 1 3.832s +─Reify.Reify_rhs_gen ------------------- 1.8% 49.4% 1 3.760s +─ReflectiveTactics.solve_post_reified_si 0.5% 33.9% 1 2.584s +─Reify.do_reify_abs_goal --------------- 31.1% 31.4% 2 2.392s +─Reify.do_reifyf_goal ------------------ 30.0% 30.3% 58 1.528s +─UnifyAbstractReflexivity.unify_transfor 22.1% 27.3% 7 0.600s +─Glue.refine_to_reflective_glue' ------- 0.0% 9.8% 1 0.744s +─eexact -------------------------------- 8.2% 8.2% 60 0.024s +─Glue.zrange_to_reflective ------------- 0.1% 6.8% 1 0.516s +─unify (constr) (constr) --------------- 5.9% 5.9% 6 0.124s +─prove_interp_compile_correct ---------- 0.0% 5.8% 1 0.444s +─ReflectiveTactics.unify_abstract_cbv_in 3.9% 5.7% 1 0.432s +─rewrite ?EtaInterp.InterpExprEta ------ 5.4% 5.4% 1 0.408s +─synthesize ---------------------------- 0.0% 5.2% 1 0.396s +─Glue.zrange_to_reflective_goal -------- 3.0% 5.0% 1 0.384s +─IntegrationTestTemporaryMiscCommon.do_r 0.1% 4.8% 1 0.364s +─change G' ----------------------------- 3.9% 3.9% 1 0.300s +─rewrite H ----------------------------- 3.0% 3.0% 1 0.232s +─tac ----------------------------------- 1.5% 2.3% 2 0.176s +─Reify.transitivity_tt ----------------- 0.0% 2.1% 2 0.092s +─reflexivity --------------------------- 2.0% 2.0% 7 0.052s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 94.8% 1 7.220s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 85.0% 1 6.476s + │└ReflectiveTactics.solve_side_conditio 0.0% 84.2% 1 6.416s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 50.3% 1 3.832s + │ │└Reify.Reify_rhs_gen --------------- 1.8% 49.4% 1 3.760s + │ │ ├─Reify.do_reify_abs_goal --------- 31.1% 31.4% 2 2.392s + │ │ │└Reify.do_reifyf_goal ------------ 30.0% 30.3% 58 1.528s + │ │ │└eexact -------------------------- 7.6% 7.6% 58 0.020s + │ │ ├─prove_interp_compile_correct ---- 0.0% 5.8% 1 0.444s + │ │ │└rewrite ?EtaInterp.InterpExprEta 5.4% 5.4% 1 0.408s + │ │ ├─rewrite H ----------------------- 3.0% 3.0% 1 0.232s + │ │ ├─tac ----------------------------- 1.5% 2.3% 1 0.176s + │ │ └─Reify.transitivity_tt ----------- 0.0% 2.1% 2 0.092s + │ └─ReflectiveTactics.solve_post_reifie 0.5% 33.9% 1 2.584s + │ ├─UnifyAbstractReflexivity.unify_tr 22.1% 27.3% 7 0.600s + │ │└unify (constr) (constr) --------- 4.3% 4.3% 5 0.096s + │ └─ReflectiveTactics.unify_abstract_ 3.9% 5.7% 1 0.432s + └─Glue.refine_to_reflective_glue' ----- 0.0% 9.8% 1 0.744s + â””Glue.zrange_to_reflective ----------- 0.1% 6.8% 1 0.516s + â””Glue.zrange_to_reflective_goal ------ 3.0% 5.0% 1 0.384s +─synthesize ---------------------------- 0.0% 5.2% 1 0.396s +â””IntegrationTestTemporaryMiscCommon.do_r 0.1% 4.8% 1 0.364s +â””change G' ----------------------------- 3.9% 3.9% 1 0.300s + +src/Specific/X25519/C64/femul (real: 39.72, user: 36.32, sys: 0.26, mem: 825448 ko) +COQC src/Specific/X25519/C64/feaddDisplay > src/Specific/X25519/C64/feaddDisplay.log +COQC src/Specific/X25519/C64/fecarryDisplay > src/Specific/X25519/C64/fecarryDisplay.log +COQC src/Specific/X25519/C64/fesub.v +Finished transaction in 3.513 secs (3.211u,0.s) (successful) +total time: 3.164s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.6% 1 3.088s +─ReflectiveTactics.do_reflective_pipelin 0.0% 74.1% 1 2.344s +─ReflectiveTactics.solve_side_conditions 0.0% 72.9% 1 2.308s +─ReflectiveTactics.do_reify ------------ 0.0% 38.6% 1 1.220s +─Reify.Reify_rhs_gen ------------------- 1.5% 37.2% 1 1.176s +─ReflectiveTactics.solve_post_reified_si 0.9% 34.4% 1 1.088s +─UnifyAbstractReflexivity.unify_transfor 19.2% 23.9% 7 0.204s +─Glue.refine_to_reflective_glue' ------- 0.0% 23.5% 1 0.744s +─Reify.do_reify_abs_goal --------------- 19.2% 19.5% 2 0.616s +─Reify.do_reifyf_goal ------------------ 18.0% 18.3% 16 0.580s +─Glue.zrange_to_reflective ------------- 0.1% 15.4% 1 0.488s +─Glue.zrange_to_reflective_goal -------- 6.8% 11.5% 1 0.364s +─ReflectiveTactics.unify_abstract_cbv_in 6.2% 9.0% 1 0.284s +─unify (constr) (constr) --------------- 5.9% 5.9% 6 0.080s +─Glue.pattern_sig_sig_assoc ------------ 0.0% 4.6% 1 0.144s +─eexact -------------------------------- 4.4% 4.4% 18 0.012s +─Glue.pattern_proj1_sig_in_sig --------- 1.4% 4.3% 1 0.136s +─prove_interp_compile_correct ---------- 0.0% 3.9% 1 0.124s +─rewrite H ----------------------------- 3.8% 3.8% 1 0.120s +─assert (H : is_bounded_by' bounds (map' 3.8% 3.8% 2 0.064s +─rewrite ?EtaInterp.InterpExprEta ------ 3.5% 3.5% 1 0.112s +─pose proof (pf : Interpretation.Bo 2.9% 2.9% 1 0.092s +─Glue.split_BoundedWordToZ ------------- 0.1% 2.8% 1 0.088s +─tac ----------------------------------- 1.9% 2.5% 2 0.080s +─reflexivity --------------------------- 2.4% 2.4% 7 0.028s +─synthesize ---------------------------- 0.0% 2.4% 1 0.076s +─destruct_sig -------------------------- 0.0% 2.4% 4 0.040s +─destruct x ---------------------------- 2.4% 2.4% 4 0.032s +─clearbody (ne_var_list) --------------- 2.3% 2.3% 4 0.060s +─Reify.transitivity_tt ----------------- 0.1% 2.3% 2 0.036s +─transitivity -------------------------- 2.1% 2.1% 5 0.032s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.6% 1 3.088s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 74.1% 1 2.344s + │└ReflectiveTactics.solve_side_conditio 0.0% 72.9% 1 2.308s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 38.6% 1 1.220s + │ │└Reify.Reify_rhs_gen --------------- 1.5% 37.2% 1 1.176s + │ │ ├─Reify.do_reify_abs_goal --------- 19.2% 19.5% 2 0.616s + │ │ │└Reify.do_reifyf_goal ------------ 18.0% 18.3% 16 0.580s + │ │ │└eexact -------------------------- 3.9% 3.9% 16 0.012s + │ │ ├─prove_interp_compile_correct ---- 0.0% 3.9% 1 0.124s + │ │ │└rewrite ?EtaInterp.InterpExprEta 3.5% 3.5% 1 0.112s + │ │ ├─rewrite H ----------------------- 3.8% 3.8% 1 0.120s + │ │ ├─tac ----------------------------- 1.9% 2.5% 1 0.080s + │ │ └─Reify.transitivity_tt ----------- 0.1% 2.3% 2 0.036s + │ │ â””transitivity -------------------- 2.0% 2.0% 4 0.032s + │ └─ReflectiveTactics.solve_post_reifie 0.9% 34.4% 1 1.088s + │ ├─UnifyAbstractReflexivity.unify_tr 19.2% 23.9% 7 0.204s + │ │└unify (constr) (constr) --------- 3.4% 3.4% 5 0.036s + │ └─ReflectiveTactics.unify_abstract_ 6.2% 9.0% 1 0.284s + │ â””unify (constr) (constr) --------- 2.5% 2.5% 1 0.080s + └─Glue.refine_to_reflective_glue' ----- 0.0% 23.5% 1 0.744s + ├─Glue.zrange_to_reflective --------- 0.1% 15.4% 1 0.488s + │ ├─Glue.zrange_to_reflective_goal -- 6.8% 11.5% 1 0.364s + │ │└pose proof (pf : Interpretat 2.9% 2.9% 1 0.092s + │ └─assert (H : is_bounded_by' bounds 3.8% 3.8% 2 0.064s + ├─Glue.pattern_sig_sig_assoc -------- 0.0% 4.6% 1 0.144s + │└Glue.pattern_proj1_sig_in_sig ----- 1.4% 4.3% 1 0.136s + └─Glue.split_BoundedWordToZ --------- 0.1% 2.8% 1 0.088s + â””destruct_sig ---------------------- 0.0% 2.4% 4 0.040s +─synthesize ---------------------------- 0.0% 2.4% 1 0.076s + +Finished transaction in 6.12 secs (5.64u,0.008s) (successful) +Closed under the global context +total time: 3.164s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.6% 1 3.088s +─ReflectiveTactics.do_reflective_pipelin 0.0% 74.1% 1 2.344s +─ReflectiveTactics.solve_side_conditions 0.0% 72.9% 1 2.308s +─ReflectiveTactics.do_reify ------------ 0.0% 38.6% 1 1.220s +─Reify.Reify_rhs_gen ------------------- 1.5% 37.2% 1 1.176s +─ReflectiveTactics.solve_post_reified_si 0.9% 34.4% 1 1.088s +─UnifyAbstractReflexivity.unify_transfor 19.2% 23.9% 7 0.204s +─Glue.refine_to_reflective_glue' ------- 0.0% 23.5% 1 0.744s +─Reify.do_reify_abs_goal --------------- 19.2% 19.5% 2 0.616s +─Reify.do_reifyf_goal ------------------ 18.0% 18.3% 16 0.580s +─Glue.zrange_to_reflective ------------- 0.1% 15.4% 1 0.488s +─Glue.zrange_to_reflective_goal -------- 6.8% 11.5% 1 0.364s +─ReflectiveTactics.unify_abstract_cbv_in 6.2% 9.0% 1 0.284s +─unify (constr) (constr) --------------- 5.9% 5.9% 6 0.080s +─Glue.pattern_sig_sig_assoc ------------ 0.0% 4.6% 1 0.144s +─eexact -------------------------------- 4.4% 4.4% 18 0.012s +─Glue.pattern_proj1_sig_in_sig --------- 1.4% 4.3% 1 0.136s +─prove_interp_compile_correct ---------- 0.0% 3.9% 1 0.124s +─rewrite H ----------------------------- 3.8% 3.8% 1 0.120s +─assert (H : is_bounded_by' bounds (map' 3.8% 3.8% 2 0.064s +─rewrite ?EtaInterp.InterpExprEta ------ 3.5% 3.5% 1 0.112s +─pose proof (pf : Interpretation.Bo 2.9% 2.9% 1 0.092s +─Glue.split_BoundedWordToZ ------------- 0.1% 2.8% 1 0.088s +─tac ----------------------------------- 1.9% 2.5% 2 0.080s +─reflexivity --------------------------- 2.4% 2.4% 7 0.028s +─synthesize ---------------------------- 0.0% 2.4% 1 0.076s +─destruct_sig -------------------------- 0.0% 2.4% 4 0.040s +─destruct x ---------------------------- 2.4% 2.4% 4 0.032s +─clearbody (ne_var_list) --------------- 2.3% 2.3% 4 0.060s +─Reify.transitivity_tt ----------------- 0.1% 2.3% 2 0.036s +─transitivity -------------------------- 2.1% 2.1% 5 0.032s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.6% 1 3.088s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 74.1% 1 2.344s + │└ReflectiveTactics.solve_side_conditio 0.0% 72.9% 1 2.308s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 38.6% 1 1.220s + │ │└Reify.Reify_rhs_gen --------------- 1.5% 37.2% 1 1.176s + │ │ ├─Reify.do_reify_abs_goal --------- 19.2% 19.5% 2 0.616s + │ │ │└Reify.do_reifyf_goal ------------ 18.0% 18.3% 16 0.580s + │ │ │└eexact -------------------------- 3.9% 3.9% 16 0.012s + │ │ ├─prove_interp_compile_correct ---- 0.0% 3.9% 1 0.124s + │ │ │└rewrite ?EtaInterp.InterpExprEta 3.5% 3.5% 1 0.112s + │ │ ├─rewrite H ----------------------- 3.8% 3.8% 1 0.120s + │ │ ├─tac ----------------------------- 1.9% 2.5% 1 0.080s + │ │ └─Reify.transitivity_tt ----------- 0.1% 2.3% 2 0.036s + │ │ â””transitivity -------------------- 2.0% 2.0% 4 0.032s + │ └─ReflectiveTactics.solve_post_reifie 0.9% 34.4% 1 1.088s + │ ├─UnifyAbstractReflexivity.unify_tr 19.2% 23.9% 7 0.204s + │ │└unify (constr) (constr) --------- 3.4% 3.4% 5 0.036s + │ └─ReflectiveTactics.unify_abstract_ 6.2% 9.0% 1 0.284s + │ â””unify (constr) (constr) --------- 2.5% 2.5% 1 0.080s + └─Glue.refine_to_reflective_glue' ----- 0.0% 23.5% 1 0.744s + ├─Glue.zrange_to_reflective --------- 0.1% 15.4% 1 0.488s + │ ├─Glue.zrange_to_reflective_goal -- 6.8% 11.5% 1 0.364s + │ │└pose proof (pf : Interpretat 2.9% 2.9% 1 0.092s + │ └─assert (H : is_bounded_by' bounds 3.8% 3.8% 2 0.064s + ├─Glue.pattern_sig_sig_assoc -------- 0.0% 4.6% 1 0.144s + │└Glue.pattern_proj1_sig_in_sig ----- 1.4% 4.3% 1 0.136s + └─Glue.split_BoundedWordToZ --------- 0.1% 2.8% 1 0.088s + â””destruct_sig ---------------------- 0.0% 2.4% 4 0.040s +─synthesize ---------------------------- 0.0% 2.4% 1 0.076s + +src/Specific/X25519/C64/fesub (real: 24.71, user: 22.65, sys: 0.24, mem: 778792 ko) +COQC src/Specific/X25519/C64/fesquare.v +Finished transaction in 6.132 secs (5.516u,0.012s) (successful) +total time: 5.480s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize ---------------------------- -0.0% 100.0% 1 5.480s +─Pipeline.refine_reflectively_gen ------ 0.0% 95.7% 1 5.244s +─ReflectiveTactics.do_reflective_pipelin 0.0% 88.6% 1 4.856s +─ReflectiveTactics.solve_side_conditions 0.0% 87.7% 1 4.804s +─ReflectiveTactics.do_reify ------------ 0.0% 53.3% 1 2.920s +─Reify.Reify_rhs_gen ------------------- 2.0% 52.5% 1 2.876s +─ReflectiveTactics.solve_post_reified_si 0.6% 34.4% 1 1.884s +─Reify.do_reify_abs_goal --------------- 33.2% 33.6% 2 1.844s +─Reify.do_reifyf_goal ------------------ 31.5% 32.0% 47 1.392s +─UnifyAbstractReflexivity.unify_transfor 21.9% 26.6% 7 0.400s +─eexact -------------------------------- 10.0% 10.0% 49 0.028s +─Glue.refine_to_reflective_glue' ------- 0.0% 7.1% 1 0.388s +─ReflectiveTactics.unify_abstract_cbv_in 5.0% 6.9% 1 0.380s +─unify (constr) (constr) --------------- 5.8% 5.8% 6 0.104s +─prove_interp_compile_correct ---------- 0.0% 5.8% 1 0.316s +─rewrite ?EtaInterp.InterpExprEta ------ 5.3% 5.3% 1 0.288s +─Glue.zrange_to_reflective ------------- 0.1% 5.1% 1 0.280s +─IntegrationTestTemporaryMiscCommon.do_r 0.1% 4.0% 1 0.220s +─Glue.zrange_to_reflective_goal -------- 3.1% 3.9% 1 0.212s +─change G' ----------------------------- 3.4% 3.4% 1 0.184s +─tac ----------------------------------- 2.0% 2.8% 2 0.156s +─rewrite H ----------------------------- 2.8% 2.8% 1 0.156s +─reflexivity --------------------------- 2.8% 2.8% 7 0.064s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize ---------------------------- -0.0% 100.0% 1 5.480s + ├─Pipeline.refine_reflectively_gen ---- 0.0% 95.7% 1 5.244s + │ ├─ReflectiveTactics.do_reflective_pip 0.0% 88.6% 1 4.856s + │ │└ReflectiveTactics.solve_side_condit 0.0% 87.7% 1 4.804s + │ │ ├─ReflectiveTactics.do_reify ------ 0.0% 53.3% 1 2.920s + │ │ │└Reify.Reify_rhs_gen ------------- 2.0% 52.5% 1 2.876s + │ │ │ ├─Reify.do_reify_abs_goal ------- 33.2% 33.6% 2 1.844s + │ │ │ │└Reify.do_reifyf_goal ---------- 31.5% 32.0% 47 1.392s + │ │ │ │└eexact ------------------------ 9.1% 9.1% 47 0.024s + │ │ │ ├─prove_interp_compile_correct -- 0.0% 5.8% 1 0.316s + │ │ │ │└rewrite ?EtaInterp.InterpExprEt 5.3% 5.3% 1 0.288s + │ │ │ ├─tac --------------------------- 2.0% 2.8% 1 0.156s + │ │ │ └─rewrite H --------------------- 2.8% 2.8% 1 0.156s + │ │ └─ReflectiveTactics.solve_post_reif 0.6% 34.4% 1 1.884s + │ │ ├─UnifyAbstractReflexivity.unify_ 21.9% 26.6% 7 0.400s + │ │ │└unify (constr) (constr) ------- 3.9% 3.9% 5 0.072s + │ │ └─ReflectiveTactics.unify_abstrac 5.0% 6.9% 1 0.380s + │ └─Glue.refine_to_reflective_glue' --- 0.0% 7.1% 1 0.388s + │ â””Glue.zrange_to_reflective --------- 0.1% 5.1% 1 0.280s + │ â””Glue.zrange_to_reflective_goal ---- 3.1% 3.9% 1 0.212s + └─IntegrationTestTemporaryMiscCommon.do 0.1% 4.0% 1 0.220s + â””change G' --------------------------- 3.4% 3.4% 1 0.184s + +Finished transaction in 10.475 secs (9.728u,0.007s) (successful) +Closed under the global context +total time: 5.480s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize ---------------------------- -0.0% 100.0% 1 5.480s +─Pipeline.refine_reflectively_gen ------ 0.0% 95.7% 1 5.244s +─ReflectiveTactics.do_reflective_pipelin 0.0% 88.6% 1 4.856s +─ReflectiveTactics.solve_side_conditions 0.0% 87.7% 1 4.804s +─ReflectiveTactics.do_reify ------------ 0.0% 53.3% 1 2.920s +─Reify.Reify_rhs_gen ------------------- 2.0% 52.5% 1 2.876s +─ReflectiveTactics.solve_post_reified_si 0.6% 34.4% 1 1.884s +─Reify.do_reify_abs_goal --------------- 33.2% 33.6% 2 1.844s +─Reify.do_reifyf_goal ------------------ 31.5% 32.0% 47 1.392s +─UnifyAbstractReflexivity.unify_transfor 21.9% 26.6% 7 0.400s +─eexact -------------------------------- 10.0% 10.0% 49 0.028s +─Glue.refine_to_reflective_glue' ------- 0.0% 7.1% 1 0.388s +─ReflectiveTactics.unify_abstract_cbv_in 5.0% 6.9% 1 0.380s +─unify (constr) (constr) --------------- 5.8% 5.8% 6 0.104s +─prove_interp_compile_correct ---------- 0.0% 5.8% 1 0.316s +─rewrite ?EtaInterp.InterpExprEta ------ 5.3% 5.3% 1 0.288s +─Glue.zrange_to_reflective ------------- 0.1% 5.1% 1 0.280s +─IntegrationTestTemporaryMiscCommon.do_r 0.1% 4.0% 1 0.220s +─Glue.zrange_to_reflective_goal -------- 3.1% 3.9% 1 0.212s +─change G' ----------------------------- 3.4% 3.4% 1 0.184s +─tac ----------------------------------- 2.0% 2.8% 2 0.156s +─rewrite H ----------------------------- 2.8% 2.8% 1 0.156s +─reflexivity --------------------------- 2.8% 2.8% 7 0.064s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize ---------------------------- -0.0% 100.0% 1 5.480s + ├─Pipeline.refine_reflectively_gen ---- 0.0% 95.7% 1 5.244s + │ ├─ReflectiveTactics.do_reflective_pip 0.0% 88.6% 1 4.856s + │ │└ReflectiveTactics.solve_side_condit 0.0% 87.7% 1 4.804s + │ │ ├─ReflectiveTactics.do_reify ------ 0.0% 53.3% 1 2.920s + │ │ │└Reify.Reify_rhs_gen ------------- 2.0% 52.5% 1 2.876s + │ │ │ ├─Reify.do_reify_abs_goal ------- 33.2% 33.6% 2 1.844s + │ │ │ │└Reify.do_reifyf_goal ---------- 31.5% 32.0% 47 1.392s + │ │ │ │└eexact ------------------------ 9.1% 9.1% 47 0.024s + │ │ │ ├─prove_interp_compile_correct -- 0.0% 5.8% 1 0.316s + │ │ │ │└rewrite ?EtaInterp.InterpExprEt 5.3% 5.3% 1 0.288s + │ │ │ ├─tac --------------------------- 2.0% 2.8% 1 0.156s + │ │ │ └─rewrite H --------------------- 2.8% 2.8% 1 0.156s + │ │ └─ReflectiveTactics.solve_post_reif 0.6% 34.4% 1 1.884s + │ │ ├─UnifyAbstractReflexivity.unify_ 21.9% 26.6% 7 0.400s + │ │ │└unify (constr) (constr) ------- 3.9% 3.9% 5 0.072s + │ │ └─ReflectiveTactics.unify_abstrac 5.0% 6.9% 1 0.380s + │ └─Glue.refine_to_reflective_glue' --- 0.0% 7.1% 1 0.388s + │ â””Glue.zrange_to_reflective --------- 0.1% 5.1% 1 0.280s + │ â””Glue.zrange_to_reflective_goal ---- 3.1% 3.9% 1 0.212s + └─IntegrationTestTemporaryMiscCommon.do 0.1% 4.0% 1 0.220s + â””change G' --------------------------- 3.4% 3.4% 1 0.184s + +src/Specific/X25519/C64/fesquare (real: 33.08, user: 30.13, sys: 0.24, mem: 799620 ko) +COQC src/Specific/X25519/C64/femulDisplay > src/Specific/X25519/C64/femulDisplay.log +COQC src/Specific/X25519/C64/freeze.v +Finished transaction in 7.307 secs (6.763u,0.011s) (successful) +total time: 6.732s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_freeze --------------------- 0.0% 100.0% 1 6.732s +─Pipeline.refine_reflectively_gen ------ 0.0% 99.3% 1 6.684s +─ReflectiveTactics.do_reflective_pipelin 0.0% 92.8% 1 6.248s +─ReflectiveTactics.solve_side_conditions 0.0% 92.0% 1 6.192s +─ReflectiveTactics.do_reify ------------ -0.0% 60.3% 1 4.060s +─Reify.Reify_rhs_gen ------------------- 1.5% 59.6% 1 4.012s +─Reify.do_reify_abs_goal --------------- 42.4% 42.7% 2 2.876s +─Reify.do_reifyf_goal ------------------ 41.3% 41.7% 129 2.804s +─ReflectiveTactics.solve_post_reified_si 0.6% 31.7% 1 2.132s +─UnifyAbstractReflexivity.unify_transfor 21.7% 25.8% 7 0.424s +─eexact -------------------------------- 13.7% 13.7% 131 0.036s +─Glue.refine_to_reflective_glue' ------- 0.0% 6.5% 1 0.436s +─prove_interp_compile_correct ---------- 0.0% 5.1% 1 0.344s +─ReflectiveTactics.unify_abstract_cbv_in 3.4% 5.0% 1 0.336s +─rewrite ?EtaInterp.InterpExprEta ------ 4.7% 4.7% 1 0.316s +─unify (constr) (constr) --------------- 4.6% 4.6% 6 0.100s +─Glue.zrange_to_reflective ------------- 0.0% 4.2% 1 0.280s +─Glue.zrange_to_reflective_goal -------- 2.4% 3.3% 1 0.220s +─Reify.transitivity_tt ----------------- 0.1% 2.6% 2 0.116s +─rewrite H ----------------------------- 2.6% 2.6% 1 0.172s +─tac ----------------------------------- 1.5% 2.3% 2 0.156s +─reflexivity --------------------------- 2.3% 2.3% 7 0.052s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_freeze --------------------- 0.0% 100.0% 1 6.732s +â””Pipeline.refine_reflectively_gen ------ 0.0% 99.3% 1 6.684s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 92.8% 1 6.248s + │└ReflectiveTactics.solve_side_conditio 0.0% 92.0% 1 6.192s + │ ├─ReflectiveTactics.do_reify -------- -0.0% 60.3% 1 4.060s + │ │└Reify.Reify_rhs_gen --------------- 1.5% 59.6% 1 4.012s + │ │ ├─Reify.do_reify_abs_goal --------- 42.4% 42.7% 2 2.876s + │ │ │└Reify.do_reifyf_goal ------------ 41.3% 41.7% 129 2.804s + │ │ │└eexact -------------------------- 13.0% 13.0% 129 0.036s + │ │ ├─prove_interp_compile_correct ---- 0.0% 5.1% 1 0.344s + │ │ │└rewrite ?EtaInterp.InterpExprEta 4.7% 4.7% 1 0.316s + │ │ ├─Reify.transitivity_tt ----------- 0.1% 2.6% 2 0.116s + │ │ ├─rewrite H ----------------------- 2.6% 2.6% 1 0.172s + │ │ └─tac ----------------------------- 1.5% 2.3% 1 0.156s + │ └─ReflectiveTactics.solve_post_reifie 0.6% 31.7% 1 2.132s + │ ├─UnifyAbstractReflexivity.unify_tr 21.7% 25.8% 7 0.424s + │ │└unify (constr) (constr) --------- 3.1% 3.1% 5 0.084s + │ └─ReflectiveTactics.unify_abstract_ 3.4% 5.0% 1 0.336s + └─Glue.refine_to_reflective_glue' ----- 0.0% 6.5% 1 0.436s + â””Glue.zrange_to_reflective ----------- 0.0% 4.2% 1 0.280s + â””Glue.zrange_to_reflective_goal ------ 2.4% 3.3% 1 0.220s + +Finished transaction in 10.495 secs (9.756u,0.s) (successful) +Closed under the global context +total time: 6.732s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_freeze --------------------- 0.0% 100.0% 1 6.732s +─Pipeline.refine_reflectively_gen ------ 0.0% 99.3% 1 6.684s +─ReflectiveTactics.do_reflective_pipelin 0.0% 92.8% 1 6.248s +─ReflectiveTactics.solve_side_conditions 0.0% 92.0% 1 6.192s +─ReflectiveTactics.do_reify ------------ -0.0% 60.3% 1 4.060s +─Reify.Reify_rhs_gen ------------------- 1.5% 59.6% 1 4.012s +─Reify.do_reify_abs_goal --------------- 42.4% 42.7% 2 2.876s +─Reify.do_reifyf_goal ------------------ 41.3% 41.7% 129 2.804s +─ReflectiveTactics.solve_post_reified_si 0.6% 31.7% 1 2.132s +─UnifyAbstractReflexivity.unify_transfor 21.7% 25.8% 7 0.424s +─eexact -------------------------------- 13.7% 13.7% 131 0.036s +─Glue.refine_to_reflective_glue' ------- 0.0% 6.5% 1 0.436s +─prove_interp_compile_correct ---------- 0.0% 5.1% 1 0.344s +─ReflectiveTactics.unify_abstract_cbv_in 3.4% 5.0% 1 0.336s +─rewrite ?EtaInterp.InterpExprEta ------ 4.7% 4.7% 1 0.316s +─unify (constr) (constr) --------------- 4.6% 4.6% 6 0.100s +─Glue.zrange_to_reflective ------------- 0.0% 4.2% 1 0.280s +─Glue.zrange_to_reflective_goal -------- 2.4% 3.3% 1 0.220s +─Reify.transitivity_tt ----------------- 0.1% 2.6% 2 0.116s +─rewrite H ----------------------------- 2.6% 2.6% 1 0.172s +─tac ----------------------------------- 1.5% 2.3% 2 0.156s +─reflexivity --------------------------- 2.3% 2.3% 7 0.052s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_freeze --------------------- 0.0% 100.0% 1 6.732s +â””Pipeline.refine_reflectively_gen ------ 0.0% 99.3% 1 6.684s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 92.8% 1 6.248s + │└ReflectiveTactics.solve_side_conditio 0.0% 92.0% 1 6.192s + │ ├─ReflectiveTactics.do_reify -------- -0.0% 60.3% 1 4.060s + │ │└Reify.Reify_rhs_gen --------------- 1.5% 59.6% 1 4.012s + │ │ ├─Reify.do_reify_abs_goal --------- 42.4% 42.7% 2 2.876s + │ │ │└Reify.do_reifyf_goal ------------ 41.3% 41.7% 129 2.804s + │ │ │└eexact -------------------------- 13.0% 13.0% 129 0.036s + │ │ ├─prove_interp_compile_correct ---- 0.0% 5.1% 1 0.344s + │ │ │└rewrite ?EtaInterp.InterpExprEta 4.7% 4.7% 1 0.316s + │ │ ├─Reify.transitivity_tt ----------- 0.1% 2.6% 2 0.116s + │ │ ├─rewrite H ----------------------- 2.6% 2.6% 1 0.172s + │ │ └─tac ----------------------------- 1.5% 2.3% 1 0.156s + │ └─ReflectiveTactics.solve_post_reifie 0.6% 31.7% 1 2.132s + │ ├─UnifyAbstractReflexivity.unify_tr 21.7% 25.8% 7 0.424s + │ │└unify (constr) (constr) --------- 3.1% 3.1% 5 0.084s + │ └─ReflectiveTactics.unify_abstract_ 3.4% 5.0% 1 0.336s + └─Glue.refine_to_reflective_glue' ----- 0.0% 6.5% 1 0.436s + â””Glue.zrange_to_reflective ----------- 0.0% 4.2% 1 0.280s + â””Glue.zrange_to_reflective_goal ------ 2.4% 3.3% 1 0.220s + +src/Specific/X25519/C64/freeze (real: 34.35, user: 31.50, sys: 0.24, mem: 828104 ko) +COQC src/Specific/NISTP256/AMD64/feadd.v +Finished transaction in 8.784 secs (8.176u,0.011s) (successful) +total time: 8.140s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 52.4% 1 4.268s +─synthesize_montgomery ----------------- 0.0% 47.6% 1 3.872s +─ReflectiveTactics.do_reflective_pipelin 0.0% 43.8% 1 3.568s +─ReflectiveTactics.solve_side_conditions 0.0% 43.2% 1 3.520s +─IntegrationTestTemporaryMiscCommon.fact 1.4% 23.6% 1 1.924s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 22.1% 1 1.796s +─ReflectiveTactics.do_reify ------------ 0.1% 21.7% 1 1.768s +─ReflectiveTactics.solve_post_reified_si 0.6% 21.5% 1 1.752s +─Reify.Reify_rhs_gen ------------------- 1.0% 20.9% 1 1.704s +─op_sig_side_conditions_t -------------- 0.0% 20.0% 1 1.624s +─DestructHyps.do_all_matches_then ------ 0.0% 20.0% 8 0.244s +─DestructHyps.do_one_match_then -------- 0.7% 19.9% 44 0.052s +─do_tac -------------------------------- 0.0% 19.2% 36 0.052s +─destruct H ---------------------------- 19.2% 19.2% 36 0.052s +─rewrite <- (lem : lemT) by by_tac ltac: 0.2% 17.3% 1 1.408s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 17.3% 1 1.408s +─by_tac -------------------------------- 0.0% 17.1% 4 0.504s +─rewrite <- (ZRange.is_bounded_by_None_r 16.7% 16.7% 8 0.344s +─UnifyAbstractReflexivity.unify_transfor 13.3% 16.1% 7 0.360s +─Reify.do_reify_abs_goal --------------- 9.9% 10.1% 2 0.820s +─Reify.do_reifyf_goal ------------------ 9.1% 9.3% 93 0.748s +─Glue.refine_to_reflective_glue' ------- 0.0% 8.6% 1 0.700s +─Glue.zrange_to_reflective ------------- 0.0% 5.3% 1 0.432s +─IntegrationTestTemporaryMiscCommon.do_s 0.0% 4.8% 1 0.388s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.9% 4.6% 3 0.368s +─ReflectiveTactics.unify_abstract_cbv_in 3.3% 4.5% 1 0.368s +─Glue.zrange_to_reflective_goal -------- 2.6% 4.0% 1 0.324s +─k ------------------------------------- 3.5% 3.6% 1 0.296s +─unify (constr) (constr) --------------- 3.3% 3.3% 8 0.092s +─rewrite H ----------------------------- 2.6% 2.6% 2 0.196s +─eexact -------------------------------- 2.6% 2.6% 95 0.024s +─prove_interp_compile_correct ---------- 0.0% 2.5% 1 0.204s +─apply (fun f => MapProjections.proj2 2.4% 2.4% 2 0.120s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 52.4% 1 4.268s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 43.8% 1 3.568s + │└ReflectiveTactics.solve_side_conditio 0.0% 43.2% 1 3.520s + │ ├─ReflectiveTactics.do_reify -------- 0.1% 21.7% 1 1.768s + │ │└Reify.Reify_rhs_gen --------------- 1.0% 20.9% 1 1.704s + │ │ ├─Reify.do_reify_abs_goal --------- 9.9% 10.1% 2 0.820s + │ │ │└Reify.do_reifyf_goal ------------ 9.1% 9.3% 93 0.748s + │ │ │└eexact -------------------------- 2.3% 2.3% 93 0.024s + │ │ ├─prove_interp_compile_correct ---- 0.0% 2.5% 1 0.204s + │ │ └─rewrite H ----------------------- 2.4% 2.4% 1 0.196s + │ └─ReflectiveTactics.solve_post_reifie 0.6% 21.5% 1 1.752s + │ ├─UnifyAbstractReflexivity.unify_tr 13.3% 16.1% 7 0.360s + │ │└unify (constr) (constr) --------- 2.2% 2.2% 5 0.064s + │ └─ReflectiveTactics.unify_abstract_ 3.3% 4.5% 1 0.368s + └─Glue.refine_to_reflective_glue' ----- 0.0% 8.6% 1 0.700s + â””Glue.zrange_to_reflective ----------- 0.0% 5.3% 1 0.432s + â””Glue.zrange_to_reflective_goal ------ 2.6% 4.0% 1 0.324s +─synthesize_montgomery ----------------- 0.0% 47.6% 1 3.872s + ├─IntegrationTestTemporaryMiscCommon.fa 1.4% 23.6% 1 1.924s + │└op_sig_side_conditions_t ------------ 0.0% 20.0% 1 1.624s + │ ├─DestructHyps.do_all_matches_then -- 0.0% 11.4% 4 0.244s + │ │└DestructHyps.do_one_match_then ---- 0.3% 11.4% 24 0.052s + │ │└do_tac ---------------------------- 0.0% 11.1% 20 0.052s + │ │└destruct H ------------------------ 11.1% 11.1% 20 0.052s + │ └─rewrite <- (ZRange.is_bounded_by_No 8.4% 8.4% 4 0.328s + └─IntegrationTestTemporaryMiscCommon.do 0.0% 22.1% 1 1.796s + ├─IntegrationTestTemporaryMiscCommon. 0.0% 17.3% 1 1.408s + │└rewrite <- (lem : lemT) by by_tac l 0.2% 17.3% 1 1.408s + │└by_tac ---------------------------- 0.0% 17.1% 4 0.504s + │ ├─DestructHyps.do_all_matches_then 0.0% 8.6% 4 0.184s + │ │└DestructHyps.do_one_match_then -- 0.3% 8.5% 20 0.052s + │ │└do_tac -------------------------- 0.0% 8.2% 16 0.052s + │ │└destruct H ---------------------- 8.2% 8.2% 16 0.052s + │ └─rewrite <- (ZRange.is_bounded_by_ 8.3% 8.3% 4 0.344s + └─IntegrationTestTemporaryMiscCommon. 0.0% 4.8% 1 0.388s + â””<Crypto.Util.Tactics.MoveLetIn.with 0.9% 4.6% 3 0.368s + â””k --------------------------------- 3.5% 3.6% 1 0.296s + +Finished transaction in 13.363 secs (12.516u,0.008s) (successful) +Closed under the global context +total time: 8.140s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 52.4% 1 4.268s +─synthesize_montgomery ----------------- 0.0% 47.6% 1 3.872s +─ReflectiveTactics.do_reflective_pipelin 0.0% 43.8% 1 3.568s +─ReflectiveTactics.solve_side_conditions 0.0% 43.2% 1 3.520s +─IntegrationTestTemporaryMiscCommon.fact 1.4% 23.6% 1 1.924s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 22.1% 1 1.796s +─ReflectiveTactics.do_reify ------------ 0.1% 21.7% 1 1.768s +─ReflectiveTactics.solve_post_reified_si 0.6% 21.5% 1 1.752s +─Reify.Reify_rhs_gen ------------------- 1.0% 20.9% 1 1.704s +─op_sig_side_conditions_t -------------- 0.0% 20.0% 1 1.624s +─DestructHyps.do_all_matches_then ------ 0.0% 20.0% 8 0.244s +─DestructHyps.do_one_match_then -------- 0.7% 19.9% 44 0.052s +─do_tac -------------------------------- 0.0% 19.2% 36 0.052s +─destruct H ---------------------------- 19.2% 19.2% 36 0.052s +─rewrite <- (lem : lemT) by by_tac ltac: 0.2% 17.3% 1 1.408s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 17.3% 1 1.408s +─by_tac -------------------------------- 0.0% 17.1% 4 0.504s +─rewrite <- (ZRange.is_bounded_by_None_r 16.7% 16.7% 8 0.344s +─UnifyAbstractReflexivity.unify_transfor 13.3% 16.1% 7 0.360s +─Reify.do_reify_abs_goal --------------- 9.9% 10.1% 2 0.820s +─Reify.do_reifyf_goal ------------------ 9.1% 9.3% 93 0.748s +─Glue.refine_to_reflective_glue' ------- 0.0% 8.6% 1 0.700s +─Glue.zrange_to_reflective ------------- 0.0% 5.3% 1 0.432s +─IntegrationTestTemporaryMiscCommon.do_s 0.0% 4.8% 1 0.388s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.9% 4.6% 3 0.368s +─ReflectiveTactics.unify_abstract_cbv_in 3.3% 4.5% 1 0.368s +─Glue.zrange_to_reflective_goal -------- 2.6% 4.0% 1 0.324s +─k ------------------------------------- 3.5% 3.6% 1 0.296s +─unify (constr) (constr) --------------- 3.3% 3.3% 8 0.092s +─rewrite H ----------------------------- 2.6% 2.6% 2 0.196s +─eexact -------------------------------- 2.6% 2.6% 95 0.024s +─prove_interp_compile_correct ---------- 0.0% 2.5% 1 0.204s +─apply (fun f => MapProjections.proj2 2.4% 2.4% 2 0.120s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 52.4% 1 4.268s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 43.8% 1 3.568s + │└ReflectiveTactics.solve_side_conditio 0.0% 43.2% 1 3.520s + │ ├─ReflectiveTactics.do_reify -------- 0.1% 21.7% 1 1.768s + │ │└Reify.Reify_rhs_gen --------------- 1.0% 20.9% 1 1.704s + │ │ ├─Reify.do_reify_abs_goal --------- 9.9% 10.1% 2 0.820s + │ │ │└Reify.do_reifyf_goal ------------ 9.1% 9.3% 93 0.748s + │ │ │└eexact -------------------------- 2.3% 2.3% 93 0.024s + │ │ ├─prove_interp_compile_correct ---- 0.0% 2.5% 1 0.204s + │ │ └─rewrite H ----------------------- 2.4% 2.4% 1 0.196s + │ └─ReflectiveTactics.solve_post_reifie 0.6% 21.5% 1 1.752s + │ ├─UnifyAbstractReflexivity.unify_tr 13.3% 16.1% 7 0.360s + │ │└unify (constr) (constr) --------- 2.2% 2.2% 5 0.064s + │ └─ReflectiveTactics.unify_abstract_ 3.3% 4.5% 1 0.368s + └─Glue.refine_to_reflective_glue' ----- 0.0% 8.6% 1 0.700s + â””Glue.zrange_to_reflective ----------- 0.0% 5.3% 1 0.432s + â””Glue.zrange_to_reflective_goal ------ 2.6% 4.0% 1 0.324s +─synthesize_montgomery ----------------- 0.0% 47.6% 1 3.872s + ├─IntegrationTestTemporaryMiscCommon.fa 1.4% 23.6% 1 1.924s + │└op_sig_side_conditions_t ------------ 0.0% 20.0% 1 1.624s + │ ├─DestructHyps.do_all_matches_then -- 0.0% 11.4% 4 0.244s + │ │└DestructHyps.do_one_match_then ---- 0.3% 11.4% 24 0.052s + │ │└do_tac ---------------------------- 0.0% 11.1% 20 0.052s + │ │└destruct H ------------------------ 11.1% 11.1% 20 0.052s + │ └─rewrite <- (ZRange.is_bounded_by_No 8.4% 8.4% 4 0.328s + └─IntegrationTestTemporaryMiscCommon.do 0.0% 22.1% 1 1.796s + ├─IntegrationTestTemporaryMiscCommon. 0.0% 17.3% 1 1.408s + │└rewrite <- (lem : lemT) by by_tac l 0.2% 17.3% 1 1.408s + │└by_tac ---------------------------- 0.0% 17.1% 4 0.504s + │ ├─DestructHyps.do_all_matches_then 0.0% 8.6% 4 0.184s + │ │└DestructHyps.do_one_match_then -- 0.3% 8.5% 20 0.052s + │ │└do_tac -------------------------- 0.0% 8.2% 16 0.052s + │ │└destruct H ---------------------- 8.2% 8.2% 16 0.052s + │ └─rewrite <- (ZRange.is_bounded_by_ 8.3% 8.3% 4 0.344s + └─IntegrationTestTemporaryMiscCommon. 0.0% 4.8% 1 0.388s + â””<Crypto.Util.Tactics.MoveLetIn.with 0.9% 4.6% 3 0.368s + â””k --------------------------------- 3.5% 3.6% 1 0.296s + +src/Specific/NISTP256/AMD64/feadd (real: 38.19, user: 35.40, sys: 0.30, mem: 799216 ko) +COQC src/Specific/NISTP256/AMD64/fenz.v +Finished transaction in 6.356 secs (5.82u,0.004s) (successful) +total time: 5.800s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_nonzero -------------------- 0.0% 100.0% 1 5.800s +─IntegrationTestTemporaryMiscCommon.nonz 0.2% 85.5% 1 4.960s +─destruct (Decidable.dec x), (Decidable. 37.4% 37.4% 1 2.168s +─destruct (Decidable.dec x) as [H| H] -- 22.0% 22.0% 1 1.276s +─Pipeline.refine_reflectively_gen ------ 0.0% 14.5% 1 0.840s +─ReflectiveTactics.do_reflective_pipelin 0.0% 10.9% 1 0.632s +─ReflectiveTactics.solve_side_conditions 0.0% 10.6% 1 0.612s +─ReflectiveTactics.solve_post_reified_si 0.3% 8.5% 1 0.492s +─IntegrationTestTemporaryMiscCommon.op_s 0.1% 8.1% 2 0.368s +─rewrite <- (ZRange.is_bounded_by_None_r 5.2% 5.2% 2 0.288s +─UnifyAbstractReflexivity.unify_transfor 3.4% 4.3% 7 0.076s +─ReflectiveTactics.unify_abstract_cbv_in 2.8% 3.8% 1 0.220s +─Glue.refine_to_reflective_glue' ------- 0.1% 3.6% 1 0.208s +─rewrite H' ---------------------------- 3.4% 3.4% 1 0.200s +─generalize dependent (constr) --------- 3.0% 3.0% 4 0.060s +─congruence ---------------------------- 2.8% 2.8% 1 0.160s +─do_tac -------------------------------- 0.0% 2.6% 4 0.044s +─destruct H ---------------------------- 2.6% 2.6% 4 0.044s +─IntegrationTestTemporaryMiscCommon.do_s 0.1% 2.6% 1 0.152s +─DestructHyps.do_one_match_then -------- 0.0% 2.6% 6 0.044s +─DestructHyps.do_all_matches_then ------ 0.0% 2.6% 2 0.076s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.4% 2.5% 3 0.140s +─Glue.zrange_to_reflective ------------- 0.0% 2.2% 1 0.128s +─rewrite H ----------------------------- 1.9% 2.1% 3 0.112s +─ReflectiveTactics.do_reify ------------ 0.0% 2.1% 1 0.120s +─k ------------------------------------- 1.9% 2.0% 1 0.116s +─Reify.Reify_rhs_gen ------------------- 0.1% 2.0% 1 0.116s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_nonzero -------------------- 0.0% 100.0% 1 5.800s + ├─IntegrationTestTemporaryMiscCommon.no 0.2% 85.5% 1 4.960s + │ ├─destruct (Decidable.dec x), (Decida 37.4% 37.4% 1 2.168s + │ ├─destruct (Decidable.dec x) as [H| H 22.0% 22.0% 1 1.276s + │ ├─IntegrationTestTemporaryMiscCommon. 0.1% 8.1% 2 0.368s + │ │ ├─rewrite <- (ZRange.is_bounded_by_ 5.2% 5.2% 2 0.288s + │ │ └─DestructHyps.do_all_matches_then 0.0% 2.6% 2 0.076s + │ │ â””DestructHyps.do_one_match_then -- 0.0% 2.6% 6 0.044s + │ │ â””do_tac -------------------------- 0.0% 2.6% 4 0.044s + │ │ â””destruct H ---------------------- 2.6% 2.6% 4 0.044s + │ ├─rewrite H' ------------------------ 3.4% 3.4% 1 0.200s + │ ├─generalize dependent (constr) ----- 3.0% 3.0% 4 0.060s + │ ├─congruence ------------------------ 2.8% 2.8% 1 0.160s + │ ├─IntegrationTestTemporaryMiscCommon. 0.1% 2.6% 1 0.152s + │ │└<Crypto.Util.Tactics.MoveLetIn.with 0.4% 2.5% 3 0.140s + │ │└k --------------------------------- 1.9% 2.0% 1 0.116s + │ └─rewrite H ------------------------- 1.7% 2.0% 2 0.112s + └─Pipeline.refine_reflectively_gen ---- 0.0% 14.5% 1 0.840s + ├─ReflectiveTactics.do_reflective_pip 0.0% 10.9% 1 0.632s + │└ReflectiveTactics.solve_side_condit 0.0% 10.6% 1 0.612s + │ ├─ReflectiveTactics.solve_post_reif 0.3% 8.5% 1 0.492s + │ │ ├─UnifyAbstractReflexivity.unify_ 3.4% 4.3% 7 0.076s + │ │ └─ReflectiveTactics.unify_abstrac 2.8% 3.8% 1 0.220s + │ └─ReflectiveTactics.do_reify ------ 0.0% 2.1% 1 0.120s + │ â””Reify.Reify_rhs_gen ------------- 0.1% 2.0% 1 0.116s + └─Glue.refine_to_reflective_glue' --- 0.1% 3.6% 1 0.208s + â””Glue.zrange_to_reflective --------- 0.0% 2.2% 1 0.128s + +Finished transaction in 6.657 secs (6.299u,0.s) (successful) +Closed under the global context +total time: 5.800s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_nonzero -------------------- 0.0% 100.0% 1 5.800s +─IntegrationTestTemporaryMiscCommon.nonz 0.2% 85.5% 1 4.960s +─destruct (Decidable.dec x), (Decidable. 37.4% 37.4% 1 2.168s +─destruct (Decidable.dec x) as [H| H] -- 22.0% 22.0% 1 1.276s +─Pipeline.refine_reflectively_gen ------ 0.0% 14.5% 1 0.840s +─ReflectiveTactics.do_reflective_pipelin 0.0% 10.9% 1 0.632s +─ReflectiveTactics.solve_side_conditions 0.0% 10.6% 1 0.612s +─ReflectiveTactics.solve_post_reified_si 0.3% 8.5% 1 0.492s +─IntegrationTestTemporaryMiscCommon.op_s 0.1% 8.1% 2 0.368s +─rewrite <- (ZRange.is_bounded_by_None_r 5.2% 5.2% 2 0.288s +─UnifyAbstractReflexivity.unify_transfor 3.4% 4.3% 7 0.076s +─ReflectiveTactics.unify_abstract_cbv_in 2.8% 3.8% 1 0.220s +─Glue.refine_to_reflective_glue' ------- 0.1% 3.6% 1 0.208s +─rewrite H' ---------------------------- 3.4% 3.4% 1 0.200s +─generalize dependent (constr) --------- 3.0% 3.0% 4 0.060s +─congruence ---------------------------- 2.8% 2.8% 1 0.160s +─do_tac -------------------------------- 0.0% 2.6% 4 0.044s +─destruct H ---------------------------- 2.6% 2.6% 4 0.044s +─IntegrationTestTemporaryMiscCommon.do_s 0.1% 2.6% 1 0.152s +─DestructHyps.do_one_match_then -------- 0.0% 2.6% 6 0.044s +─DestructHyps.do_all_matches_then ------ 0.0% 2.6% 2 0.076s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.4% 2.5% 3 0.140s +─Glue.zrange_to_reflective ------------- 0.0% 2.2% 1 0.128s +─rewrite H ----------------------------- 1.9% 2.1% 3 0.112s +─ReflectiveTactics.do_reify ------------ 0.0% 2.1% 1 0.120s +─k ------------------------------------- 1.9% 2.0% 1 0.116s +─Reify.Reify_rhs_gen ------------------- 0.1% 2.0% 1 0.116s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_nonzero -------------------- 0.0% 100.0% 1 5.800s + ├─IntegrationTestTemporaryMiscCommon.no 0.2% 85.5% 1 4.960s + │ ├─destruct (Decidable.dec x), (Decida 37.4% 37.4% 1 2.168s + │ ├─destruct (Decidable.dec x) as [H| H 22.0% 22.0% 1 1.276s + │ ├─IntegrationTestTemporaryMiscCommon. 0.1% 8.1% 2 0.368s + │ │ ├─rewrite <- (ZRange.is_bounded_by_ 5.2% 5.2% 2 0.288s + │ │ └─DestructHyps.do_all_matches_then 0.0% 2.6% 2 0.076s + │ │ â””DestructHyps.do_one_match_then -- 0.0% 2.6% 6 0.044s + │ │ â””do_tac -------------------------- 0.0% 2.6% 4 0.044s + │ │ â””destruct H ---------------------- 2.6% 2.6% 4 0.044s + │ ├─rewrite H' ------------------------ 3.4% 3.4% 1 0.200s + │ ├─generalize dependent (constr) ----- 3.0% 3.0% 4 0.060s + │ ├─congruence ------------------------ 2.8% 2.8% 1 0.160s + │ ├─IntegrationTestTemporaryMiscCommon. 0.1% 2.6% 1 0.152s + │ │└<Crypto.Util.Tactics.MoveLetIn.with 0.4% 2.5% 3 0.140s + │ │└k --------------------------------- 1.9% 2.0% 1 0.116s + │ └─rewrite H ------------------------- 1.7% 2.0% 2 0.112s + └─Pipeline.refine_reflectively_gen ---- 0.0% 14.5% 1 0.840s + ├─ReflectiveTactics.do_reflective_pip 0.0% 10.9% 1 0.632s + │└ReflectiveTactics.solve_side_condit 0.0% 10.6% 1 0.612s + │ ├─ReflectiveTactics.solve_post_reif 0.3% 8.5% 1 0.492s + │ │ ├─UnifyAbstractReflexivity.unify_ 3.4% 4.3% 7 0.076s + │ │ └─ReflectiveTactics.unify_abstrac 2.8% 3.8% 1 0.220s + │ └─ReflectiveTactics.do_reify ------ 0.0% 2.1% 1 0.120s + │ â””Reify.Reify_rhs_gen ------------- 0.1% 2.0% 1 0.116s + └─Glue.refine_to_reflective_glue' --- 0.1% 3.6% 1 0.208s + â””Glue.zrange_to_reflective --------- 0.0% 2.2% 1 0.128s + +src/Specific/NISTP256/AMD64/fenz (real: 27.81, user: 25.50, sys: 0.22, mem: 756080 ko) +COQC src/Specific/NISTP256/AMD64/feopp.v +Finished transaction in 7.73 secs (7.112u,0.008s) (successful) +total time: 7.072s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 62.5% 1 4.420s +─IntegrationTestTemporaryMiscCommon.fact 18.7% 51.6% 1 3.648s +─Pipeline.refine_reflectively_gen ------ 0.0% 37.5% 1 2.652s +─ReflectiveTactics.do_reflective_pipelin 0.0% 32.6% 1 2.308s +─ReflectiveTactics.solve_side_conditions 0.0% 32.2% 1 2.276s +─reflexivity --------------------------- 24.8% 24.8% 8 1.700s +─ReflectiveTactics.solve_post_reified_si 0.5% 18.5% 1 1.308s +─ReflectiveTactics.do_reify ------------ 0.0% 13.7% 1 0.968s +─UnifyAbstractReflexivity.unify_transfor 11.2% 13.6% 7 0.284s +─Reify.Reify_rhs_gen ------------------- 0.6% 13.4% 1 0.948s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 9.7% 1 0.684s +─rewrite <- (ZRange.is_bounded_by_None_r 9.0% 9.0% 4 0.328s +─op_sig_side_conditions_t -------------- 0.0% 7.8% 1 0.552s +─rewrite <- (lem : lemT) by by_tac ltac: 0.1% 7.4% 1 0.520s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 7.4% 1 0.520s +─by_tac -------------------------------- 0.0% 7.2% 2 0.404s +─Reify.do_reify_abs_goal --------------- 7.1% 7.2% 2 0.512s +─Reify.do_reifyf_goal ------------------ 6.6% 6.7% 62 0.472s +─DestructHyps.do_one_match_then -------- 0.2% 5.8% 14 0.048s +─DestructHyps.do_all_matches_then ------ 0.0% 5.8% 4 0.124s +─do_tac -------------------------------- 0.0% 5.6% 10 0.048s +─destruct H ---------------------------- 5.6% 5.6% 10 0.048s +─Glue.refine_to_reflective_glue' ------- 0.0% 4.9% 1 0.344s +─ReflectiveTactics.unify_abstract_cbv_in 2.9% 4.2% 1 0.300s +─Glue.zrange_to_reflective ------------- 0.0% 3.3% 1 0.232s +─unify (constr) (constr) --------------- 3.2% 3.2% 7 0.088s +─Glue.zrange_to_reflective_goal -------- 1.9% 2.6% 1 0.184s +─IntegrationTestTemporaryMiscCommon.do_s 0.0% 2.3% 1 0.164s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.4% 2.2% 3 0.152s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 62.5% 1 4.420s + ├─IntegrationTestTemporaryMiscCommon.fa 18.7% 51.6% 1 3.648s + │ ├─reflexivity ----------------------- 24.0% 24.0% 1 1.700s + │ └─op_sig_side_conditions_t ---------- 0.0% 7.8% 1 0.552s + │ ├─rewrite <- (ZRange.is_bounded_by_ 4.2% 4.2% 2 0.284s + │ └─DestructHyps.do_all_matches_then 0.0% 3.5% 2 0.124s + │ â””DestructHyps.do_one_match_then -- 0.2% 3.5% 8 0.044s + │ â””do_tac -------------------------- 0.0% 3.3% 6 0.040s + │ â””destruct H ---------------------- 3.3% 3.3% 6 0.040s + └─IntegrationTestTemporaryMiscCommon.do 0.0% 9.7% 1 0.684s + ├─IntegrationTestTemporaryMiscCommon. 0.0% 7.4% 1 0.520s + │└rewrite <- (lem : lemT) by by_tac l 0.1% 7.4% 1 0.520s + │└by_tac ---------------------------- 0.0% 7.2% 2 0.404s + │ ├─rewrite <- (ZRange.is_bounded_by_ 4.8% 4.8% 2 0.328s + │ └─DestructHyps.do_all_matches_then 0.0% 2.3% 2 0.088s + │ â””DestructHyps.do_one_match_then -- 0.0% 2.3% 6 0.048s + │ â””do_tac -------------------------- 0.0% 2.3% 4 0.048s + │ â””destruct H ---------------------- 2.3% 2.3% 4 0.048s + └─IntegrationTestTemporaryMiscCommon. 0.0% 2.3% 1 0.164s + â””<Crypto.Util.Tactics.MoveLetIn.with 0.4% 2.2% 3 0.152s +─Pipeline.refine_reflectively_gen ------ 0.0% 37.5% 1 2.652s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 32.6% 1 2.308s + │└ReflectiveTactics.solve_side_conditio 0.0% 32.2% 1 2.276s + │ ├─ReflectiveTactics.solve_post_reifie 0.5% 18.5% 1 1.308s + │ │ ├─UnifyAbstractReflexivity.unify_tr 11.2% 13.6% 7 0.284s + │ │ └─ReflectiveTactics.unify_abstract_ 2.9% 4.2% 1 0.300s + │ └─ReflectiveTactics.do_reify -------- 0.0% 13.7% 1 0.968s + │ â””Reify.Reify_rhs_gen --------------- 0.6% 13.4% 1 0.948s + │ â””Reify.do_reify_abs_goal ----------- 7.1% 7.2% 2 0.512s + │ â””Reify.do_reifyf_goal -------------- 6.6% 6.7% 62 0.472s + └─Glue.refine_to_reflective_glue' ----- 0.0% 4.9% 1 0.344s + â””Glue.zrange_to_reflective ----------- 0.0% 3.3% 1 0.232s + â””Glue.zrange_to_reflective_goal ------ 1.9% 2.6% 1 0.184s + +Finished transaction in 7.732 secs (7.1u,0.003s) (successful) +Closed under the global context +total time: 7.072s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 62.5% 1 4.420s +─IntegrationTestTemporaryMiscCommon.fact 18.7% 51.6% 1 3.648s +─Pipeline.refine_reflectively_gen ------ 0.0% 37.5% 1 2.652s +─ReflectiveTactics.do_reflective_pipelin 0.0% 32.6% 1 2.308s +─ReflectiveTactics.solve_side_conditions 0.0% 32.2% 1 2.276s +─reflexivity --------------------------- 24.8% 24.8% 8 1.700s +─ReflectiveTactics.solve_post_reified_si 0.5% 18.5% 1 1.308s +─ReflectiveTactics.do_reify ------------ 0.0% 13.7% 1 0.968s +─UnifyAbstractReflexivity.unify_transfor 11.2% 13.6% 7 0.284s +─Reify.Reify_rhs_gen ------------------- 0.6% 13.4% 1 0.948s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 9.7% 1 0.684s +─rewrite <- (ZRange.is_bounded_by_None_r 9.0% 9.0% 4 0.328s +─op_sig_side_conditions_t -------------- 0.0% 7.8% 1 0.552s +─rewrite <- (lem : lemT) by by_tac ltac: 0.1% 7.4% 1 0.520s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 7.4% 1 0.520s +─by_tac -------------------------------- 0.0% 7.2% 2 0.404s +─Reify.do_reify_abs_goal --------------- 7.1% 7.2% 2 0.512s +─Reify.do_reifyf_goal ------------------ 6.6% 6.7% 62 0.472s +─DestructHyps.do_one_match_then -------- 0.2% 5.8% 14 0.048s +─DestructHyps.do_all_matches_then ------ 0.0% 5.8% 4 0.124s +─do_tac -------------------------------- 0.0% 5.6% 10 0.048s +─destruct H ---------------------------- 5.6% 5.6% 10 0.048s +─Glue.refine_to_reflective_glue' ------- 0.0% 4.9% 1 0.344s +─ReflectiveTactics.unify_abstract_cbv_in 2.9% 4.2% 1 0.300s +─Glue.zrange_to_reflective ------------- 0.0% 3.3% 1 0.232s +─unify (constr) (constr) --------------- 3.2% 3.2% 7 0.088s +─Glue.zrange_to_reflective_goal -------- 1.9% 2.6% 1 0.184s +─IntegrationTestTemporaryMiscCommon.do_s 0.0% 2.3% 1 0.164s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.4% 2.2% 3 0.152s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 62.5% 1 4.420s + ├─IntegrationTestTemporaryMiscCommon.fa 18.7% 51.6% 1 3.648s + │ ├─reflexivity ----------------------- 24.0% 24.0% 1 1.700s + │ └─op_sig_side_conditions_t ---------- 0.0% 7.8% 1 0.552s + │ ├─rewrite <- (ZRange.is_bounded_by_ 4.2% 4.2% 2 0.284s + │ └─DestructHyps.do_all_matches_then 0.0% 3.5% 2 0.124s + │ â””DestructHyps.do_one_match_then -- 0.2% 3.5% 8 0.044s + │ â””do_tac -------------------------- 0.0% 3.3% 6 0.040s + │ â””destruct H ---------------------- 3.3% 3.3% 6 0.040s + └─IntegrationTestTemporaryMiscCommon.do 0.0% 9.7% 1 0.684s + ├─IntegrationTestTemporaryMiscCommon. 0.0% 7.4% 1 0.520s + │└rewrite <- (lem : lemT) by by_tac l 0.1% 7.4% 1 0.520s + │└by_tac ---------------------------- 0.0% 7.2% 2 0.404s + │ ├─rewrite <- (ZRange.is_bounded_by_ 4.8% 4.8% 2 0.328s + │ └─DestructHyps.do_all_matches_then 0.0% 2.3% 2 0.088s + │ â””DestructHyps.do_one_match_then -- 0.0% 2.3% 6 0.048s + │ â””do_tac -------------------------- 0.0% 2.3% 4 0.048s + │ â””destruct H ---------------------- 2.3% 2.3% 4 0.048s + └─IntegrationTestTemporaryMiscCommon. 0.0% 2.3% 1 0.164s + â””<Crypto.Util.Tactics.MoveLetIn.with 0.4% 2.2% 3 0.152s +─Pipeline.refine_reflectively_gen ------ 0.0% 37.5% 1 2.652s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 32.6% 1 2.308s + │└ReflectiveTactics.solve_side_conditio 0.0% 32.2% 1 2.276s + │ ├─ReflectiveTactics.solve_post_reifie 0.5% 18.5% 1 1.308s + │ │ ├─UnifyAbstractReflexivity.unify_tr 11.2% 13.6% 7 0.284s + │ │ └─ReflectiveTactics.unify_abstract_ 2.9% 4.2% 1 0.300s + │ └─ReflectiveTactics.do_reify -------- 0.0% 13.7% 1 0.968s + │ â””Reify.Reify_rhs_gen --------------- 0.6% 13.4% 1 0.948s + │ â””Reify.do_reify_abs_goal ----------- 7.1% 7.2% 2 0.512s + │ â””Reify.do_reifyf_goal -------------- 6.6% 6.7% 62 0.472s + └─Glue.refine_to_reflective_glue' ----- 0.0% 4.9% 1 0.344s + â””Glue.zrange_to_reflective ----------- 0.0% 3.3% 1 0.232s + â””Glue.zrange_to_reflective_goal ------ 1.9% 2.6% 1 0.184s + +src/Specific/NISTP256/AMD64/feopp (real: 31.00, user: 28.51, sys: 0.20, mem: 765208 ko) +COQC src/Specific/NISTP256/AMD64/fesub.v +Finished transaction in 12.996 secs (12.091u,0.004s) (successful) +total time: 12.048s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 66.1% 1 7.964s +─IntegrationTestTemporaryMiscCommon.fact 16.2% 50.9% 1 6.128s +─Pipeline.refine_reflectively_gen ------ 0.0% 33.9% 1 4.084s +─ReflectiveTactics.do_reflective_pipelin 0.0% 28.3% 1 3.404s +─ReflectiveTactics.solve_side_conditions 0.0% 27.8% 1 3.352s +─reflexivity --------------------------- 21.7% 21.7% 8 2.480s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 14.1% 1 1.704s +─ReflectiveTactics.solve_post_reified_si 0.4% 14.1% 1 1.696s +─ReflectiveTactics.do_reify ------------ 0.0% 13.7% 1 1.656s +─Reify.Reify_rhs_gen ------------------- 0.9% 13.2% 1 1.592s +─DestructHyps.do_all_matches_then ------ 0.0% 12.9% 8 0.232s +─DestructHyps.do_one_match_then -------- 0.6% 12.9% 44 0.052s +─op_sig_side_conditions_t -------------- 0.0% 12.7% 1 1.528s +─do_tac -------------------------------- 0.0% 12.3% 36 0.048s +─destruct H ---------------------------- 12.3% 12.3% 36 0.048s +─rewrite <- (lem : lemT) by by_tac ltac: 0.1% 11.2% 1 1.352s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 11.2% 1 1.352s +─by_tac -------------------------------- 0.0% 11.1% 4 0.476s +─UnifyAbstractReflexivity.unify_transfor 8.8% 10.6% 7 0.344s +─rewrite <- (ZRange.is_bounded_by_None_r 10.5% 10.5% 8 0.316s +─Reify.do_reify_abs_goal --------------- 6.0% 6.1% 2 0.732s +─Glue.refine_to_reflective_glue' ------- 0.0% 5.6% 1 0.680s +─Reify.do_reifyf_goal ------------------ 5.4% 5.5% 80 0.660s +─Glue.zrange_to_reflective ------------- 0.0% 3.6% 1 0.428s +─ReflectiveTactics.unify_abstract_cbv_in 2.2% 3.0% 1 0.360s +─IntegrationTestTemporaryMiscCommon.do_s 0.0% 2.9% 1 0.348s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.5% 2.8% 3 0.332s +─Glue.zrange_to_reflective_goal -------- 1.7% 2.6% 1 0.316s +─k ------------------------------------- 2.1% 2.2% 1 0.268s +─unify (constr) (constr) --------------- 2.1% 2.1% 8 0.092s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 66.1% 1 7.964s + ├─IntegrationTestTemporaryMiscCommon.fa 16.2% 50.9% 1 6.128s + │ ├─reflexivity ----------------------- 20.6% 20.6% 1 2.480s + │ └─op_sig_side_conditions_t ---------- 0.0% 12.7% 1 1.528s + │ ├─DestructHyps.do_all_matches_then 0.0% 7.3% 4 0.232s + │ │└DestructHyps.do_one_match_then -- 0.3% 7.3% 24 0.052s + │ │└do_tac -------------------------- 0.0% 7.0% 20 0.048s + │ │└destruct H ---------------------- 6.9% 6.9% 20 0.048s + │ └─rewrite <- (ZRange.is_bounded_by_ 5.2% 5.2% 4 0.300s + └─IntegrationTestTemporaryMiscCommon.do 0.0% 14.1% 1 1.704s + ├─IntegrationTestTemporaryMiscCommon. 0.0% 11.2% 1 1.352s + │└rewrite <- (lem : lemT) by by_tac l 0.1% 11.2% 1 1.352s + │└by_tac ---------------------------- 0.0% 11.1% 4 0.476s + │ ├─DestructHyps.do_all_matches_then 0.0% 5.6% 4 0.176s + │ │└DestructHyps.do_one_match_then -- 0.2% 5.6% 20 0.052s + │ │└do_tac -------------------------- 0.0% 5.3% 16 0.048s + │ │└destruct H ---------------------- 5.3% 5.3% 16 0.048s + │ └─rewrite <- (ZRange.is_bounded_by_ 5.3% 5.3% 4 0.316s + └─IntegrationTestTemporaryMiscCommon. 0.0% 2.9% 1 0.348s + â””<Crypto.Util.Tactics.MoveLetIn.with 0.5% 2.8% 3 0.332s + â””k --------------------------------- 2.1% 2.2% 1 0.268s +─Pipeline.refine_reflectively_gen ------ 0.0% 33.9% 1 4.084s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 28.3% 1 3.404s + │└ReflectiveTactics.solve_side_conditio 0.0% 27.8% 1 3.352s + │ ├─ReflectiveTactics.solve_post_reifie 0.4% 14.1% 1 1.696s + │ │ ├─UnifyAbstractReflexivity.unify_tr 8.8% 10.6% 7 0.344s + │ │ └─ReflectiveTactics.unify_abstract_ 2.2% 3.0% 1 0.360s + │ └─ReflectiveTactics.do_reify -------- 0.0% 13.7% 1 1.656s + │ â””Reify.Reify_rhs_gen --------------- 0.9% 13.2% 1 1.592s + │ â””Reify.do_reify_abs_goal ----------- 6.0% 6.1% 2 0.732s + │ â””Reify.do_reifyf_goal -------------- 5.4% 5.5% 80 0.660s + └─Glue.refine_to_reflective_glue' ----- 0.0% 5.6% 1 0.680s + â””Glue.zrange_to_reflective ----------- 0.0% 3.6% 1 0.428s + â””Glue.zrange_to_reflective_goal ------ 1.7% 2.6% 1 0.316s + +Finished transaction in 13.895 secs (12.78u,0.02s) (successful) +Closed under the global context +total time: 12.048s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 66.1% 1 7.964s +─IntegrationTestTemporaryMiscCommon.fact 16.2% 50.9% 1 6.128s +─Pipeline.refine_reflectively_gen ------ 0.0% 33.9% 1 4.084s +─ReflectiveTactics.do_reflective_pipelin 0.0% 28.3% 1 3.404s +─ReflectiveTactics.solve_side_conditions 0.0% 27.8% 1 3.352s +─reflexivity --------------------------- 21.7% 21.7% 8 2.480s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 14.1% 1 1.704s +─ReflectiveTactics.solve_post_reified_si 0.4% 14.1% 1 1.696s +─ReflectiveTactics.do_reify ------------ 0.0% 13.7% 1 1.656s +─Reify.Reify_rhs_gen ------------------- 0.9% 13.2% 1 1.592s +─DestructHyps.do_all_matches_then ------ 0.0% 12.9% 8 0.232s +─DestructHyps.do_one_match_then -------- 0.6% 12.9% 44 0.052s +─op_sig_side_conditions_t -------------- 0.0% 12.7% 1 1.528s +─do_tac -------------------------------- 0.0% 12.3% 36 0.048s +─destruct H ---------------------------- 12.3% 12.3% 36 0.048s +─rewrite <- (lem : lemT) by by_tac ltac: 0.1% 11.2% 1 1.352s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 11.2% 1 1.352s +─by_tac -------------------------------- 0.0% 11.1% 4 0.476s +─UnifyAbstractReflexivity.unify_transfor 8.8% 10.6% 7 0.344s +─rewrite <- (ZRange.is_bounded_by_None_r 10.5% 10.5% 8 0.316s +─Reify.do_reify_abs_goal --------------- 6.0% 6.1% 2 0.732s +─Glue.refine_to_reflective_glue' ------- 0.0% 5.6% 1 0.680s +─Reify.do_reifyf_goal ------------------ 5.4% 5.5% 80 0.660s +─Glue.zrange_to_reflective ------------- 0.0% 3.6% 1 0.428s +─ReflectiveTactics.unify_abstract_cbv_in 2.2% 3.0% 1 0.360s +─IntegrationTestTemporaryMiscCommon.do_s 0.0% 2.9% 1 0.348s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.5% 2.8% 3 0.332s +─Glue.zrange_to_reflective_goal -------- 1.7% 2.6% 1 0.316s +─k ------------------------------------- 2.1% 2.2% 1 0.268s +─unify (constr) (constr) --------------- 2.1% 2.1% 8 0.092s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 66.1% 1 7.964s + ├─IntegrationTestTemporaryMiscCommon.fa 16.2% 50.9% 1 6.128s + │ ├─reflexivity ----------------------- 20.6% 20.6% 1 2.480s + │ └─op_sig_side_conditions_t ---------- 0.0% 12.7% 1 1.528s + │ ├─DestructHyps.do_all_matches_then 0.0% 7.3% 4 0.232s + │ │└DestructHyps.do_one_match_then -- 0.3% 7.3% 24 0.052s + │ │└do_tac -------------------------- 0.0% 7.0% 20 0.048s + │ │└destruct H ---------------------- 6.9% 6.9% 20 0.048s + │ └─rewrite <- (ZRange.is_bounded_by_ 5.2% 5.2% 4 0.300s + └─IntegrationTestTemporaryMiscCommon.do 0.0% 14.1% 1 1.704s + ├─IntegrationTestTemporaryMiscCommon. 0.0% 11.2% 1 1.352s + │└rewrite <- (lem : lemT) by by_tac l 0.1% 11.2% 1 1.352s + │└by_tac ---------------------------- 0.0% 11.1% 4 0.476s + │ ├─DestructHyps.do_all_matches_then 0.0% 5.6% 4 0.176s + │ │└DestructHyps.do_one_match_then -- 0.2% 5.6% 20 0.052s + │ │└do_tac -------------------------- 0.0% 5.3% 16 0.048s + │ │└destruct H ---------------------- 5.3% 5.3% 16 0.048s + │ └─rewrite <- (ZRange.is_bounded_by_ 5.3% 5.3% 4 0.316s + └─IntegrationTestTemporaryMiscCommon. 0.0% 2.9% 1 0.348s + â””<Crypto.Util.Tactics.MoveLetIn.with 0.5% 2.8% 3 0.332s + â””k --------------------------------- 2.1% 2.2% 1 0.268s +─Pipeline.refine_reflectively_gen ------ 0.0% 33.9% 1 4.084s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 28.3% 1 3.404s + │└ReflectiveTactics.solve_side_conditio 0.0% 27.8% 1 3.352s + │ ├─ReflectiveTactics.solve_post_reifie 0.4% 14.1% 1 1.696s + │ │ ├─UnifyAbstractReflexivity.unify_tr 8.8% 10.6% 7 0.344s + │ │ └─ReflectiveTactics.unify_abstract_ 2.2% 3.0% 1 0.360s + │ └─ReflectiveTactics.do_reify -------- 0.0% 13.7% 1 1.656s + │ â””Reify.Reify_rhs_gen --------------- 0.9% 13.2% 1 1.592s + │ â””Reify.do_reify_abs_goal ----------- 6.0% 6.1% 2 0.732s + │ â””Reify.do_reifyf_goal -------------- 5.4% 5.5% 80 0.660s + └─Glue.refine_to_reflective_glue' ----- 0.0% 5.6% 1 0.680s + â””Glue.zrange_to_reflective ----------- 0.0% 3.6% 1 0.428s + â””Glue.zrange_to_reflective_goal ------ 1.7% 2.6% 1 0.316s + +src/Specific/NISTP256/AMD64/fesub (real: 43.34, user: 39.59, sys: 0.26, mem: 793376 ko) +COQC src/Specific/NISTP256/AMD64/feaddDisplay > src/Specific/NISTP256/AMD64/feaddDisplay.log +COQC src/Specific/NISTP256/AMD64/fenzDisplay > src/Specific/NISTP256/AMD64/fenzDisplay.log +COQC src/Specific/solinas32_2e255m765_12limbs/femul.v +Finished transaction in 50.426 secs (46.528u,0.072s) (successful) +total time: 46.544s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ -0.0% 94.9% 1 44.164s +─ReflectiveTactics.do_reflective_pipelin 0.0% 87.1% 1 40.552s +─ReflectiveTactics.solve_side_conditions 0.0% 86.7% 1 40.372s +─ReflectiveTactics.do_reify ------------ 0.0% 59.6% 1 27.740s +─Reify.Reify_rhs_gen ------------------- 1.6% 58.9% 1 27.432s +─Reify.do_reify_abs_goal --------------- 43.3% 43.6% 2 20.312s +─Reify.do_reifyf_goal ------------------ 42.5% 42.8% 108 10.328s +─ReflectiveTactics.solve_post_reified_si 0.1% 27.1% 1 12.632s +─UnifyAbstractReflexivity.unify_transfor 18.6% 23.5% 7 3.552s +─eexact -------------------------------- 13.7% 13.7% 110 0.136s +─Glue.refine_to_reflective_glue' ------- 0.0% 7.8% 1 3.612s +─Glue.zrange_to_reflective ------------- 0.0% 7.2% 1 3.332s +─Glue.zrange_to_reflective_goal -------- 1.7% 5.5% 1 2.544s +─synthesize ---------------------------- 0.0% 5.1% 1 2.380s +─unify (constr) (constr) --------------- 5.1% 5.1% 6 1.068s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 5.0% 1 2.320s +─change G' ----------------------------- 4.8% 4.8% 1 2.252s +─rewrite H ----------------------------- 3.8% 3.8% 1 1.748s +─pose proof (pf : Interpretation.Bo 3.6% 3.6% 1 1.664s +─prove_interp_compile_correct ---------- 0.0% 3.5% 1 1.616s +─rewrite ?EtaInterp.InterpExprEta ------ 3.2% 3.2% 1 1.468s +─ReflectiveTactics.unify_abstract_cbv_in 1.6% 2.4% 1 1.124s +─reflexivity --------------------------- 2.1% 2.1% 7 0.396s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ -0.0% 94.9% 1 44.164s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 87.1% 1 40.552s + │└ReflectiveTactics.solve_side_conditio 0.0% 86.7% 1 40.372s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 59.6% 1 27.740s + │ │└Reify.Reify_rhs_gen --------------- 1.6% 58.9% 1 27.432s + │ │ ├─Reify.do_reify_abs_goal --------- 43.3% 43.6% 2 20.312s + │ │ │└Reify.do_reifyf_goal ------------ 42.5% 42.8% 108 10.328s + │ │ │└eexact -------------------------- 13.2% 13.2% 108 0.072s + │ │ ├─rewrite H ----------------------- 3.8% 3.8% 1 1.748s + │ │ └─prove_interp_compile_correct ---- 0.0% 3.5% 1 1.616s + │ │ â””rewrite ?EtaInterp.InterpExprEta 3.2% 3.2% 1 1.468s + │ └─ReflectiveTactics.solve_post_reifie 0.1% 27.1% 1 12.632s + │ ├─UnifyAbstractReflexivity.unify_tr 18.6% 23.5% 7 3.552s + │ │└unify (constr) (constr) --------- 4.3% 4.3% 5 1.068s + │ └─ReflectiveTactics.unify_abstract_ 1.6% 2.4% 1 1.124s + └─Glue.refine_to_reflective_glue' ----- 0.0% 7.8% 1 3.612s + â””Glue.zrange_to_reflective ----------- 0.0% 7.2% 1 3.332s + â””Glue.zrange_to_reflective_goal ------ 1.7% 5.5% 1 2.544s + â””pose proof (pf : Interpretation. 3.6% 3.6% 1 1.664s +─synthesize ---------------------------- 0.0% 5.1% 1 2.380s +â””IntegrationTestTemporaryMiscCommon.do_r 0.0% 5.0% 1 2.320s +â””change G' ----------------------------- 4.8% 4.8% 1 2.252s + +Finished transaction in 80.129 secs (74.068u,0.024s) (successful) +Closed under the global context +total time: 46.544s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ -0.0% 94.9% 1 44.164s +─ReflectiveTactics.do_reflective_pipelin 0.0% 87.1% 1 40.552s +─ReflectiveTactics.solve_side_conditions 0.0% 86.7% 1 40.372s +─ReflectiveTactics.do_reify ------------ 0.0% 59.6% 1 27.740s +─Reify.Reify_rhs_gen ------------------- 1.6% 58.9% 1 27.432s +─Reify.do_reify_abs_goal --------------- 43.3% 43.6% 2 20.312s +─Reify.do_reifyf_goal ------------------ 42.5% 42.8% 108 10.328s +─ReflectiveTactics.solve_post_reified_si 0.1% 27.1% 1 12.632s +─UnifyAbstractReflexivity.unify_transfor 18.6% 23.5% 7 3.552s +─eexact -------------------------------- 13.7% 13.7% 110 0.136s +─Glue.refine_to_reflective_glue' ------- 0.0% 7.8% 1 3.612s +─Glue.zrange_to_reflective ------------- 0.0% 7.2% 1 3.332s +─Glue.zrange_to_reflective_goal -------- 1.7% 5.5% 1 2.544s +─synthesize ---------------------------- 0.0% 5.1% 1 2.380s +─unify (constr) (constr) --------------- 5.1% 5.1% 6 1.068s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 5.0% 1 2.320s +─change G' ----------------------------- 4.8% 4.8% 1 2.252s +─rewrite H ----------------------------- 3.8% 3.8% 1 1.748s +─pose proof (pf : Interpretation.Bo 3.6% 3.6% 1 1.664s +─prove_interp_compile_correct ---------- 0.0% 3.5% 1 1.616s +─rewrite ?EtaInterp.InterpExprEta ------ 3.2% 3.2% 1 1.468s +─ReflectiveTactics.unify_abstract_cbv_in 1.6% 2.4% 1 1.124s +─reflexivity --------------------------- 2.1% 2.1% 7 0.396s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ -0.0% 94.9% 1 44.164s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 87.1% 1 40.552s + │└ReflectiveTactics.solve_side_conditio 0.0% 86.7% 1 40.372s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 59.6% 1 27.740s + │ │└Reify.Reify_rhs_gen --------------- 1.6% 58.9% 1 27.432s + │ │ ├─Reify.do_reify_abs_goal --------- 43.3% 43.6% 2 20.312s + │ │ │└Reify.do_reifyf_goal ------------ 42.5% 42.8% 108 10.328s + │ │ │└eexact -------------------------- 13.2% 13.2% 108 0.072s + │ │ ├─rewrite H ----------------------- 3.8% 3.8% 1 1.748s + │ │ └─prove_interp_compile_correct ---- 0.0% 3.5% 1 1.616s + │ │ â””rewrite ?EtaInterp.InterpExprEta 3.2% 3.2% 1 1.468s + │ └─ReflectiveTactics.solve_post_reifie 0.1% 27.1% 1 12.632s + │ ├─UnifyAbstractReflexivity.unify_tr 18.6% 23.5% 7 3.552s + │ │└unify (constr) (constr) --------- 4.3% 4.3% 5 1.068s + │ └─ReflectiveTactics.unify_abstract_ 1.6% 2.4% 1 1.124s + └─Glue.refine_to_reflective_glue' ----- 0.0% 7.8% 1 3.612s + â””Glue.zrange_to_reflective ----------- 0.0% 7.2% 1 3.332s + â””Glue.zrange_to_reflective_goal ------ 1.7% 5.5% 1 2.544s + â””pose proof (pf : Interpretation. 3.6% 3.6% 1 1.664s +─synthesize ---------------------------- 0.0% 5.1% 1 2.380s +â””IntegrationTestTemporaryMiscCommon.do_r 0.0% 5.0% 1 2.320s +â””change G' ----------------------------- 4.8% 4.8% 1 2.252s + +src/Specific/solinas32_2e255m765_12limbs/femul (real: 155.79, user: 143.70, sys: 0.32, mem: 1454696 ko) +COQC src/Specific/NISTP256/AMD64/feoppDisplay > src/Specific/NISTP256/AMD64/feoppDisplay.log +COQC src/Specific/NISTP256/AMD64/fesubDisplay > src/Specific/NISTP256/AMD64/fesubDisplay.log +COQC src/Specific/X25519/C64/fesquareDisplay > src/Specific/X25519/C64/fesquareDisplay.log +COQC src/Specific/X25519/C64/fesubDisplay > src/Specific/X25519/C64/fesubDisplay.log +COQC src/Specific/X25519/C64/freezeDisplay > src/Specific/X25519/C64/freezeDisplay.log +COQC src/Specific/solinas32_2e255m765_13limbs/femul.v +Finished transaction in 61.854 secs (57.328u,0.079s) (successful) +total time: 57.348s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 94.6% 1 54.224s +─ReflectiveTactics.do_reflective_pipelin 0.0% 86.2% 1 49.452s +─ReflectiveTactics.solve_side_conditions 0.0% 85.9% 1 49.264s +─ReflectiveTactics.do_reify ------------ -0.0% 57.6% 1 33.004s +─Reify.Reify_rhs_gen ------------------- 1.3% 56.9% 1 32.608s +─Reify.do_reify_abs_goal --------------- 43.1% 43.3% 2 24.840s +─Reify.do_reifyf_goal ------------------ 42.3% 42.6% 117 12.704s +─ReflectiveTactics.solve_post_reified_si 0.1% 28.4% 1 16.260s +─UnifyAbstractReflexivity.unify_transfor 19.6% 25.0% 7 4.824s +─eexact -------------------------------- 13.9% 13.9% 119 0.144s +─Glue.refine_to_reflective_glue' ------- 0.0% 8.3% 1 4.772s +─Glue.zrange_to_reflective ------------- 0.0% 7.8% 1 4.484s +─Glue.zrange_to_reflective_goal -------- 1.7% 6.0% 1 3.464s +─synthesize ---------------------------- 0.0% 5.4% 1 3.124s +─unify (constr) (constr) --------------- 5.4% 5.4% 6 1.540s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 5.3% 1 3.040s +─change G' ----------------------------- 5.2% 5.2% 1 2.964s +─pose proof (pf : Interpretation.Bo 4.2% 4.2% 1 2.416s +─prove_interp_compile_correct ---------- 0.0% 3.3% 1 1.904s +─rewrite H ----------------------------- 3.3% 3.3% 1 1.896s +─rewrite ?EtaInterp.InterpExprEta ------ 3.0% 3.0% 1 1.732s +─ReflectiveTactics.unify_abstract_cbv_in 1.4% 2.1% 1 1.212s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 94.6% 1 54.224s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 86.2% 1 49.452s + │└ReflectiveTactics.solve_side_conditio 0.0% 85.9% 1 49.264s + │ ├─ReflectiveTactics.do_reify -------- -0.0% 57.6% 1 33.004s + │ │└Reify.Reify_rhs_gen --------------- 1.3% 56.9% 1 32.608s + │ │ ├─Reify.do_reify_abs_goal --------- 43.1% 43.3% 2 24.840s + │ │ │└Reify.do_reifyf_goal ------------ 42.3% 42.6% 117 12.704s + │ │ │└eexact -------------------------- 13.4% 13.4% 117 0.084s + │ │ ├─prove_interp_compile_correct ---- 0.0% 3.3% 1 1.904s + │ │ │└rewrite ?EtaInterp.InterpExprEta 3.0% 3.0% 1 1.732s + │ │ └─rewrite H ----------------------- 3.3% 3.3% 1 1.896s + │ └─ReflectiveTactics.solve_post_reifie 0.1% 28.4% 1 16.260s + │ ├─UnifyAbstractReflexivity.unify_tr 19.6% 25.0% 7 4.824s + │ │└unify (constr) (constr) --------- 4.8% 4.8% 5 1.540s + │ └─ReflectiveTactics.unify_abstract_ 1.4% 2.1% 1 1.212s + └─Glue.refine_to_reflective_glue' ----- 0.0% 8.3% 1 4.772s + â””Glue.zrange_to_reflective ----------- 0.0% 7.8% 1 4.484s + â””Glue.zrange_to_reflective_goal ------ 1.7% 6.0% 1 3.464s + â””pose proof (pf : Interpretation. 4.2% 4.2% 1 2.416s +─synthesize ---------------------------- 0.0% 5.4% 1 3.124s +â””IntegrationTestTemporaryMiscCommon.do_r 0.0% 5.3% 1 3.040s +â””change G' ----------------------------- 5.2% 5.2% 1 2.964s + +Finished transaction in 94.432 secs (86.96u,0.02s) (successful) +Closed under the global context +total time: 57.348s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 94.6% 1 54.224s +─ReflectiveTactics.do_reflective_pipelin 0.0% 86.2% 1 49.452s +─ReflectiveTactics.solve_side_conditions 0.0% 85.9% 1 49.264s +─ReflectiveTactics.do_reify ------------ -0.0% 57.6% 1 33.004s +─Reify.Reify_rhs_gen ------------------- 1.3% 56.9% 1 32.608s +─Reify.do_reify_abs_goal --------------- 43.1% 43.3% 2 24.840s +─Reify.do_reifyf_goal ------------------ 42.3% 42.6% 117 12.704s +─ReflectiveTactics.solve_post_reified_si 0.1% 28.4% 1 16.260s +─UnifyAbstractReflexivity.unify_transfor 19.6% 25.0% 7 4.824s +─eexact -------------------------------- 13.9% 13.9% 119 0.144s +─Glue.refine_to_reflective_glue' ------- 0.0% 8.3% 1 4.772s +─Glue.zrange_to_reflective ------------- 0.0% 7.8% 1 4.484s +─Glue.zrange_to_reflective_goal -------- 1.7% 6.0% 1 3.464s +─synthesize ---------------------------- 0.0% 5.4% 1 3.124s +─unify (constr) (constr) --------------- 5.4% 5.4% 6 1.540s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 5.3% 1 3.040s +─change G' ----------------------------- 5.2% 5.2% 1 2.964s +─pose proof (pf : Interpretation.Bo 4.2% 4.2% 1 2.416s +─prove_interp_compile_correct ---------- 0.0% 3.3% 1 1.904s +─rewrite H ----------------------------- 3.3% 3.3% 1 1.896s +─rewrite ?EtaInterp.InterpExprEta ------ 3.0% 3.0% 1 1.732s +─ReflectiveTactics.unify_abstract_cbv_in 1.4% 2.1% 1 1.212s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 94.6% 1 54.224s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 86.2% 1 49.452s + │└ReflectiveTactics.solve_side_conditio 0.0% 85.9% 1 49.264s + │ ├─ReflectiveTactics.do_reify -------- -0.0% 57.6% 1 33.004s + │ │└Reify.Reify_rhs_gen --------------- 1.3% 56.9% 1 32.608s + │ │ ├─Reify.do_reify_abs_goal --------- 43.1% 43.3% 2 24.840s + │ │ │└Reify.do_reifyf_goal ------------ 42.3% 42.6% 117 12.704s + │ │ │└eexact -------------------------- 13.4% 13.4% 117 0.084s + │ │ ├─prove_interp_compile_correct ---- 0.0% 3.3% 1 1.904s + │ │ │└rewrite ?EtaInterp.InterpExprEta 3.0% 3.0% 1 1.732s + │ │ └─rewrite H ----------------------- 3.3% 3.3% 1 1.896s + │ └─ReflectiveTactics.solve_post_reifie 0.1% 28.4% 1 16.260s + │ ├─UnifyAbstractReflexivity.unify_tr 19.6% 25.0% 7 4.824s + │ │└unify (constr) (constr) --------- 4.8% 4.8% 5 1.540s + │ └─ReflectiveTactics.unify_abstract_ 1.4% 2.1% 1 1.212s + └─Glue.refine_to_reflective_glue' ----- 0.0% 8.3% 1 4.772s + â””Glue.zrange_to_reflective ----------- 0.0% 7.8% 1 4.484s + â””Glue.zrange_to_reflective_goal ------ 1.7% 6.0% 1 3.464s + â””pose proof (pf : Interpretation. 4.2% 4.2% 1 2.416s +─synthesize ---------------------------- 0.0% 5.4% 1 3.124s +â””IntegrationTestTemporaryMiscCommon.do_r 0.0% 5.3% 1 3.040s +â””change G' ----------------------------- 5.2% 5.2% 1 2.964s + +src/Specific/solinas32_2e255m765_13limbs/femul (real: 181.77, user: 168.52, sys: 0.40, mem: 1589516 ko) +COQC src/Specific/NISTP256/AMD64/femul.v +Finished transaction in 119.257 secs (109.936u,0.256s) (successful) +total time: 110.140s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.1% 1 106.964s +─ReflectiveTactics.do_reflective_pipelin -0.0% 96.4% 1 106.196s +─ReflectiveTactics.solve_side_conditions 0.0% 96.2% 1 105.992s +─ReflectiveTactics.do_reify ------------ -0.0% 83.7% 1 92.208s +─Reify.Reify_rhs_gen ------------------- 0.7% 83.5% 1 91.960s +─Reify.do_reify_abs_goal --------------- 77.7% 77.8% 2 85.708s +─Reify.do_reifyf_goal ------------------ 77.4% 77.5% 901 85.364s +─eexact -------------------------------- 17.9% 17.9% 903 0.136s +─ReflectiveTactics.solve_post_reified_si 0.3% 12.5% 1 13.784s +─UnifyAbstractReflexivity.unify_transfor 9.8% 11.2% 7 3.356s +─synthesize_montgomery ----------------- 0.0% 2.9% 1 3.176s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.1% 1 106.964s +â””ReflectiveTactics.do_reflective_pipelin -0.0% 96.4% 1 106.196s +â””ReflectiveTactics.solve_side_conditions 0.0% 96.2% 1 105.992s + ├─ReflectiveTactics.do_reify ---------- -0.0% 83.7% 1 92.208s + │└Reify.Reify_rhs_gen ----------------- 0.7% 83.5% 1 91.960s + │└Reify.do_reify_abs_goal ------------- 77.7% 77.8% 2 85.708s + │└Reify.do_reifyf_goal ---------------- 77.4% 77.5% 901 85.364s + │└eexact ------------------------------ 17.7% 17.7% 901 0.136s + └─ReflectiveTactics.solve_post_reified_ 0.3% 12.5% 1 13.784s + â””UnifyAbstractReflexivity.unify_transf 9.8% 11.2% 7 3.356s +─synthesize_montgomery ----------------- 0.0% 2.9% 1 3.176s + +Finished transaction in 61.452 secs (58.503u,0.055s) (successful) +Closed under the global context +total time: 110.140s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.1% 1 106.964s +─ReflectiveTactics.do_reflective_pipelin -0.0% 96.4% 1 106.196s +─ReflectiveTactics.solve_side_conditions 0.0% 96.2% 1 105.992s +─ReflectiveTactics.do_reify ------------ -0.0% 83.7% 1 92.208s +─Reify.Reify_rhs_gen ------------------- 0.7% 83.5% 1 91.960s +─Reify.do_reify_abs_goal --------------- 77.7% 77.8% 2 85.708s +─Reify.do_reifyf_goal ------------------ 77.4% 77.5% 901 85.364s +─eexact -------------------------------- 17.9% 17.9% 903 0.136s +─ReflectiveTactics.solve_post_reified_si 0.3% 12.5% 1 13.784s +─UnifyAbstractReflexivity.unify_transfor 9.8% 11.2% 7 3.356s +─synthesize_montgomery ----------------- 0.0% 2.9% 1 3.176s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.1% 1 106.964s +â””ReflectiveTactics.do_reflective_pipelin -0.0% 96.4% 1 106.196s +â””ReflectiveTactics.solve_side_conditions 0.0% 96.2% 1 105.992s + ├─ReflectiveTactics.do_reify ---------- -0.0% 83.7% 1 92.208s + │└Reify.Reify_rhs_gen ----------------- 0.7% 83.5% 1 91.960s + │└Reify.do_reify_abs_goal ------------- 77.7% 77.8% 2 85.708s + │└Reify.do_reifyf_goal ---------------- 77.4% 77.5% 901 85.364s + │└eexact ------------------------------ 17.7% 17.7% 901 0.136s + └─ReflectiveTactics.solve_post_reified_ 0.3% 12.5% 1 13.784s + â””UnifyAbstractReflexivity.unify_transf 9.8% 11.2% 7 3.356s +─synthesize_montgomery ----------------- 0.0% 2.9% 1 3.176s + +src/Specific/NISTP256/AMD64/femul (real: 202.96, user: 189.62, sys: 0.64, mem: 3302508 ko) +COQC src/Specific/NISTP256/AMD64/femulDisplay > src/Specific/NISTP256/AMD64/femulDisplay.log +COQC src/Specific/X25519/C64/ladderstep.v +total time: 52.080s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_xzladderstep --------------- 0.0% 100.0% 1 52.080s +─Pipeline.refine_reflectively_gen ------ 0.0% 98.5% 1 51.320s +─ReflectiveTactics.do_reflective_pipelin 0.0% 93.8% 1 48.872s +─ReflectiveTactics.solve_side_conditions 0.0% 93.7% 1 48.776s +─ReflectiveTactics.solve_post_reified_si 0.2% 56.5% 1 29.412s +─UnifyAbstractReflexivity.unify_transfor 44.7% 49.1% 7 6.968s +─ReflectiveTactics.do_reify ------------ 0.0% 37.2% 1 19.364s +─Reify.Reify_rhs_gen ------------------- 2.1% 23.4% 1 12.200s +─Reify.do_reifyf_goal ------------------ 11.2% 11.3% 138 1.884s +─Compilers.Reify.reify_context_variables 0.1% 9.2% 1 4.808s +─rewrite H ----------------------------- 7.3% 7.3% 1 3.816s +─ReflectiveTactics.unify_abstract_cbv_in 4.7% 6.4% 1 3.336s +─Glue.refine_to_reflective_glue' ------- 0.0% 4.7% 1 2.448s +─Glue.zrange_to_reflective ------------- 0.0% 4.0% 1 2.068s +─Reify.transitivity_tt ----------------- 0.1% 3.7% 2 0.984s +─transitivity -------------------------- 3.5% 3.5% 10 0.880s +─reflexivity --------------------------- 3.4% 3.4% 11 0.772s +─Glue.zrange_to_reflective_goal -------- 2.4% 3.3% 1 1.728s +─eexact -------------------------------- 3.2% 3.2% 140 0.032s +─unify (constr) (constr) --------------- 3.1% 3.1% 6 0.852s +─clear (var_list) ---------------------- 3.1% 3.1% 98 0.584s +─UnfoldArg.unfold_second_arg ----------- 0.4% 3.0% 2 1.576s +─tac ----------------------------------- 2.1% 3.0% 2 1.564s +─ClearAll.clear_all -------------------- 0.2% 2.8% 7 0.584s +─ChangeInAll.change_with_compute_in_all 0.0% 2.6% 221 0.012s +─change c with c' in * ----------------- 2.5% 2.5% 221 0.012s +─Reify.do_reify_abs_goal --------------- 2.4% 2.5% 2 1.276s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_xzladderstep --------------- 0.0% 100.0% 1 52.080s +â””Pipeline.refine_reflectively_gen ------ 0.0% 98.5% 1 51.320s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 93.8% 1 48.872s + │└ReflectiveTactics.solve_side_conditio 0.0% 93.7% 1 48.776s + │ ├─ReflectiveTactics.solve_post_reifie 0.2% 56.5% 1 29.412s + │ │ ├─UnifyAbstractReflexivity.unify_tr 44.7% 49.1% 7 6.968s + │ │ │└ClearAll.clear_all -------------- 0.2% 2.8% 7 0.584s + │ │ │└clear (var_list) ---------------- 2.7% 2.7% 65 0.584s + │ │ └─ReflectiveTactics.unify_abstract_ 4.7% 6.4% 1 3.336s + │ └─ReflectiveTactics.do_reify -------- 0.0% 37.2% 1 19.364s + │ ├─Reify.Reify_rhs_gen ------------- 2.1% 23.4% 1 12.200s + │ │ ├─rewrite H --------------------- 7.3% 7.3% 1 3.816s + │ │ ├─Reify.transitivity_tt --------- 0.1% 3.7% 2 0.984s + │ │ │└transitivity ------------------ 3.4% 3.4% 4 0.880s + │ │ ├─tac --------------------------- 2.1% 3.0% 1 1.564s + │ │ └─Reify.do_reify_abs_goal ------- 2.4% 2.5% 2 1.276s + │ │ â””Reify.do_reifyf_goal ---------- 2.2% 2.2% 25 1.148s + │ ├─Compilers.Reify.reify_context_var 0.1% 9.2% 1 4.808s + │ │└Reify.do_reifyf_goal ------------ 9.0% 9.1% 113 1.884s + │ │└eexact -------------------------- 2.4% 2.4% 113 0.032s + │ └─UnfoldArg.unfold_second_arg ----- 0.4% 3.0% 2 1.576s + │ â””ChangeInAll.change_with_compute_i 0.0% 2.6% 221 0.012s + │ â””change c with c' in * ----------- 2.5% 2.5% 221 0.012s + └─Glue.refine_to_reflective_glue' ----- 0.0% 4.7% 1 2.448s + â””Glue.zrange_to_reflective ----------- 0.0% 4.0% 1 2.068s + â””Glue.zrange_to_reflective_goal ------ 2.4% 3.3% 1 1.728s + +Finished transaction in 171.122 secs (161.392u,0.039s) (successful) +Closed under the global context +total time: 52.080s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_xzladderstep --------------- 0.0% 100.0% 1 52.080s +─Pipeline.refine_reflectively_gen ------ 0.0% 98.5% 1 51.320s +─ReflectiveTactics.do_reflective_pipelin 0.0% 93.8% 1 48.872s +─ReflectiveTactics.solve_side_conditions 0.0% 93.7% 1 48.776s +─ReflectiveTactics.solve_post_reified_si 0.2% 56.5% 1 29.412s +─UnifyAbstractReflexivity.unify_transfor 44.7% 49.1% 7 6.968s +─ReflectiveTactics.do_reify ------------ 0.0% 37.2% 1 19.364s +─Reify.Reify_rhs_gen ------------------- 2.1% 23.4% 1 12.200s +─Reify.do_reifyf_goal ------------------ 11.2% 11.3% 138 1.884s +─Compilers.Reify.reify_context_variables 0.1% 9.2% 1 4.808s +─rewrite H ----------------------------- 7.3% 7.3% 1 3.816s +─ReflectiveTactics.unify_abstract_cbv_in 4.7% 6.4% 1 3.336s +─Glue.refine_to_reflective_glue' ------- 0.0% 4.7% 1 2.448s +─Glue.zrange_to_reflective ------------- 0.0% 4.0% 1 2.068s +─Reify.transitivity_tt ----------------- 0.1% 3.7% 2 0.984s +─transitivity -------------------------- 3.5% 3.5% 10 0.880s +─reflexivity --------------------------- 3.4% 3.4% 11 0.772s +─Glue.zrange_to_reflective_goal -------- 2.4% 3.3% 1 1.728s +─eexact -------------------------------- 3.2% 3.2% 140 0.032s +─unify (constr) (constr) --------------- 3.1% 3.1% 6 0.852s +─clear (var_list) ---------------------- 3.1% 3.1% 98 0.584s +─UnfoldArg.unfold_second_arg ----------- 0.4% 3.0% 2 1.576s +─tac ----------------------------------- 2.1% 3.0% 2 1.564s +─ClearAll.clear_all -------------------- 0.2% 2.8% 7 0.584s +─ChangeInAll.change_with_compute_in_all 0.0% 2.6% 221 0.012s +─change c with c' in * ----------------- 2.5% 2.5% 221 0.012s +─Reify.do_reify_abs_goal --------------- 2.4% 2.5% 2 1.276s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_xzladderstep --------------- 0.0% 100.0% 1 52.080s +â””Pipeline.refine_reflectively_gen ------ 0.0% 98.5% 1 51.320s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 93.8% 1 48.872s + │└ReflectiveTactics.solve_side_conditio 0.0% 93.7% 1 48.776s + │ ├─ReflectiveTactics.solve_post_reifie 0.2% 56.5% 1 29.412s + │ │ ├─UnifyAbstractReflexivity.unify_tr 44.7% 49.1% 7 6.968s + │ │ │└ClearAll.clear_all -------------- 0.2% 2.8% 7 0.584s + │ │ │└clear (var_list) ---------------- 2.7% 2.7% 65 0.584s + │ │ └─ReflectiveTactics.unify_abstract_ 4.7% 6.4% 1 3.336s + │ └─ReflectiveTactics.do_reify -------- 0.0% 37.2% 1 19.364s + │ ├─Reify.Reify_rhs_gen ------------- 2.1% 23.4% 1 12.200s + │ │ ├─rewrite H --------------------- 7.3% 7.3% 1 3.816s + │ │ ├─Reify.transitivity_tt --------- 0.1% 3.7% 2 0.984s + │ │ │└transitivity ------------------ 3.4% 3.4% 4 0.880s + │ │ ├─tac --------------------------- 2.1% 3.0% 1 1.564s + │ │ └─Reify.do_reify_abs_goal ------- 2.4% 2.5% 2 1.276s + │ │ â””Reify.do_reifyf_goal ---------- 2.2% 2.2% 25 1.148s + │ ├─Compilers.Reify.reify_context_var 0.1% 9.2% 1 4.808s + │ │└Reify.do_reifyf_goal ------------ 9.0% 9.1% 113 1.884s + │ │└eexact -------------------------- 2.4% 2.4% 113 0.032s + │ └─UnfoldArg.unfold_second_arg ----- 0.4% 3.0% 2 1.576s + │ â””ChangeInAll.change_with_compute_i 0.0% 2.6% 221 0.012s + │ â””change c with c' in * ----------- 2.5% 2.5% 221 0.012s + └─Glue.refine_to_reflective_glue' ----- 0.0% 4.7% 1 2.448s + â””Glue.zrange_to_reflective ----------- 0.0% 4.0% 1 2.068s + â””Glue.zrange_to_reflective_goal ------ 2.4% 3.3% 1 1.728s + +src/Specific/X25519/C64/ladderstep (real: 256.77, user: 241.34, sys: 0.45, mem: 1617000 ko) +COQC src/Specific/X25519/C64/ladderstepDisplay > src/Specific/X25519/C64/ladderstepDisplay.log diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-before.log.in b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-before.log.in new file mode 100644 index 0000000000..14102902b1 --- /dev/null +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-before.log.in @@ -0,0 +1,1662 @@ +COQDEP src/Compilers/Z/Bounds/Pipeline/Definition.v +COQDEP src/Compilers/Z/Bounds/Pipeline/ReflectiveTactics.v +/home/jgross/.local64/coq/coq-master/bin/coq_makefile -f _CoqProject INSTALLDEFAULTROOT = Crypto -o Makefile-old +COQ_MAKEFILE -f _CoqProject > Makefile.coq +make --no-print-directory -C coqprime +make[1]: Nothing to be done for 'all'. +ECHO > _CoqProject +COQC src/Compilers/Z/Bounds/Pipeline/Definition.v +src/Compilers/Z/Bounds/Pipeline/Definition (real: 7.40, user: 7.22, sys: 0.15, mem: 578344 ko) +COQC src/Compilers/Z/Bounds/Pipeline/ReflectiveTactics.v +src/Compilers/Z/Bounds/Pipeline/ReflectiveTactics (real: 1.73, user: 1.58, sys: 0.14, mem: 546112 ko) +COQC src/Compilers/Z/Bounds/Pipeline.v +src/Compilers/Z/Bounds/Pipeline (real: 1.18, user: 1.04, sys: 0.14, mem: 539160 ko) +COQC src/Specific/Framework/SynthesisFramework.v +src/Specific/Framework/SynthesisFramework (real: 1.95, user: 1.72, sys: 0.22, mem: 648632 ko) +COQC src/Specific/X25519/C64/Synthesis.v +src/Specific/X25519/C64/Synthesis (real: 11.23, user: 10.30, sys: 0.19, mem: 687812 ko) +COQC src/Specific/NISTP256/AMD64/Synthesis.v +src/Specific/NISTP256/AMD64/Synthesis (real: 13.74, user: 12.54, sys: 0.23, mem: 667664 ko) +COQC src/Specific/X25519/C64/feadd.v +Finished transaction in 2.852 secs (2.699u,0.012s) (successful) +total time: 2.664s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.4% 1 2.596s +─ReflectiveTactics.do_reflective_pipelin 0.0% 70.9% 1 1.888s +─ReflectiveTactics.solve_side_conditions 0.0% 69.5% 1 1.852s +─ReflectiveTactics.solve_post_reified_si 1.4% 43.7% 1 1.164s +─UnifyAbstractReflexivity.unify_transfor 27.0% 31.7% 8 0.256s +─Glue.refine_to_reflective_glue' ------- 0.0% 26.6% 1 0.708s +─ReflectiveTactics.do_reify ------------ 0.0% 25.8% 1 0.688s +─Reify.Reify_rhs_gen ------------------- 2.0% 24.0% 1 0.640s +─Glue.zrange_to_reflective ------------- 0.0% 17.9% 1 0.476s +─Glue.zrange_to_reflective_goal -------- 8.1% 13.1% 1 0.348s +─Reify.do_reify_abs_goal --------------- 12.8% 12.9% 2 0.344s +─Reify.do_reifyf_goal ------------------ 11.7% 11.9% 16 0.316s +─ReflectiveTactics.unify_abstract_cbv_in 7.7% 10.2% 1 0.272s +─unify (constr) (constr) --------------- 6.0% 6.0% 7 0.064s +─Glue.pattern_sig_sig_assoc ------------ 0.0% 5.0% 1 0.132s +─assert (H : is_bounded_by' bounds (map' 4.5% 4.7% 2 0.068s +─Glue.pattern_proj1_sig_in_sig --------- 1.5% 4.7% 1 0.124s +─pose proof (pf : Interpretation.Bo 3.3% 3.3% 1 0.088s +─Glue.split_BoundedWordToZ ------------- 0.2% 3.0% 1 0.080s +─destruct x ---------------------------- 2.7% 2.7% 4 0.032s +─clearbody (ne_var_list) --------------- 2.7% 2.7% 4 0.056s +─destruct_sig -------------------------- 0.0% 2.7% 4 0.040s +─synthesize ---------------------------- 0.0% 2.6% 1 0.068s +─prove_interp_compile_correct ---------- 0.0% 2.4% 1 0.064s +─reflexivity --------------------------- 2.3% 2.3% 7 0.028s +─rewrite ?EtaInterp.InterpExprEta ------ 2.3% 2.3% 1 0.060s +─ClearbodyAll.clearbody_all ------------ 0.0% 2.1% 2 0.056s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.4% 1 2.596s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 70.9% 1 1.888s + │└ReflectiveTactics.solve_side_conditio 0.0% 69.5% 1 1.852s + │ ├─ReflectiveTactics.solve_post_reifie 1.4% 43.7% 1 1.164s + │ │ ├─UnifyAbstractReflexivity.unify_tr 27.0% 31.7% 8 0.256s + │ │ │└unify (constr) (constr) --------- 3.6% 3.6% 6 0.028s + │ │ └─ReflectiveTactics.unify_abstract_ 7.7% 10.2% 1 0.272s + │ │ â””unify (constr) (constr) --------- 2.4% 2.4% 1 0.064s + │ └─ReflectiveTactics.do_reify -------- 0.0% 25.8% 1 0.688s + │ â””Reify.Reify_rhs_gen --------------- 2.0% 24.0% 1 0.640s + │ ├─Reify.do_reify_abs_goal --------- 12.8% 12.9% 2 0.344s + │ │└Reify.do_reifyf_goal ------------ 11.7% 11.9% 16 0.316s + │ └─prove_interp_compile_correct ---- 0.0% 2.4% 1 0.064s + │ â””rewrite ?EtaInterp.InterpExprEta 2.3% 2.3% 1 0.060s + └─Glue.refine_to_reflective_glue' ----- 0.0% 26.6% 1 0.708s + ├─Glue.zrange_to_reflective --------- 0.0% 17.9% 1 0.476s + │ ├─Glue.zrange_to_reflective_goal -- 8.1% 13.1% 1 0.348s + │ │└pose proof (pf : Interpretat 3.3% 3.3% 1 0.088s + │ └─assert (H : is_bounded_by' bounds 4.5% 4.7% 2 0.068s + ├─Glue.pattern_sig_sig_assoc -------- 0.0% 5.0% 1 0.132s + │└Glue.pattern_proj1_sig_in_sig ----- 1.5% 4.7% 1 0.124s + │└ClearbodyAll.clearbody_all -------- 0.0% 2.1% 2 0.056s + │└clearbody (ne_var_list) ----------- 2.1% 2.1% 1 0.056s + └─Glue.split_BoundedWordToZ --------- 0.2% 3.0% 1 0.080s + â””destruct_sig ---------------------- 0.0% 2.7% 4 0.040s + â””destruct x ------------------------ 2.1% 2.1% 2 0.032s +─synthesize ---------------------------- 0.0% 2.6% 1 0.068s + +Finished transaction in 5.46 secs (5.068u,0.003s) (successful) +Closed under the global context +total time: 2.664s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.4% 1 2.596s +─ReflectiveTactics.do_reflective_pipelin 0.0% 70.9% 1 1.888s +─ReflectiveTactics.solve_side_conditions 0.0% 69.5% 1 1.852s +─ReflectiveTactics.solve_post_reified_si 1.4% 43.7% 1 1.164s +─UnifyAbstractReflexivity.unify_transfor 27.0% 31.7% 8 0.256s +─Glue.refine_to_reflective_glue' ------- 0.0% 26.6% 1 0.708s +─ReflectiveTactics.do_reify ------------ 0.0% 25.8% 1 0.688s +─Reify.Reify_rhs_gen ------------------- 2.0% 24.0% 1 0.640s +─Glue.zrange_to_reflective ------------- 0.0% 17.9% 1 0.476s +─Glue.zrange_to_reflective_goal -------- 8.1% 13.1% 1 0.348s +─Reify.do_reify_abs_goal --------------- 12.8% 12.9% 2 0.344s +─Reify.do_reifyf_goal ------------------ 11.7% 11.9% 16 0.316s +─ReflectiveTactics.unify_abstract_cbv_in 7.7% 10.2% 1 0.272s +─unify (constr) (constr) --------------- 6.0% 6.0% 7 0.064s +─Glue.pattern_sig_sig_assoc ------------ 0.0% 5.0% 1 0.132s +─assert (H : is_bounded_by' bounds (map' 4.5% 4.7% 2 0.068s +─Glue.pattern_proj1_sig_in_sig --------- 1.5% 4.7% 1 0.124s +─pose proof (pf : Interpretation.Bo 3.3% 3.3% 1 0.088s +─Glue.split_BoundedWordToZ ------------- 0.2% 3.0% 1 0.080s +─destruct x ---------------------------- 2.7% 2.7% 4 0.032s +─clearbody (ne_var_list) --------------- 2.7% 2.7% 4 0.056s +─destruct_sig -------------------------- 0.0% 2.7% 4 0.040s +─synthesize ---------------------------- 0.0% 2.6% 1 0.068s +─prove_interp_compile_correct ---------- 0.0% 2.4% 1 0.064s +─reflexivity --------------------------- 2.3% 2.3% 7 0.028s +─rewrite ?EtaInterp.InterpExprEta ------ 2.3% 2.3% 1 0.060s +─ClearbodyAll.clearbody_all ------------ 0.0% 2.1% 2 0.056s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.4% 1 2.596s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 70.9% 1 1.888s + │└ReflectiveTactics.solve_side_conditio 0.0% 69.5% 1 1.852s + │ ├─ReflectiveTactics.solve_post_reifie 1.4% 43.7% 1 1.164s + │ │ ├─UnifyAbstractReflexivity.unify_tr 27.0% 31.7% 8 0.256s + │ │ │└unify (constr) (constr) --------- 3.6% 3.6% 6 0.028s + │ │ └─ReflectiveTactics.unify_abstract_ 7.7% 10.2% 1 0.272s + │ │ â””unify (constr) (constr) --------- 2.4% 2.4% 1 0.064s + │ └─ReflectiveTactics.do_reify -------- 0.0% 25.8% 1 0.688s + │ â””Reify.Reify_rhs_gen --------------- 2.0% 24.0% 1 0.640s + │ ├─Reify.do_reify_abs_goal --------- 12.8% 12.9% 2 0.344s + │ │└Reify.do_reifyf_goal ------------ 11.7% 11.9% 16 0.316s + │ └─prove_interp_compile_correct ---- 0.0% 2.4% 1 0.064s + │ â””rewrite ?EtaInterp.InterpExprEta 2.3% 2.3% 1 0.060s + └─Glue.refine_to_reflective_glue' ----- 0.0% 26.6% 1 0.708s + ├─Glue.zrange_to_reflective --------- 0.0% 17.9% 1 0.476s + │ ├─Glue.zrange_to_reflective_goal -- 8.1% 13.1% 1 0.348s + │ │└pose proof (pf : Interpretat 3.3% 3.3% 1 0.088s + │ └─assert (H : is_bounded_by' bounds 4.5% 4.7% 2 0.068s + ├─Glue.pattern_sig_sig_assoc -------- 0.0% 5.0% 1 0.132s + │└Glue.pattern_proj1_sig_in_sig ----- 1.5% 4.7% 1 0.124s + │└ClearbodyAll.clearbody_all -------- 0.0% 2.1% 2 0.056s + │└clearbody (ne_var_list) ----------- 2.1% 2.1% 1 0.056s + └─Glue.split_BoundedWordToZ --------- 0.2% 3.0% 1 0.080s + â””destruct_sig ---------------------- 0.0% 2.7% 4 0.040s + â””destruct x ------------------------ 2.1% 2.1% 2 0.032s +─synthesize ---------------------------- 0.0% 2.6% 1 0.068s + +src/Specific/X25519/C64/feadd (real: 23.43, user: 21.41, sys: 0.26, mem: 766168 ko) +COQC src/Specific/solinas32_2e255m765_12limbs/Synthesis.v +src/Specific/solinas32_2e255m765_12limbs/Synthesis (real: 39.53, user: 36.64, sys: 0.21, mem: 729464 ko) +COQC src/Specific/X25519/C64/fecarry.v +Finished transaction in 4.798 secs (4.375u,0.003s) (successful) +total time: 4.332s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.1% 99.0% 1 4.288s +─ReflectiveTactics.do_reflective_pipelin 0.0% 89.2% 1 3.864s +─ReflectiveTactics.solve_side_conditions 0.0% 88.1% 1 3.816s +─ReflectiveTactics.do_reify ------------ 0.0% 53.2% 1 2.304s +─Reify.Reify_rhs_gen ------------------- 1.8% 52.6% 1 2.280s +─ReflectiveTactics.solve_post_reified_si 0.6% 34.9% 1 1.512s +─Reify.do_reify_abs_goal --------------- 33.5% 33.9% 2 1.468s +─Reify.do_reifyf_goal ------------------ 32.1% 32.5% 29 1.408s +─UnifyAbstractReflexivity.unify_transfor 22.5% 27.1% 8 0.316s +─Glue.refine_to_reflective_glue' ------- 0.1% 9.7% 1 0.420s +─eexact -------------------------------- 9.3% 9.3% 31 0.024s +─ReflectiveTactics.unify_abstract_cbv_in 5.2% 7.0% 1 0.304s +─Glue.zrange_to_reflective ------------- 0.1% 6.2% 1 0.268s +─prove_interp_compile_correct ---------- 0.0% 5.6% 1 0.244s +─rewrite ?EtaInterp.InterpExprEta ------ 5.3% 5.3% 1 0.228s +─unify (constr) (constr) --------------- 5.3% 5.3% 7 0.076s +─Glue.zrange_to_reflective_goal -------- 4.0% 4.9% 1 0.212s +─rewrite H ----------------------------- 3.4% 3.4% 1 0.148s +─tac ----------------------------------- 1.8% 2.6% 2 0.112s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.1% 99.0% 1 4.288s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 89.2% 1 3.864s + │└ReflectiveTactics.solve_side_conditio 0.0% 88.1% 1 3.816s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 53.2% 1 2.304s + │ │└Reify.Reify_rhs_gen --------------- 1.8% 52.6% 1 2.280s + │ │ ├─Reify.do_reify_abs_goal --------- 33.5% 33.9% 2 1.468s + │ │ │└Reify.do_reifyf_goal ------------ 32.1% 32.5% 29 1.408s + │ │ │└eexact -------------------------- 8.6% 8.6% 29 0.024s + │ │ ├─prove_interp_compile_correct ---- 0.0% 5.6% 1 0.244s + │ │ │└rewrite ?EtaInterp.InterpExprEta 5.3% 5.3% 1 0.228s + │ │ ├─rewrite H ----------------------- 3.4% 3.4% 1 0.148s + │ │ └─tac ----------------------------- 1.8% 2.6% 1 0.112s + │ └─ReflectiveTactics.solve_post_reifie 0.6% 34.9% 1 1.512s + │ ├─UnifyAbstractReflexivity.unify_tr 22.5% 27.1% 8 0.316s + │ │└unify (constr) (constr) --------- 3.5% 3.5% 6 0.044s + │ └─ReflectiveTactics.unify_abstract_ 5.2% 7.0% 1 0.304s + └─Glue.refine_to_reflective_glue' ----- 0.1% 9.7% 1 0.420s + â””Glue.zrange_to_reflective ----------- 0.1% 6.2% 1 0.268s + â””Glue.zrange_to_reflective_goal ------ 4.0% 4.9% 1 0.212s + +Finished transaction in 8.342 secs (7.604u,0.008s) (successful) +Closed under the global context +total time: 4.332s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.1% 99.0% 1 4.288s +─ReflectiveTactics.do_reflective_pipelin 0.0% 89.2% 1 3.864s +─ReflectiveTactics.solve_side_conditions 0.0% 88.1% 1 3.816s +─ReflectiveTactics.do_reify ------------ 0.0% 53.2% 1 2.304s +─Reify.Reify_rhs_gen ------------------- 1.8% 52.6% 1 2.280s +─ReflectiveTactics.solve_post_reified_si 0.6% 34.9% 1 1.512s +─Reify.do_reify_abs_goal --------------- 33.5% 33.9% 2 1.468s +─Reify.do_reifyf_goal ------------------ 32.1% 32.5% 29 1.408s +─UnifyAbstractReflexivity.unify_transfor 22.5% 27.1% 8 0.316s +─Glue.refine_to_reflective_glue' ------- 0.1% 9.7% 1 0.420s +─eexact -------------------------------- 9.3% 9.3% 31 0.024s +─ReflectiveTactics.unify_abstract_cbv_in 5.2% 7.0% 1 0.304s +─Glue.zrange_to_reflective ------------- 0.1% 6.2% 1 0.268s +─prove_interp_compile_correct ---------- 0.0% 5.6% 1 0.244s +─rewrite ?EtaInterp.InterpExprEta ------ 5.3% 5.3% 1 0.228s +─unify (constr) (constr) --------------- 5.3% 5.3% 7 0.076s +─Glue.zrange_to_reflective_goal -------- 4.0% 4.9% 1 0.212s +─rewrite H ----------------------------- 3.4% 3.4% 1 0.148s +─tac ----------------------------------- 1.8% 2.6% 2 0.112s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.1% 99.0% 1 4.288s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 89.2% 1 3.864s + │└ReflectiveTactics.solve_side_conditio 0.0% 88.1% 1 3.816s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 53.2% 1 2.304s + │ │└Reify.Reify_rhs_gen --------------- 1.8% 52.6% 1 2.280s + │ │ ├─Reify.do_reify_abs_goal --------- 33.5% 33.9% 2 1.468s + │ │ │└Reify.do_reifyf_goal ------------ 32.1% 32.5% 29 1.408s + │ │ │└eexact -------------------------- 8.6% 8.6% 29 0.024s + │ │ ├─prove_interp_compile_correct ---- 0.0% 5.6% 1 0.244s + │ │ │└rewrite ?EtaInterp.InterpExprEta 5.3% 5.3% 1 0.228s + │ │ ├─rewrite H ----------------------- 3.4% 3.4% 1 0.148s + │ │ └─tac ----------------------------- 1.8% 2.6% 1 0.112s + │ └─ReflectiveTactics.solve_post_reifie 0.6% 34.9% 1 1.512s + │ ├─UnifyAbstractReflexivity.unify_tr 22.5% 27.1% 8 0.316s + │ │└unify (constr) (constr) --------- 3.5% 3.5% 6 0.044s + │ └─ReflectiveTactics.unify_abstract_ 5.2% 7.0% 1 0.304s + └─Glue.refine_to_reflective_glue' ----- 0.1% 9.7% 1 0.420s + â””Glue.zrange_to_reflective ----------- 0.1% 6.2% 1 0.268s + â””Glue.zrange_to_reflective_goal ------ 4.0% 4.9% 1 0.212s + +src/Specific/X25519/C64/fecarry (real: 28.85, user: 26.31, sys: 0.25, mem: 787148 ko) +COQC src/Specific/solinas32_2e255m765_13limbs/Synthesis.v +src/Specific/solinas32_2e255m765_13limbs/Synthesis (real: 49.50, user: 45.58, sys: 0.18, mem: 744472 ko) +COQC src/Specific/X25519/C64/femul.v +Finished transaction in 9.325 secs (8.62u,0.016s) (successful) +total time: 8.576s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 95.8% 1 8.220s +─ReflectiveTactics.do_reflective_pipelin 0.0% 87.7% 1 7.524s +─ReflectiveTactics.solve_side_conditions 0.0% 87.0% 1 7.460s +─ReflectiveTactics.do_reify ------------ 0.0% 43.8% 1 3.760s +─ReflectiveTactics.solve_post_reified_si 0.6% 43.1% 1 3.700s +─Reify.Reify_rhs_gen ------------------- 1.4% 43.0% 1 3.688s +─UnifyAbstractReflexivity.unify_transfor 31.1% 36.7% 8 1.096s +─Reify.do_reify_abs_goal --------------- 26.3% 26.6% 2 2.284s +─Reify.do_reifyf_goal ------------------ 25.3% 25.6% 58 1.440s +─Glue.refine_to_reflective_glue' ------- 0.0% 8.1% 1 0.696s +─eexact -------------------------------- 7.6% 7.6% 60 0.032s +─unify (constr) (constr) --------------- 5.8% 5.8% 7 0.128s +─Glue.zrange_to_reflective ------------- 0.0% 5.7% 1 0.488s +─ReflectiveTactics.unify_abstract_cbv_in 3.8% 5.5% 1 0.468s +─prove_interp_compile_correct ---------- 0.0% 5.2% 1 0.448s +─rewrite ?EtaInterp.InterpExprEta ------ 4.9% 4.9% 1 0.416s +─Glue.zrange_to_reflective_goal -------- 2.6% 4.2% 1 0.364s +─synthesize ---------------------------- 0.0% 4.2% 1 0.356s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 3.8% 1 0.328s +─rewrite H ----------------------------- 3.2% 3.2% 1 0.276s +─change G' ----------------------------- 3.2% 3.2% 1 0.272s +─tac ----------------------------------- 1.4% 2.1% 2 0.180s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 95.8% 1 8.220s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 87.7% 1 7.524s + │└ReflectiveTactics.solve_side_conditio 0.0% 87.0% 1 7.460s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 43.8% 1 3.760s + │ │└Reify.Reify_rhs_gen --------------- 1.4% 43.0% 1 3.688s + │ │ ├─Reify.do_reify_abs_goal --------- 26.3% 26.6% 2 2.284s + │ │ │└Reify.do_reifyf_goal ------------ 25.3% 25.6% 58 1.440s + │ │ │└eexact -------------------------- 6.9% 6.9% 58 0.032s + │ │ ├─prove_interp_compile_correct ---- 0.0% 5.2% 1 0.448s + │ │ │└rewrite ?EtaInterp.InterpExprEta 4.9% 4.9% 1 0.416s + │ │ ├─rewrite H ----------------------- 3.2% 3.2% 1 0.276s + │ │ └─tac ----------------------------- 1.4% 2.1% 1 0.180s + │ └─ReflectiveTactics.solve_post_reifie 0.6% 43.1% 1 3.700s + │ ├─UnifyAbstractReflexivity.unify_tr 31.1% 36.7% 8 1.096s + │ │└unify (constr) (constr) --------- 4.3% 4.3% 6 0.092s + │ └─ReflectiveTactics.unify_abstract_ 3.8% 5.5% 1 0.468s + └─Glue.refine_to_reflective_glue' ----- 0.0% 8.1% 1 0.696s + â””Glue.zrange_to_reflective ----------- 0.0% 5.7% 1 0.488s + â””Glue.zrange_to_reflective_goal ------ 2.6% 4.2% 1 0.364s +─synthesize ---------------------------- 0.0% 4.2% 1 0.356s +â””IntegrationTestTemporaryMiscCommon.do_r 0.0% 3.8% 1 0.328s +â””change G' ----------------------------- 3.2% 3.2% 1 0.272s + +Finished transaction in 16.611 secs (15.352u,0.s) (successful) +Closed under the global context +total time: 8.576s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 95.8% 1 8.220s +─ReflectiveTactics.do_reflective_pipelin 0.0% 87.7% 1 7.524s +─ReflectiveTactics.solve_side_conditions 0.0% 87.0% 1 7.460s +─ReflectiveTactics.do_reify ------------ 0.0% 43.8% 1 3.760s +─ReflectiveTactics.solve_post_reified_si 0.6% 43.1% 1 3.700s +─Reify.Reify_rhs_gen ------------------- 1.4% 43.0% 1 3.688s +─UnifyAbstractReflexivity.unify_transfor 31.1% 36.7% 8 1.096s +─Reify.do_reify_abs_goal --------------- 26.3% 26.6% 2 2.284s +─Reify.do_reifyf_goal ------------------ 25.3% 25.6% 58 1.440s +─Glue.refine_to_reflective_glue' ------- 0.0% 8.1% 1 0.696s +─eexact -------------------------------- 7.6% 7.6% 60 0.032s +─unify (constr) (constr) --------------- 5.8% 5.8% 7 0.128s +─Glue.zrange_to_reflective ------------- 0.0% 5.7% 1 0.488s +─ReflectiveTactics.unify_abstract_cbv_in 3.8% 5.5% 1 0.468s +─prove_interp_compile_correct ---------- 0.0% 5.2% 1 0.448s +─rewrite ?EtaInterp.InterpExprEta ------ 4.9% 4.9% 1 0.416s +─Glue.zrange_to_reflective_goal -------- 2.6% 4.2% 1 0.364s +─synthesize ---------------------------- 0.0% 4.2% 1 0.356s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 3.8% 1 0.328s +─rewrite H ----------------------------- 3.2% 3.2% 1 0.276s +─change G' ----------------------------- 3.2% 3.2% 1 0.272s +─tac ----------------------------------- 1.4% 2.1% 2 0.180s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 95.8% 1 8.220s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 87.7% 1 7.524s + │└ReflectiveTactics.solve_side_conditio 0.0% 87.0% 1 7.460s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 43.8% 1 3.760s + │ │└Reify.Reify_rhs_gen --------------- 1.4% 43.0% 1 3.688s + │ │ ├─Reify.do_reify_abs_goal --------- 26.3% 26.6% 2 2.284s + │ │ │└Reify.do_reifyf_goal ------------ 25.3% 25.6% 58 1.440s + │ │ │└eexact -------------------------- 6.9% 6.9% 58 0.032s + │ │ ├─prove_interp_compile_correct ---- 0.0% 5.2% 1 0.448s + │ │ │└rewrite ?EtaInterp.InterpExprEta 4.9% 4.9% 1 0.416s + │ │ ├─rewrite H ----------------------- 3.2% 3.2% 1 0.276s + │ │ └─tac ----------------------------- 1.4% 2.1% 1 0.180s + │ └─ReflectiveTactics.solve_post_reifie 0.6% 43.1% 1 3.700s + │ ├─UnifyAbstractReflexivity.unify_tr 31.1% 36.7% 8 1.096s + │ │└unify (constr) (constr) --------- 4.3% 4.3% 6 0.092s + │ └─ReflectiveTactics.unify_abstract_ 3.8% 5.5% 1 0.468s + └─Glue.refine_to_reflective_glue' ----- 0.0% 8.1% 1 0.696s + â””Glue.zrange_to_reflective ----------- 0.0% 5.7% 1 0.488s + â””Glue.zrange_to_reflective_goal ------ 2.6% 4.2% 1 0.364s +─synthesize ---------------------------- 0.0% 4.2% 1 0.356s +â””IntegrationTestTemporaryMiscCommon.do_r 0.0% 3.8% 1 0.328s +â””change G' ----------------------------- 3.2% 3.2% 1 0.272s + +src/Specific/X25519/C64/femul (real: 42.98, user: 39.50, sys: 0.29, mem: 839624 ko) +COQC src/Specific/X25519/C64/feaddDisplay > src/Specific/X25519/C64/feaddDisplay.log +COQC src/Specific/X25519/C64/fecarryDisplay > src/Specific/X25519/C64/fecarryDisplay.log +COQC src/Specific/X25519/C64/fesub.v +Finished transaction in 3.729 secs (3.48u,0.012s) (successful) +total time: 3.444s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 98.0% 1 3.376s +─ReflectiveTactics.do_reflective_pipelin 0.0% 77.1% 1 2.656s +─ReflectiveTactics.solve_side_conditions 0.0% 75.8% 1 2.612s +─ReflectiveTactics.solve_post_reified_si 1.2% 40.1% 1 1.380s +─ReflectiveTactics.do_reify ------------ 0.0% 35.8% 1 1.232s +─Reify.Reify_rhs_gen ------------------- 1.4% 34.4% 1 1.184s +─UnifyAbstractReflexivity.unify_transfor 25.7% 30.5% 8 0.324s +─Glue.refine_to_reflective_glue' ------- 0.0% 20.9% 1 0.720s +─Reify.do_reify_abs_goal --------------- 18.5% 18.8% 2 0.648s +─Reify.do_reifyf_goal ------------------ 17.3% 17.5% 16 0.604s +─Glue.zrange_to_reflective ------------- 0.0% 14.2% 1 0.488s +─Glue.zrange_to_reflective_goal -------- 6.5% 10.6% 1 0.364s +─ReflectiveTactics.unify_abstract_cbv_in 5.8% 8.0% 1 0.276s +─unify (constr) (constr) --------------- 5.8% 5.8% 7 0.076s +─eexact -------------------------------- 4.4% 4.4% 18 0.012s +─Glue.pattern_sig_sig_assoc ------------ 0.0% 3.8% 1 0.132s +─assert (H : is_bounded_by' bounds (map' 3.6% 3.6% 2 0.064s +─Glue.pattern_proj1_sig_in_sig --------- 1.2% 3.6% 1 0.124s +─prove_interp_compile_correct ---------- 0.0% 3.5% 1 0.120s +─rewrite H ----------------------------- 3.4% 3.4% 1 0.116s +─rewrite ?EtaInterp.InterpExprEta ------ 3.1% 3.1% 1 0.108s +─pose proof (pf : Interpretation.Bo 2.7% 2.7% 1 0.092s +─reflexivity --------------------------- 2.6% 2.6% 7 0.032s +─Glue.split_BoundedWordToZ ------------- 0.2% 2.4% 1 0.084s +─tac ----------------------------------- 1.7% 2.2% 2 0.076s +─Reify.transitivity_tt ----------------- 0.1% 2.2% 2 0.040s +─transitivity -------------------------- 2.1% 2.1% 5 0.032s +─clearbody (ne_var_list) --------------- 2.1% 2.1% 4 0.056s +─destruct_sig -------------------------- 0.0% 2.1% 4 0.040s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 98.0% 1 3.376s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 77.1% 1 2.656s + │└ReflectiveTactics.solve_side_conditio 0.0% 75.8% 1 2.612s + │ ├─ReflectiveTactics.solve_post_reifie 1.2% 40.1% 1 1.380s + │ │ ├─UnifyAbstractReflexivity.unify_tr 25.7% 30.5% 8 0.324s + │ │ │└unify (constr) (constr) --------- 3.6% 3.6% 6 0.040s + │ │ └─ReflectiveTactics.unify_abstract_ 5.8% 8.0% 1 0.276s + │ │ â””unify (constr) (constr) --------- 2.2% 2.2% 1 0.076s + │ └─ReflectiveTactics.do_reify -------- 0.0% 35.8% 1 1.232s + │ â””Reify.Reify_rhs_gen --------------- 1.4% 34.4% 1 1.184s + │ ├─Reify.do_reify_abs_goal --------- 18.5% 18.8% 2 0.648s + │ │└Reify.do_reifyf_goal ------------ 17.3% 17.5% 16 0.604s + │ │└eexact -------------------------- 3.8% 3.8% 16 0.012s + │ ├─prove_interp_compile_correct ---- 0.0% 3.5% 1 0.120s + │ │└rewrite ?EtaInterp.InterpExprEta 3.1% 3.1% 1 0.108s + │ ├─rewrite H ----------------------- 3.4% 3.4% 1 0.116s + │ ├─tac ----------------------------- 1.7% 2.2% 1 0.076s + │ └─Reify.transitivity_tt ----------- 0.1% 2.2% 2 0.040s + └─Glue.refine_to_reflective_glue' ----- 0.0% 20.9% 1 0.720s + ├─Glue.zrange_to_reflective --------- 0.0% 14.2% 1 0.488s + │ ├─Glue.zrange_to_reflective_goal -- 6.5% 10.6% 1 0.364s + │ │└pose proof (pf : Interpretat 2.7% 2.7% 1 0.092s + │ └─assert (H : is_bounded_by' bounds 3.6% 3.6% 2 0.064s + ├─Glue.pattern_sig_sig_assoc -------- 0.0% 3.8% 1 0.132s + │└Glue.pattern_proj1_sig_in_sig ----- 1.2% 3.6% 1 0.124s + └─Glue.split_BoundedWordToZ --------- 0.2% 2.4% 1 0.084s + â””destruct_sig ---------------------- 0.0% 2.1% 4 0.040s + +Finished transaction in 6.763 secs (6.183u,0.s) (successful) +Closed under the global context +total time: 3.444s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 98.0% 1 3.376s +─ReflectiveTactics.do_reflective_pipelin 0.0% 77.1% 1 2.656s +─ReflectiveTactics.solve_side_conditions 0.0% 75.8% 1 2.612s +─ReflectiveTactics.solve_post_reified_si 1.2% 40.1% 1 1.380s +─ReflectiveTactics.do_reify ------------ 0.0% 35.8% 1 1.232s +─Reify.Reify_rhs_gen ------------------- 1.4% 34.4% 1 1.184s +─UnifyAbstractReflexivity.unify_transfor 25.7% 30.5% 8 0.324s +─Glue.refine_to_reflective_glue' ------- 0.0% 20.9% 1 0.720s +─Reify.do_reify_abs_goal --------------- 18.5% 18.8% 2 0.648s +─Reify.do_reifyf_goal ------------------ 17.3% 17.5% 16 0.604s +─Glue.zrange_to_reflective ------------- 0.0% 14.2% 1 0.488s +─Glue.zrange_to_reflective_goal -------- 6.5% 10.6% 1 0.364s +─ReflectiveTactics.unify_abstract_cbv_in 5.8% 8.0% 1 0.276s +─unify (constr) (constr) --------------- 5.8% 5.8% 7 0.076s +─eexact -------------------------------- 4.4% 4.4% 18 0.012s +─Glue.pattern_sig_sig_assoc ------------ 0.0% 3.8% 1 0.132s +─assert (H : is_bounded_by' bounds (map' 3.6% 3.6% 2 0.064s +─Glue.pattern_proj1_sig_in_sig --------- 1.2% 3.6% 1 0.124s +─prove_interp_compile_correct ---------- 0.0% 3.5% 1 0.120s +─rewrite H ----------------------------- 3.4% 3.4% 1 0.116s +─rewrite ?EtaInterp.InterpExprEta ------ 3.1% 3.1% 1 0.108s +─pose proof (pf : Interpretation.Bo 2.7% 2.7% 1 0.092s +─reflexivity --------------------------- 2.6% 2.6% 7 0.032s +─Glue.split_BoundedWordToZ ------------- 0.2% 2.4% 1 0.084s +─tac ----------------------------------- 1.7% 2.2% 2 0.076s +─Reify.transitivity_tt ----------------- 0.1% 2.2% 2 0.040s +─transitivity -------------------------- 2.1% 2.1% 5 0.032s +─clearbody (ne_var_list) --------------- 2.1% 2.1% 4 0.056s +─destruct_sig -------------------------- 0.0% 2.1% 4 0.040s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 98.0% 1 3.376s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 77.1% 1 2.656s + │└ReflectiveTactics.solve_side_conditio 0.0% 75.8% 1 2.612s + │ ├─ReflectiveTactics.solve_post_reifie 1.2% 40.1% 1 1.380s + │ │ ├─UnifyAbstractReflexivity.unify_tr 25.7% 30.5% 8 0.324s + │ │ │└unify (constr) (constr) --------- 3.6% 3.6% 6 0.040s + │ │ └─ReflectiveTactics.unify_abstract_ 5.8% 8.0% 1 0.276s + │ │ â””unify (constr) (constr) --------- 2.2% 2.2% 1 0.076s + │ └─ReflectiveTactics.do_reify -------- 0.0% 35.8% 1 1.232s + │ â””Reify.Reify_rhs_gen --------------- 1.4% 34.4% 1 1.184s + │ ├─Reify.do_reify_abs_goal --------- 18.5% 18.8% 2 0.648s + │ │└Reify.do_reifyf_goal ------------ 17.3% 17.5% 16 0.604s + │ │└eexact -------------------------- 3.8% 3.8% 16 0.012s + │ ├─prove_interp_compile_correct ---- 0.0% 3.5% 1 0.120s + │ │└rewrite ?EtaInterp.InterpExprEta 3.1% 3.1% 1 0.108s + │ ├─rewrite H ----------------------- 3.4% 3.4% 1 0.116s + │ ├─tac ----------------------------- 1.7% 2.2% 1 0.076s + │ └─Reify.transitivity_tt ----------- 0.1% 2.2% 2 0.040s + └─Glue.refine_to_reflective_glue' ----- 0.0% 20.9% 1 0.720s + ├─Glue.zrange_to_reflective --------- 0.0% 14.2% 1 0.488s + │ ├─Glue.zrange_to_reflective_goal -- 6.5% 10.6% 1 0.364s + │ │└pose proof (pf : Interpretat 2.7% 2.7% 1 0.092s + │ └─assert (H : is_bounded_by' bounds 3.6% 3.6% 2 0.064s + ├─Glue.pattern_sig_sig_assoc -------- 0.0% 3.8% 1 0.132s + │└Glue.pattern_proj1_sig_in_sig ----- 1.2% 3.6% 1 0.124s + └─Glue.split_BoundedWordToZ --------- 0.2% 2.4% 1 0.084s + â””destruct_sig ---------------------- 0.0% 2.1% 4 0.040s + +src/Specific/X25519/C64/fesub (real: 26.11, user: 23.72, sys: 0.24, mem: 781808 ko) +COQC src/Specific/X25519/C64/fesquare.v +Finished transaction in 6.477 secs (6.044u,0.008s) (successful) +total time: 6.012s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize ---------------------------- 0.0% 100.0% 1 6.012s +─Pipeline.refine_reflectively_gen ------ 0.0% 95.9% 1 5.764s +─ReflectiveTactics.do_reflective_pipelin 0.0% 89.6% 1 5.388s +─ReflectiveTactics.solve_side_conditions 0.0% 88.8% 1 5.340s +─ReflectiveTactics.do_reify ------------ 0.0% 47.0% 1 2.828s +─Reify.Reify_rhs_gen ------------------- 1.5% 46.3% 1 2.784s +─ReflectiveTactics.solve_post_reified_si 0.5% 41.8% 1 2.512s +─UnifyAbstractReflexivity.unify_transfor 28.5% 34.1% 8 0.552s +─Reify.do_reify_abs_goal --------------- 28.7% 29.1% 2 1.752s +─Reify.do_reifyf_goal ------------------ 27.6% 27.9% 47 1.320s +─eexact -------------------------------- 8.4% 8.4% 49 0.024s +─ReflectiveTactics.unify_abstract_cbv_in 5.0% 6.9% 1 0.412s +─unify (constr) (constr) --------------- 6.3% 6.3% 7 0.104s +─Glue.refine_to_reflective_glue' ------- 0.0% 6.3% 1 0.376s +─prove_interp_compile_correct ---------- 0.0% 5.3% 1 0.316s +─rewrite ?EtaInterp.InterpExprEta ------ 4.8% 4.8% 1 0.288s +─Glue.zrange_to_reflective ------------- 0.0% 4.4% 1 0.264s +─IntegrationTestTemporaryMiscCommon.do_r 0.1% 3.7% 1 0.224s +─Glue.zrange_to_reflective_goal -------- 2.6% 3.3% 1 0.196s +─change G' ----------------------------- 3.1% 3.1% 1 0.188s +─rewrite H ----------------------------- 3.0% 3.0% 1 0.180s +─tac ----------------------------------- 1.9% 2.7% 2 0.160s +─reflexivity --------------------------- 2.4% 2.4% 7 0.060s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize ---------------------------- 0.0% 100.0% 1 6.012s + ├─Pipeline.refine_reflectively_gen ---- 0.0% 95.9% 1 5.764s + │ ├─ReflectiveTactics.do_reflective_pip 0.0% 89.6% 1 5.388s + │ │└ReflectiveTactics.solve_side_condit 0.0% 88.8% 1 5.340s + │ │ ├─ReflectiveTactics.do_reify ------ 0.0% 47.0% 1 2.828s + │ │ │└Reify.Reify_rhs_gen ------------- 1.5% 46.3% 1 2.784s + │ │ │ ├─Reify.do_reify_abs_goal ------- 28.7% 29.1% 2 1.752s + │ │ │ │└Reify.do_reifyf_goal ---------- 27.6% 27.9% 47 1.320s + │ │ │ │└eexact ------------------------ 7.7% 7.7% 47 0.024s + │ │ │ ├─prove_interp_compile_correct -- 0.0% 5.3% 1 0.316s + │ │ │ │└rewrite ?EtaInterp.InterpExprEt 4.8% 4.8% 1 0.288s + │ │ │ ├─rewrite H --------------------- 3.0% 3.0% 1 0.180s + │ │ │ └─tac --------------------------- 1.9% 2.7% 1 0.160s + │ │ └─ReflectiveTactics.solve_post_reif 0.5% 41.8% 1 2.512s + │ │ ├─UnifyAbstractReflexivity.unify_ 28.5% 34.1% 8 0.552s + │ │ │└unify (constr) (constr) ------- 4.6% 4.6% 6 0.076s + │ │ └─ReflectiveTactics.unify_abstrac 5.0% 6.9% 1 0.412s + │ └─Glue.refine_to_reflective_glue' --- 0.0% 6.3% 1 0.376s + │ â””Glue.zrange_to_reflective --------- 0.0% 4.4% 1 0.264s + │ â””Glue.zrange_to_reflective_goal ---- 2.6% 3.3% 1 0.196s + └─IntegrationTestTemporaryMiscCommon.do 0.1% 3.7% 1 0.224s + â””change G' --------------------------- 3.1% 3.1% 1 0.188s + +Finished transaction in 12.356 secs (11.331u,0.004s) (successful) +Closed under the global context +total time: 6.012s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize ---------------------------- 0.0% 100.0% 1 6.012s +─Pipeline.refine_reflectively_gen ------ 0.0% 95.9% 1 5.764s +─ReflectiveTactics.do_reflective_pipelin 0.0% 89.6% 1 5.388s +─ReflectiveTactics.solve_side_conditions 0.0% 88.8% 1 5.340s +─ReflectiveTactics.do_reify ------------ 0.0% 47.0% 1 2.828s +─Reify.Reify_rhs_gen ------------------- 1.5% 46.3% 1 2.784s +─ReflectiveTactics.solve_post_reified_si 0.5% 41.8% 1 2.512s +─UnifyAbstractReflexivity.unify_transfor 28.5% 34.1% 8 0.552s +─Reify.do_reify_abs_goal --------------- 28.7% 29.1% 2 1.752s +─Reify.do_reifyf_goal ------------------ 27.6% 27.9% 47 1.320s +─eexact -------------------------------- 8.4% 8.4% 49 0.024s +─ReflectiveTactics.unify_abstract_cbv_in 5.0% 6.9% 1 0.412s +─unify (constr) (constr) --------------- 6.3% 6.3% 7 0.104s +─Glue.refine_to_reflective_glue' ------- 0.0% 6.3% 1 0.376s +─prove_interp_compile_correct ---------- 0.0% 5.3% 1 0.316s +─rewrite ?EtaInterp.InterpExprEta ------ 4.8% 4.8% 1 0.288s +─Glue.zrange_to_reflective ------------- 0.0% 4.4% 1 0.264s +─IntegrationTestTemporaryMiscCommon.do_r 0.1% 3.7% 1 0.224s +─Glue.zrange_to_reflective_goal -------- 2.6% 3.3% 1 0.196s +─change G' ----------------------------- 3.1% 3.1% 1 0.188s +─rewrite H ----------------------------- 3.0% 3.0% 1 0.180s +─tac ----------------------------------- 1.9% 2.7% 2 0.160s +─reflexivity --------------------------- 2.4% 2.4% 7 0.060s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize ---------------------------- 0.0% 100.0% 1 6.012s + ├─Pipeline.refine_reflectively_gen ---- 0.0% 95.9% 1 5.764s + │ ├─ReflectiveTactics.do_reflective_pip 0.0% 89.6% 1 5.388s + │ │└ReflectiveTactics.solve_side_condit 0.0% 88.8% 1 5.340s + │ │ ├─ReflectiveTactics.do_reify ------ 0.0% 47.0% 1 2.828s + │ │ │└Reify.Reify_rhs_gen ------------- 1.5% 46.3% 1 2.784s + │ │ │ ├─Reify.do_reify_abs_goal ------- 28.7% 29.1% 2 1.752s + │ │ │ │└Reify.do_reifyf_goal ---------- 27.6% 27.9% 47 1.320s + │ │ │ │└eexact ------------------------ 7.7% 7.7% 47 0.024s + │ │ │ ├─prove_interp_compile_correct -- 0.0% 5.3% 1 0.316s + │ │ │ │└rewrite ?EtaInterp.InterpExprEt 4.8% 4.8% 1 0.288s + │ │ │ ├─rewrite H --------------------- 3.0% 3.0% 1 0.180s + │ │ │ └─tac --------------------------- 1.9% 2.7% 1 0.160s + │ │ └─ReflectiveTactics.solve_post_reif 0.5% 41.8% 1 2.512s + │ │ ├─UnifyAbstractReflexivity.unify_ 28.5% 34.1% 8 0.552s + │ │ │└unify (constr) (constr) ------- 4.6% 4.6% 6 0.076s + │ │ └─ReflectiveTactics.unify_abstrac 5.0% 6.9% 1 0.412s + │ └─Glue.refine_to_reflective_glue' --- 0.0% 6.3% 1 0.376s + │ â””Glue.zrange_to_reflective --------- 0.0% 4.4% 1 0.264s + │ â””Glue.zrange_to_reflective_goal ---- 2.6% 3.3% 1 0.196s + └─IntegrationTestTemporaryMiscCommon.do 0.1% 3.7% 1 0.224s + â””change G' --------------------------- 3.1% 3.1% 1 0.188s + +src/Specific/X25519/C64/fesquare (real: 35.23, user: 32.24, sys: 0.26, mem: 802776 ko) +COQC src/Specific/X25519/C64/femulDisplay > src/Specific/X25519/C64/femulDisplay.log +COQC src/Specific/X25519/C64/freeze.v +Finished transaction in 7.785 secs (7.139u,0.019s) (successful) +total time: 7.112s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_freeze --------------------- -0.0% 100.0% 1 7.112s +─Pipeline.refine_reflectively_gen ------ 0.0% 99.2% 1 7.056s +─ReflectiveTactics.do_reflective_pipelin 0.0% 92.8% 1 6.600s +─ReflectiveTactics.solve_side_conditions -0.0% 91.8% 1 6.532s +─ReflectiveTactics.do_reify ------------ 0.0% 57.1% 1 4.060s +─Reify.Reify_rhs_gen ------------------- 1.5% 56.4% 1 4.012s +─Reify.do_reify_abs_goal --------------- 40.1% 40.3% 2 2.868s +─Reify.do_reifyf_goal ------------------ 39.1% 39.4% 129 2.800s +─ReflectiveTactics.solve_post_reified_si 0.6% 34.8% 1 2.472s +─UnifyAbstractReflexivity.unify_transfor 25.2% 29.4% 8 0.428s +─eexact -------------------------------- 12.9% 12.9% 131 0.028s +─Glue.refine_to_reflective_glue' ------- 0.1% 6.4% 1 0.456s +─prove_interp_compile_correct ---------- 0.0% 4.7% 1 0.332s +─unify (constr) (constr) --------------- 4.6% 4.6% 7 0.096s +─ReflectiveTactics.unify_abstract_cbv_in 3.1% 4.6% 1 0.324s +─rewrite ?EtaInterp.InterpExprEta ------ 4.3% 4.3% 1 0.308s +─Glue.zrange_to_reflective ------------- 0.0% 4.1% 1 0.292s +─Glue.zrange_to_reflective_goal -------- 2.6% 3.2% 1 0.228s +─rewrite H ----------------------------- 3.0% 3.0% 1 0.212s +─reflexivity --------------------------- 2.3% 2.3% 7 0.064s +─Reify.transitivity_tt ----------------- 0.0% 2.1% 2 0.096s +─transitivity -------------------------- 2.1% 2.1% 5 0.084s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_freeze --------------------- -0.0% 100.0% 1 7.112s +â””Pipeline.refine_reflectively_gen ------ 0.0% 99.2% 1 7.056s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 92.8% 1 6.600s + │└ReflectiveTactics.solve_side_conditio -0.0% 91.8% 1 6.532s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 57.1% 1 4.060s + │ │└Reify.Reify_rhs_gen --------------- 1.5% 56.4% 1 4.012s + │ │ ├─Reify.do_reify_abs_goal --------- 40.1% 40.3% 2 2.868s + │ │ │└Reify.do_reifyf_goal ------------ 39.1% 39.4% 129 2.800s + │ │ │└eexact -------------------------- 12.4% 12.4% 129 0.028s + │ │ ├─prove_interp_compile_correct ---- 0.0% 4.7% 1 0.332s + │ │ │└rewrite ?EtaInterp.InterpExprEta 4.3% 4.3% 1 0.308s + │ │ ├─rewrite H ----------------------- 3.0% 3.0% 1 0.212s + │ │ └─Reify.transitivity_tt ----------- 0.0% 2.1% 2 0.096s + │ │ â””transitivity -------------------- 2.0% 2.0% 4 0.084s + │ └─ReflectiveTactics.solve_post_reifie 0.6% 34.8% 1 2.472s + │ ├─UnifyAbstractReflexivity.unify_tr 25.2% 29.4% 8 0.428s + │ │└unify (constr) (constr) --------- 3.2% 3.2% 6 0.068s + │ └─ReflectiveTactics.unify_abstract_ 3.1% 4.6% 1 0.324s + └─Glue.refine_to_reflective_glue' ----- 0.1% 6.4% 1 0.456s + â””Glue.zrange_to_reflective ----------- 0.0% 4.1% 1 0.292s + â””Glue.zrange_to_reflective_goal ------ 2.6% 3.2% 1 0.228s + +Finished transaction in 12.063 secs (11.036u,0.012s) (successful) +Closed under the global context +total time: 7.112s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_freeze --------------------- -0.0% 100.0% 1 7.112s +─Pipeline.refine_reflectively_gen ------ 0.0% 99.2% 1 7.056s +─ReflectiveTactics.do_reflective_pipelin 0.0% 92.8% 1 6.600s +─ReflectiveTactics.solve_side_conditions -0.0% 91.8% 1 6.532s +─ReflectiveTactics.do_reify ------------ 0.0% 57.1% 1 4.060s +─Reify.Reify_rhs_gen ------------------- 1.5% 56.4% 1 4.012s +─Reify.do_reify_abs_goal --------------- 40.1% 40.3% 2 2.868s +─Reify.do_reifyf_goal ------------------ 39.1% 39.4% 129 2.800s +─ReflectiveTactics.solve_post_reified_si 0.6% 34.8% 1 2.472s +─UnifyAbstractReflexivity.unify_transfor 25.2% 29.4% 8 0.428s +─eexact -------------------------------- 12.9% 12.9% 131 0.028s +─Glue.refine_to_reflective_glue' ------- 0.1% 6.4% 1 0.456s +─prove_interp_compile_correct ---------- 0.0% 4.7% 1 0.332s +─unify (constr) (constr) --------------- 4.6% 4.6% 7 0.096s +─ReflectiveTactics.unify_abstract_cbv_in 3.1% 4.6% 1 0.324s +─rewrite ?EtaInterp.InterpExprEta ------ 4.3% 4.3% 1 0.308s +─Glue.zrange_to_reflective ------------- 0.0% 4.1% 1 0.292s +─Glue.zrange_to_reflective_goal -------- 2.6% 3.2% 1 0.228s +─rewrite H ----------------------------- 3.0% 3.0% 1 0.212s +─reflexivity --------------------------- 2.3% 2.3% 7 0.064s +─Reify.transitivity_tt ----------------- 0.0% 2.1% 2 0.096s +─transitivity -------------------------- 2.1% 2.1% 5 0.084s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_freeze --------------------- -0.0% 100.0% 1 7.112s +â””Pipeline.refine_reflectively_gen ------ 0.0% 99.2% 1 7.056s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 92.8% 1 6.600s + │└ReflectiveTactics.solve_side_conditio -0.0% 91.8% 1 6.532s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 57.1% 1 4.060s + │ │└Reify.Reify_rhs_gen --------------- 1.5% 56.4% 1 4.012s + │ │ ├─Reify.do_reify_abs_goal --------- 40.1% 40.3% 2 2.868s + │ │ │└Reify.do_reifyf_goal ------------ 39.1% 39.4% 129 2.800s + │ │ │└eexact -------------------------- 12.4% 12.4% 129 0.028s + │ │ ├─prove_interp_compile_correct ---- 0.0% 4.7% 1 0.332s + │ │ │└rewrite ?EtaInterp.InterpExprEta 4.3% 4.3% 1 0.308s + │ │ ├─rewrite H ----------------------- 3.0% 3.0% 1 0.212s + │ │ └─Reify.transitivity_tt ----------- 0.0% 2.1% 2 0.096s + │ │ â””transitivity -------------------- 2.0% 2.0% 4 0.084s + │ └─ReflectiveTactics.solve_post_reifie 0.6% 34.8% 1 2.472s + │ ├─UnifyAbstractReflexivity.unify_tr 25.2% 29.4% 8 0.428s + │ │└unify (constr) (constr) --------- 3.2% 3.2% 6 0.068s + │ └─ReflectiveTactics.unify_abstract_ 3.1% 4.6% 1 0.324s + └─Glue.refine_to_reflective_glue' ----- 0.1% 6.4% 1 0.456s + â””Glue.zrange_to_reflective ----------- 0.0% 4.1% 1 0.292s + â””Glue.zrange_to_reflective_goal ------ 2.6% 3.2% 1 0.228s + +src/Specific/X25519/C64/freeze (real: 36.42, user: 33.24, sys: 0.26, mem: 826476 ko) +COQC src/Specific/NISTP256/AMD64/feadd.v +Finished transaction in 9.065 secs (8.452u,0.004s) (successful) +total time: 8.408s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 56.0% 1 4.712s +─ReflectiveTactics.do_reflective_pipelin 0.0% 47.7% 1 4.012s +─ReflectiveTactics.solve_side_conditions 0.0% 47.1% 1 3.960s +─synthesize_montgomery ----------------- 0.0% 44.0% 1 3.696s +─ReflectiveTactics.solve_post_reified_si 0.6% 26.4% 1 2.220s +─UnifyAbstractReflexivity.unify_transfor 18.0% 21.3% 8 0.508s +─IntegrationTestTemporaryMiscCommon.fact 1.3% 21.3% 1 1.788s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 21.0% 1 1.768s +─ReflectiveTactics.do_reify ------------ 0.0% 20.7% 1 1.740s +─Reify.Reify_rhs_gen ------------------- 1.0% 20.0% 1 1.684s +─DestructHyps.do_all_matches_then ------ 0.1% 18.6% 8 0.220s +─DestructHyps.do_one_match_then -------- 0.8% 18.5% 44 0.056s +─op_sig_side_conditions_t -------------- 0.0% 17.9% 1 1.504s +─do_tac -------------------------------- 0.0% 17.7% 43 0.052s +─destruct H ---------------------------- 17.7% 17.7% 36 0.052s +─rewrite <- (lem : lemT) by by_tac ltac: 0.3% 17.3% 1 1.452s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 17.3% 1 1.452s +─by_tac -------------------------------- 0.0% 17.0% 4 0.532s +─rewrite <- (ZRange.is_bounded_by_None_r 15.7% 15.8% 8 0.360s +─Reify.do_reify_abs_goal --------------- 9.1% 9.3% 2 0.780s +─Reify.do_reifyf_goal ------------------ 8.5% 8.6% 93 0.716s +─Glue.refine_to_reflective_glue' ------- 0.0% 8.3% 1 0.700s +─Glue.zrange_to_reflective ------------- 0.0% 5.3% 1 0.444s +─ReflectiveTactics.unify_abstract_cbv_in 2.9% 4.3% 1 0.360s +─Glue.zrange_to_reflective_goal -------- 2.5% 4.0% 1 0.336s +─unify (constr) (constr) --------------- 3.9% 3.9% 9 0.108s +─IntegrationTestTemporaryMiscCommon.do_s 0.0% 3.8% 1 0.316s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.8% 3.6% 3 0.300s +─k ------------------------------------- 2.6% 2.8% 1 0.232s +─rewrite H ----------------------------- 2.4% 2.4% 2 0.192s +─prove_interp_compile_correct ---------- 0.0% 2.4% 1 0.200s +─rewrite ?EtaInterp.InterpExprEta ------ 2.2% 2.2% 1 0.188s +─apply (fun f => MapProjections.proj2 2.1% 2.1% 2 0.108s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 56.0% 1 4.712s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 47.7% 1 4.012s + │└ReflectiveTactics.solve_side_conditio 0.0% 47.1% 1 3.960s + │ ├─ReflectiveTactics.solve_post_reifie 0.6% 26.4% 1 2.220s + │ │ ├─UnifyAbstractReflexivity.unify_tr 18.0% 21.3% 8 0.508s + │ │ │└unify (constr) (constr) --------- 2.6% 2.6% 6 0.064s + │ │ └─ReflectiveTactics.unify_abstract_ 2.9% 4.3% 1 0.360s + │ └─ReflectiveTactics.do_reify -------- 0.0% 20.7% 1 1.740s + │ â””Reify.Reify_rhs_gen --------------- 1.0% 20.0% 1 1.684s + │ ├─Reify.do_reify_abs_goal --------- 9.1% 9.3% 2 0.780s + │ │└Reify.do_reifyf_goal ------------ 8.5% 8.6% 93 0.716s + │ ├─prove_interp_compile_correct ---- 0.0% 2.4% 1 0.200s + │ │└rewrite ?EtaInterp.InterpExprEta 2.2% 2.2% 1 0.188s + │ └─rewrite H ----------------------- 2.3% 2.3% 1 0.192s + └─Glue.refine_to_reflective_glue' ----- 0.0% 8.3% 1 0.700s + â””Glue.zrange_to_reflective ----------- 0.0% 5.3% 1 0.444s + â””Glue.zrange_to_reflective_goal ------ 2.5% 4.0% 1 0.336s +─synthesize_montgomery ----------------- 0.0% 44.0% 1 3.696s + ├─IntegrationTestTemporaryMiscCommon.fa 1.3% 21.3% 1 1.788s + │└op_sig_side_conditions_t ------------ 0.0% 17.9% 1 1.504s + │ ├─DestructHyps.do_all_matches_then -- 0.1% 10.1% 4 0.220s + │ │└DestructHyps.do_one_match_then ---- 0.4% 10.0% 24 0.052s + │ │└do_tac ---------------------------- 0.0% 9.6% 20 0.048s + │ │└destruct H ------------------------ 9.6% 9.6% 20 0.048s + │ └─rewrite <- (ZRange.is_bounded_by_No 7.5% 7.6% 4 0.308s + └─IntegrationTestTemporaryMiscCommon.do 0.0% 21.0% 1 1.768s + ├─IntegrationTestTemporaryMiscCommon. 0.0% 17.3% 1 1.452s + │└rewrite <- (lem : lemT) by by_tac l 0.3% 17.3% 1 1.452s + │└by_tac ---------------------------- 0.0% 17.0% 4 0.532s + │ ├─DestructHyps.do_all_matches_then 0.0% 8.5% 4 0.184s + │ │└DestructHyps.do_one_match_then -- 0.3% 8.5% 20 0.056s + │ │└do_tac -------------------------- 0.0% 8.2% 16 0.052s + │ │└destruct H ---------------------- 8.2% 8.2% 16 0.052s + │ └─rewrite <- (ZRange.is_bounded_by_ 8.2% 8.3% 4 0.360s + └─IntegrationTestTemporaryMiscCommon. 0.0% 3.8% 1 0.316s + â””<Crypto.Util.Tactics.MoveLetIn.with 0.8% 3.6% 3 0.300s + â””k --------------------------------- 2.6% 2.8% 1 0.232s + +Finished transaction in 15.052 secs (13.947u,0.003s) (successful) +Closed under the global context +total time: 8.408s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 56.0% 1 4.712s +─ReflectiveTactics.do_reflective_pipelin 0.0% 47.7% 1 4.012s +─ReflectiveTactics.solve_side_conditions 0.0% 47.1% 1 3.960s +─synthesize_montgomery ----------------- 0.0% 44.0% 1 3.696s +─ReflectiveTactics.solve_post_reified_si 0.6% 26.4% 1 2.220s +─UnifyAbstractReflexivity.unify_transfor 18.0% 21.3% 8 0.508s +─IntegrationTestTemporaryMiscCommon.fact 1.3% 21.3% 1 1.788s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 21.0% 1 1.768s +─ReflectiveTactics.do_reify ------------ 0.0% 20.7% 1 1.740s +─Reify.Reify_rhs_gen ------------------- 1.0% 20.0% 1 1.684s +─DestructHyps.do_all_matches_then ------ 0.1% 18.6% 8 0.220s +─DestructHyps.do_one_match_then -------- 0.8% 18.5% 44 0.056s +─op_sig_side_conditions_t -------------- 0.0% 17.9% 1 1.504s +─do_tac -------------------------------- 0.0% 17.7% 43 0.052s +─destruct H ---------------------------- 17.7% 17.7% 36 0.052s +─rewrite <- (lem : lemT) by by_tac ltac: 0.3% 17.3% 1 1.452s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 17.3% 1 1.452s +─by_tac -------------------------------- 0.0% 17.0% 4 0.532s +─rewrite <- (ZRange.is_bounded_by_None_r 15.7% 15.8% 8 0.360s +─Reify.do_reify_abs_goal --------------- 9.1% 9.3% 2 0.780s +─Reify.do_reifyf_goal ------------------ 8.5% 8.6% 93 0.716s +─Glue.refine_to_reflective_glue' ------- 0.0% 8.3% 1 0.700s +─Glue.zrange_to_reflective ------------- 0.0% 5.3% 1 0.444s +─ReflectiveTactics.unify_abstract_cbv_in 2.9% 4.3% 1 0.360s +─Glue.zrange_to_reflective_goal -------- 2.5% 4.0% 1 0.336s +─unify (constr) (constr) --------------- 3.9% 3.9% 9 0.108s +─IntegrationTestTemporaryMiscCommon.do_s 0.0% 3.8% 1 0.316s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.8% 3.6% 3 0.300s +─k ------------------------------------- 2.6% 2.8% 1 0.232s +─rewrite H ----------------------------- 2.4% 2.4% 2 0.192s +─prove_interp_compile_correct ---------- 0.0% 2.4% 1 0.200s +─rewrite ?EtaInterp.InterpExprEta ------ 2.2% 2.2% 1 0.188s +─apply (fun f => MapProjections.proj2 2.1% 2.1% 2 0.108s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 56.0% 1 4.712s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 47.7% 1 4.012s + │└ReflectiveTactics.solve_side_conditio 0.0% 47.1% 1 3.960s + │ ├─ReflectiveTactics.solve_post_reifie 0.6% 26.4% 1 2.220s + │ │ ├─UnifyAbstractReflexivity.unify_tr 18.0% 21.3% 8 0.508s + │ │ │└unify (constr) (constr) --------- 2.6% 2.6% 6 0.064s + │ │ └─ReflectiveTactics.unify_abstract_ 2.9% 4.3% 1 0.360s + │ └─ReflectiveTactics.do_reify -------- 0.0% 20.7% 1 1.740s + │ â””Reify.Reify_rhs_gen --------------- 1.0% 20.0% 1 1.684s + │ ├─Reify.do_reify_abs_goal --------- 9.1% 9.3% 2 0.780s + │ │└Reify.do_reifyf_goal ------------ 8.5% 8.6% 93 0.716s + │ ├─prove_interp_compile_correct ---- 0.0% 2.4% 1 0.200s + │ │└rewrite ?EtaInterp.InterpExprEta 2.2% 2.2% 1 0.188s + │ └─rewrite H ----------------------- 2.3% 2.3% 1 0.192s + └─Glue.refine_to_reflective_glue' ----- 0.0% 8.3% 1 0.700s + â””Glue.zrange_to_reflective ----------- 0.0% 5.3% 1 0.444s + â””Glue.zrange_to_reflective_goal ------ 2.5% 4.0% 1 0.336s +─synthesize_montgomery ----------------- 0.0% 44.0% 1 3.696s + ├─IntegrationTestTemporaryMiscCommon.fa 1.3% 21.3% 1 1.788s + │└op_sig_side_conditions_t ------------ 0.0% 17.9% 1 1.504s + │ ├─DestructHyps.do_all_matches_then -- 0.1% 10.1% 4 0.220s + │ │└DestructHyps.do_one_match_then ---- 0.4% 10.0% 24 0.052s + │ │└do_tac ---------------------------- 0.0% 9.6% 20 0.048s + │ │└destruct H ------------------------ 9.6% 9.6% 20 0.048s + │ └─rewrite <- (ZRange.is_bounded_by_No 7.5% 7.6% 4 0.308s + └─IntegrationTestTemporaryMiscCommon.do 0.0% 21.0% 1 1.768s + ├─IntegrationTestTemporaryMiscCommon. 0.0% 17.3% 1 1.452s + │└rewrite <- (lem : lemT) by by_tac l 0.3% 17.3% 1 1.452s + │└by_tac ---------------------------- 0.0% 17.0% 4 0.532s + │ ├─DestructHyps.do_all_matches_then 0.0% 8.5% 4 0.184s + │ │└DestructHyps.do_one_match_then -- 0.3% 8.5% 20 0.056s + │ │└do_tac -------------------------- 0.0% 8.2% 16 0.052s + │ │└destruct H ---------------------- 8.2% 8.2% 16 0.052s + │ └─rewrite <- (ZRange.is_bounded_by_ 8.2% 8.3% 4 0.360s + └─IntegrationTestTemporaryMiscCommon. 0.0% 3.8% 1 0.316s + â””<Crypto.Util.Tactics.MoveLetIn.with 0.8% 3.6% 3 0.300s + â””k --------------------------------- 2.6% 2.8% 1 0.232s + +src/Specific/NISTP256/AMD64/feadd (real: 40.48, user: 37.21, sys: 0.27, mem: 797944 ko) +COQC src/Specific/NISTP256/AMD64/fenz.v +Finished transaction in 6.724 secs (6.196u,0.007s) (successful) +total time: 6.180s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_nonzero -------------------- 0.0% 100.0% 1 6.180s +─IntegrationTestTemporaryMiscCommon.nonz 0.1% 84.5% 1 5.224s +─destruct (Decidable.dec x), (Decidable. 36.7% 36.7% 1 2.268s +─destruct (Decidable.dec x) as [H| H] -- 21.6% 21.6% 1 1.336s +─Pipeline.refine_reflectively_gen ------ 0.1% 15.5% 1 0.956s +─ReflectiveTactics.do_reflective_pipelin 0.0% 11.9% 1 0.736s +─ReflectiveTactics.solve_side_conditions 0.0% 11.6% 1 0.716s +─ReflectiveTactics.solve_post_reified_si 0.3% 9.6% 1 0.592s +─IntegrationTestTemporaryMiscCommon.op_s 0.1% 7.9% 2 0.392s +─rewrite <- (ZRange.is_bounded_by_None_r 5.2% 5.2% 2 0.308s +─UnifyAbstractReflexivity.unify_transfor 4.2% 5.2% 8 0.076s +─ReflectiveTactics.unify_abstract_cbv_in 3.0% 4.0% 1 0.248s +─Glue.refine_to_reflective_glue' ------- 0.0% 3.5% 1 0.216s +─rewrite H' ---------------------------- 3.4% 3.4% 1 0.208s +─generalize dependent (constr) --------- 3.1% 3.1% 4 0.068s +─congruence ---------------------------- 2.8% 2.8% 1 0.176s +─IntegrationTestTemporaryMiscCommon.do_s 0.0% 2.7% 1 0.164s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.5% 2.6% 3 0.156s +─DestructHyps.do_one_match_then -------- 0.1% 2.5% 6 0.048s +─DestructHyps.do_all_matches_then ------ 0.0% 2.5% 2 0.084s +─do_tac -------------------------------- 0.0% 2.5% 7 0.044s +─destruct H ---------------------------- 2.5% 2.5% 4 0.044s +─Glue.zrange_to_reflective ------------- 0.1% 2.1% 1 0.132s +─rewrite H ----------------------------- 1.9% 2.1% 3 0.116s +─k ------------------------------------- 1.9% 2.0% 1 0.124s +─ReflectiveTactics.do_reify ------------ 0.0% 2.0% 1 0.124s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_nonzero -------------------- 0.0% 100.0% 1 6.180s + ├─IntegrationTestTemporaryMiscCommon.no 0.1% 84.5% 1 5.224s + │ ├─destruct (Decidable.dec x), (Decida 36.7% 36.7% 1 2.268s + │ ├─destruct (Decidable.dec x) as [H| H 21.6% 21.6% 1 1.336s + │ ├─IntegrationTestTemporaryMiscCommon. 0.1% 7.9% 2 0.392s + │ │ ├─rewrite <- (ZRange.is_bounded_by_ 5.2% 5.2% 2 0.308s + │ │ └─DestructHyps.do_all_matches_then 0.0% 2.5% 2 0.084s + │ │ â””DestructHyps.do_one_match_then -- 0.1% 2.5% 6 0.048s + │ │ â””do_tac -------------------------- 0.0% 2.5% 4 0.044s + │ │ â””destruct H ---------------------- 2.5% 2.5% 4 0.044s + │ ├─rewrite H' ------------------------ 3.4% 3.4% 1 0.208s + │ ├─generalize dependent (constr) ----- 3.1% 3.1% 4 0.068s + │ ├─congruence ------------------------ 2.8% 2.8% 1 0.176s + │ └─IntegrationTestTemporaryMiscCommon. 0.0% 2.7% 1 0.164s + │ â””<Crypto.Util.Tactics.MoveLetIn.with 0.5% 2.6% 3 0.156s + │ â””k --------------------------------- 1.9% 2.0% 1 0.124s + └─Pipeline.refine_reflectively_gen ---- 0.1% 15.5% 1 0.956s + ├─ReflectiveTactics.do_reflective_pip 0.0% 11.9% 1 0.736s + │└ReflectiveTactics.solve_side_condit 0.0% 11.6% 1 0.716s + │ ├─ReflectiveTactics.solve_post_reif 0.3% 9.6% 1 0.592s + │ │ ├─UnifyAbstractReflexivity.unify_ 4.2% 5.2% 8 0.076s + │ │ └─ReflectiveTactics.unify_abstrac 3.0% 4.0% 1 0.248s + │ └─ReflectiveTactics.do_reify ------ 0.0% 2.0% 1 0.124s + └─Glue.refine_to_reflective_glue' --- 0.0% 3.5% 1 0.216s + â””Glue.zrange_to_reflective --------- 0.1% 2.1% 1 0.132s + +Finished transaction in 7.301 secs (6.731u,0.s) (successful) +Closed under the global context +total time: 6.180s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_nonzero -------------------- 0.0% 100.0% 1 6.180s +─IntegrationTestTemporaryMiscCommon.nonz 0.1% 84.5% 1 5.224s +─destruct (Decidable.dec x), (Decidable. 36.7% 36.7% 1 2.268s +─destruct (Decidable.dec x) as [H| H] -- 21.6% 21.6% 1 1.336s +─Pipeline.refine_reflectively_gen ------ 0.1% 15.5% 1 0.956s +─ReflectiveTactics.do_reflective_pipelin 0.0% 11.9% 1 0.736s +─ReflectiveTactics.solve_side_conditions 0.0% 11.6% 1 0.716s +─ReflectiveTactics.solve_post_reified_si 0.3% 9.6% 1 0.592s +─IntegrationTestTemporaryMiscCommon.op_s 0.1% 7.9% 2 0.392s +─rewrite <- (ZRange.is_bounded_by_None_r 5.2% 5.2% 2 0.308s +─UnifyAbstractReflexivity.unify_transfor 4.2% 5.2% 8 0.076s +─ReflectiveTactics.unify_abstract_cbv_in 3.0% 4.0% 1 0.248s +─Glue.refine_to_reflective_glue' ------- 0.0% 3.5% 1 0.216s +─rewrite H' ---------------------------- 3.4% 3.4% 1 0.208s +─generalize dependent (constr) --------- 3.1% 3.1% 4 0.068s +─congruence ---------------------------- 2.8% 2.8% 1 0.176s +─IntegrationTestTemporaryMiscCommon.do_s 0.0% 2.7% 1 0.164s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.5% 2.6% 3 0.156s +─DestructHyps.do_one_match_then -------- 0.1% 2.5% 6 0.048s +─DestructHyps.do_all_matches_then ------ 0.0% 2.5% 2 0.084s +─do_tac -------------------------------- 0.0% 2.5% 7 0.044s +─destruct H ---------------------------- 2.5% 2.5% 4 0.044s +─Glue.zrange_to_reflective ------------- 0.1% 2.1% 1 0.132s +─rewrite H ----------------------------- 1.9% 2.1% 3 0.116s +─k ------------------------------------- 1.9% 2.0% 1 0.124s +─ReflectiveTactics.do_reify ------------ 0.0% 2.0% 1 0.124s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_nonzero -------------------- 0.0% 100.0% 1 6.180s + ├─IntegrationTestTemporaryMiscCommon.no 0.1% 84.5% 1 5.224s + │ ├─destruct (Decidable.dec x), (Decida 36.7% 36.7% 1 2.268s + │ ├─destruct (Decidable.dec x) as [H| H 21.6% 21.6% 1 1.336s + │ ├─IntegrationTestTemporaryMiscCommon. 0.1% 7.9% 2 0.392s + │ │ ├─rewrite <- (ZRange.is_bounded_by_ 5.2% 5.2% 2 0.308s + │ │ └─DestructHyps.do_all_matches_then 0.0% 2.5% 2 0.084s + │ │ â””DestructHyps.do_one_match_then -- 0.1% 2.5% 6 0.048s + │ │ â””do_tac -------------------------- 0.0% 2.5% 4 0.044s + │ │ â””destruct H ---------------------- 2.5% 2.5% 4 0.044s + │ ├─rewrite H' ------------------------ 3.4% 3.4% 1 0.208s + │ ├─generalize dependent (constr) ----- 3.1% 3.1% 4 0.068s + │ ├─congruence ------------------------ 2.8% 2.8% 1 0.176s + │ └─IntegrationTestTemporaryMiscCommon. 0.0% 2.7% 1 0.164s + │ â””<Crypto.Util.Tactics.MoveLetIn.with 0.5% 2.6% 3 0.156s + │ â””k --------------------------------- 1.9% 2.0% 1 0.124s + └─Pipeline.refine_reflectively_gen ---- 0.1% 15.5% 1 0.956s + ├─ReflectiveTactics.do_reflective_pip 0.0% 11.9% 1 0.736s + │└ReflectiveTactics.solve_side_condit 0.0% 11.6% 1 0.716s + │ ├─ReflectiveTactics.solve_post_reif 0.3% 9.6% 1 0.592s + │ │ ├─UnifyAbstractReflexivity.unify_ 4.2% 5.2% 8 0.076s + │ │ └─ReflectiveTactics.unify_abstrac 3.0% 4.0% 1 0.248s + │ └─ReflectiveTactics.do_reify ------ 0.0% 2.0% 1 0.124s + └─Glue.refine_to_reflective_glue' --- 0.0% 3.5% 1 0.216s + â””Glue.zrange_to_reflective --------- 0.1% 2.1% 1 0.132s + +src/Specific/NISTP256/AMD64/fenz (real: 28.91, user: 26.41, sys: 0.19, mem: 756216 ko) +COQC src/Specific/NISTP256/AMD64/feopp.v +Finished transaction in 7.716 secs (7.216u,0.s) (successful) +total time: 7.168s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 59.8% 1 4.284s +─IntegrationTestTemporaryMiscCommon.fact 17.6% 49.1% 1 3.516s +─Pipeline.refine_reflectively_gen ------ 0.0% 40.2% 1 2.884s +─ReflectiveTactics.do_reflective_pipelin 0.0% 35.3% 1 2.528s +─ReflectiveTactics.solve_side_conditions 0.0% 34.8% 1 2.492s +─reflexivity --------------------------- 23.8% 23.8% 8 1.660s +─ReflectiveTactics.solve_post_reified_si 0.4% 21.0% 1 1.504s +─UnifyAbstractReflexivity.unify_transfor 13.8% 16.4% 8 0.268s +─ReflectiveTactics.do_reify ------------ 0.1% 13.8% 1 0.988s +─Reify.Reify_rhs_gen ------------------- 0.8% 13.6% 1 0.972s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 9.5% 1 0.680s +─rewrite <- (ZRange.is_bounded_by_None_r 8.7% 8.7% 4 0.332s +─rewrite <- (lem : lemT) by by_tac ltac: 0.1% 7.3% 1 0.520s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 7.3% 1 0.520s +─op_sig_side_conditions_t -------------- 0.0% 7.2% 1 0.516s +─by_tac -------------------------------- 0.0% 7.1% 2 0.412s +─Reify.do_reify_abs_goal --------------- 6.9% 7.0% 2 0.500s +─Reify.do_reifyf_goal ------------------ 6.3% 6.5% 62 0.460s +─DestructHyps.do_one_match_then -------- 0.3% 5.4% 14 0.044s +─DestructHyps.do_all_matches_then ------ 0.0% 5.4% 4 0.116s +─do_tac -------------------------------- 0.0% 5.1% 13 0.044s +─destruct H ---------------------------- 5.1% 5.1% 10 0.044s +─Glue.refine_to_reflective_glue' ------- 0.0% 5.0% 1 0.356s +─ReflectiveTactics.unify_abstract_cbv_in 3.1% 4.1% 1 0.292s +─Glue.zrange_to_reflective ------------- 0.0% 3.4% 1 0.244s +─unify (constr) (constr) --------------- 3.1% 3.1% 8 0.072s +─Glue.zrange_to_reflective_goal -------- 2.1% 2.7% 1 0.196s +─IntegrationTestTemporaryMiscCommon.do_s 0.0% 2.2% 1 0.160s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.3% 2.2% 3 0.152s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 59.8% 1 4.284s + ├─IntegrationTestTemporaryMiscCommon.fa 17.6% 49.1% 1 3.516s + │ ├─reflexivity ----------------------- 23.2% 23.2% 1 1.660s + │ └─op_sig_side_conditions_t ---------- 0.0% 7.2% 1 0.516s + │ ├─rewrite <- (ZRange.is_bounded_by_ 3.9% 3.9% 2 0.272s + │ └─DestructHyps.do_all_matches_then 0.0% 3.2% 2 0.116s + │ â””DestructHyps.do_one_match_then -- 0.2% 3.2% 8 0.044s + │ â””do_tac -------------------------- 0.0% 3.0% 6 0.040s + │ â””destruct H ---------------------- 3.0% 3.0% 6 0.040s + └─IntegrationTestTemporaryMiscCommon.do 0.0% 9.5% 1 0.680s + ├─IntegrationTestTemporaryMiscCommon. 0.0% 7.3% 1 0.520s + │└rewrite <- (lem : lemT) by by_tac l 0.1% 7.3% 1 0.520s + │└by_tac ---------------------------- 0.0% 7.1% 2 0.412s + │ ├─rewrite <- (ZRange.is_bounded_by_ 4.8% 4.8% 2 0.332s + │ └─DestructHyps.do_all_matches_then 0.0% 2.2% 2 0.080s + │ â””DestructHyps.do_one_match_then -- 0.1% 2.2% 6 0.044s + │ â””do_tac -------------------------- 0.0% 2.2% 4 0.044s + │ â””destruct H ---------------------- 2.2% 2.2% 4 0.044s + └─IntegrationTestTemporaryMiscCommon. 0.0% 2.2% 1 0.160s + â””<Crypto.Util.Tactics.MoveLetIn.with 0.3% 2.2% 3 0.152s +─Pipeline.refine_reflectively_gen ------ 0.0% 40.2% 1 2.884s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 35.3% 1 2.528s + │└ReflectiveTactics.solve_side_conditio 0.0% 34.8% 1 2.492s + │ ├─ReflectiveTactics.solve_post_reifie 0.4% 21.0% 1 1.504s + │ │ ├─UnifyAbstractReflexivity.unify_tr 13.8% 16.4% 8 0.268s + │ │ │└unify (constr) (constr) --------- 2.1% 2.1% 6 0.048s + │ │ └─ReflectiveTactics.unify_abstract_ 3.1% 4.1% 1 0.292s + │ └─ReflectiveTactics.do_reify -------- 0.1% 13.8% 1 0.988s + │ â””Reify.Reify_rhs_gen --------------- 0.8% 13.6% 1 0.972s + │ â””Reify.do_reify_abs_goal ----------- 6.9% 7.0% 2 0.500s + │ â””Reify.do_reifyf_goal -------------- 6.3% 6.5% 62 0.460s + └─Glue.refine_to_reflective_glue' ----- 0.0% 5.0% 1 0.356s + â””Glue.zrange_to_reflective ----------- 0.0% 3.4% 1 0.244s + â””Glue.zrange_to_reflective_goal ------ 2.1% 2.7% 1 0.196s + +Finished transaction in 8.918 secs (8.116u,0.004s) (successful) +Closed under the global context +total time: 7.168s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 59.8% 1 4.284s +─IntegrationTestTemporaryMiscCommon.fact 17.6% 49.1% 1 3.516s +─Pipeline.refine_reflectively_gen ------ 0.0% 40.2% 1 2.884s +─ReflectiveTactics.do_reflective_pipelin 0.0% 35.3% 1 2.528s +─ReflectiveTactics.solve_side_conditions 0.0% 34.8% 1 2.492s +─reflexivity --------------------------- 23.8% 23.8% 8 1.660s +─ReflectiveTactics.solve_post_reified_si 0.4% 21.0% 1 1.504s +─UnifyAbstractReflexivity.unify_transfor 13.8% 16.4% 8 0.268s +─ReflectiveTactics.do_reify ------------ 0.1% 13.8% 1 0.988s +─Reify.Reify_rhs_gen ------------------- 0.8% 13.6% 1 0.972s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 9.5% 1 0.680s +─rewrite <- (ZRange.is_bounded_by_None_r 8.7% 8.7% 4 0.332s +─rewrite <- (lem : lemT) by by_tac ltac: 0.1% 7.3% 1 0.520s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 7.3% 1 0.520s +─op_sig_side_conditions_t -------------- 0.0% 7.2% 1 0.516s +─by_tac -------------------------------- 0.0% 7.1% 2 0.412s +─Reify.do_reify_abs_goal --------------- 6.9% 7.0% 2 0.500s +─Reify.do_reifyf_goal ------------------ 6.3% 6.5% 62 0.460s +─DestructHyps.do_one_match_then -------- 0.3% 5.4% 14 0.044s +─DestructHyps.do_all_matches_then ------ 0.0% 5.4% 4 0.116s +─do_tac -------------------------------- 0.0% 5.1% 13 0.044s +─destruct H ---------------------------- 5.1% 5.1% 10 0.044s +─Glue.refine_to_reflective_glue' ------- 0.0% 5.0% 1 0.356s +─ReflectiveTactics.unify_abstract_cbv_in 3.1% 4.1% 1 0.292s +─Glue.zrange_to_reflective ------------- 0.0% 3.4% 1 0.244s +─unify (constr) (constr) --------------- 3.1% 3.1% 8 0.072s +─Glue.zrange_to_reflective_goal -------- 2.1% 2.7% 1 0.196s +─IntegrationTestTemporaryMiscCommon.do_s 0.0% 2.2% 1 0.160s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.3% 2.2% 3 0.152s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 59.8% 1 4.284s + ├─IntegrationTestTemporaryMiscCommon.fa 17.6% 49.1% 1 3.516s + │ ├─reflexivity ----------------------- 23.2% 23.2% 1 1.660s + │ └─op_sig_side_conditions_t ---------- 0.0% 7.2% 1 0.516s + │ ├─rewrite <- (ZRange.is_bounded_by_ 3.9% 3.9% 2 0.272s + │ └─DestructHyps.do_all_matches_then 0.0% 3.2% 2 0.116s + │ â””DestructHyps.do_one_match_then -- 0.2% 3.2% 8 0.044s + │ â””do_tac -------------------------- 0.0% 3.0% 6 0.040s + │ â””destruct H ---------------------- 3.0% 3.0% 6 0.040s + └─IntegrationTestTemporaryMiscCommon.do 0.0% 9.5% 1 0.680s + ├─IntegrationTestTemporaryMiscCommon. 0.0% 7.3% 1 0.520s + │└rewrite <- (lem : lemT) by by_tac l 0.1% 7.3% 1 0.520s + │└by_tac ---------------------------- 0.0% 7.1% 2 0.412s + │ ├─rewrite <- (ZRange.is_bounded_by_ 4.8% 4.8% 2 0.332s + │ └─DestructHyps.do_all_matches_then 0.0% 2.2% 2 0.080s + │ â””DestructHyps.do_one_match_then -- 0.1% 2.2% 6 0.044s + │ â””do_tac -------------------------- 0.0% 2.2% 4 0.044s + │ â””destruct H ---------------------- 2.2% 2.2% 4 0.044s + └─IntegrationTestTemporaryMiscCommon. 0.0% 2.2% 1 0.160s + â””<Crypto.Util.Tactics.MoveLetIn.with 0.3% 2.2% 3 0.152s +─Pipeline.refine_reflectively_gen ------ 0.0% 40.2% 1 2.884s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 35.3% 1 2.528s + │└ReflectiveTactics.solve_side_conditio 0.0% 34.8% 1 2.492s + │ ├─ReflectiveTactics.solve_post_reifie 0.4% 21.0% 1 1.504s + │ │ ├─UnifyAbstractReflexivity.unify_tr 13.8% 16.4% 8 0.268s + │ │ │└unify (constr) (constr) --------- 2.1% 2.1% 6 0.048s + │ │ └─ReflectiveTactics.unify_abstract_ 3.1% 4.1% 1 0.292s + │ └─ReflectiveTactics.do_reify -------- 0.1% 13.8% 1 0.988s + │ â””Reify.Reify_rhs_gen --------------- 0.8% 13.6% 1 0.972s + │ â””Reify.do_reify_abs_goal ----------- 6.9% 7.0% 2 0.500s + │ â””Reify.do_reifyf_goal -------------- 6.3% 6.5% 62 0.460s + └─Glue.refine_to_reflective_glue' ----- 0.0% 5.0% 1 0.356s + â””Glue.zrange_to_reflective ----------- 0.0% 3.4% 1 0.244s + â””Glue.zrange_to_reflective_goal ------ 2.1% 2.7% 1 0.196s + +src/Specific/NISTP256/AMD64/feopp (real: 32.08, user: 29.46, sys: 0.25, mem: 765212 ko) +COQC src/Specific/NISTP256/AMD64/fesub.v +Finished transaction in 12.83 secs (11.988u,0.019s) (successful) +total time: 11.956s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 63.2% 1 7.560s +─IntegrationTestTemporaryMiscCommon.fact 15.6% 48.5% 1 5.796s +─Pipeline.refine_reflectively_gen ------ 0.0% 36.8% 1 4.396s +─ReflectiveTactics.do_reflective_pipelin 0.0% 31.0% 1 3.712s +─ReflectiveTactics.solve_side_conditions 0.0% 30.6% 1 3.656s +─reflexivity --------------------------- 20.3% 20.3% 8 2.312s +─ReflectiveTactics.solve_post_reified_si 0.5% 17.3% 1 2.064s +─UnifyAbstractReflexivity.unify_transfor 11.8% 13.9% 8 0.452s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 13.7% 1 1.636s +─ReflectiveTactics.do_reify ------------ 0.0% 13.3% 1 1.592s +─Reify.Reify_rhs_gen ------------------- 0.9% 12.8% 1 1.536s +─DestructHyps.do_all_matches_then ------ 0.1% 12.6% 8 0.224s +─DestructHyps.do_one_match_then -------- 0.5% 12.5% 44 0.056s +─op_sig_side_conditions_t -------------- 0.0% 12.2% 1 1.456s +─do_tac -------------------------------- 0.0% 12.0% 43 0.052s +─destruct H ---------------------------- 11.9% 11.9% 36 0.052s +─rewrite <- (lem : lemT) by by_tac ltac: 0.2% 11.1% 1 1.324s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 11.1% 1 1.324s +─by_tac -------------------------------- 0.0% 10.9% 4 0.488s +─rewrite <- (ZRange.is_bounded_by_None_r 10.1% 10.2% 8 0.328s +─Reify.do_reify_abs_goal --------------- 6.0% 6.1% 2 0.724s +─Glue.refine_to_reflective_glue' ------- 0.0% 5.7% 1 0.680s +─Reify.do_reifyf_goal ------------------ 5.5% 5.6% 80 0.660s +─Glue.zrange_to_reflective ------------- 0.0% 3.6% 1 0.432s +─ReflectiveTactics.unify_abstract_cbv_in 2.0% 2.8% 1 0.340s +─Glue.zrange_to_reflective_goal -------- 1.7% 2.7% 1 0.324s +─IntegrationTestTemporaryMiscCommon.do_s 0.0% 2.6% 1 0.312s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.5% 2.5% 3 0.300s +─unify (constr) (constr) --------------- 2.4% 2.4% 9 0.100s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 63.2% 1 7.560s + ├─IntegrationTestTemporaryMiscCommon.fa 15.6% 48.5% 1 5.796s + │ ├─reflexivity ----------------------- 19.3% 19.3% 1 2.312s + │ └─op_sig_side_conditions_t ---------- 0.0% 12.2% 1 1.456s + │ ├─DestructHyps.do_all_matches_then 0.1% 7.1% 4 0.224s + │ │└DestructHyps.do_one_match_then -- 0.3% 7.1% 24 0.056s + │ │└do_tac -------------------------- 0.0% 6.7% 20 0.052s + │ │└destruct H ---------------------- 6.7% 6.7% 20 0.052s + │ └─rewrite <- (ZRange.is_bounded_by_ 4.9% 4.9% 4 0.292s + └─IntegrationTestTemporaryMiscCommon.do 0.0% 13.7% 1 1.636s + ├─IntegrationTestTemporaryMiscCommon. 0.0% 11.1% 1 1.324s + │└rewrite <- (lem : lemT) by by_tac l 0.2% 11.1% 1 1.324s + │└by_tac ---------------------------- 0.0% 10.9% 4 0.488s + │ ├─DestructHyps.do_all_matches_then 0.0% 5.5% 4 0.176s + │ │└DestructHyps.do_one_match_then -- 0.2% 5.5% 20 0.048s + │ │└do_tac -------------------------- 0.0% 5.3% 16 0.048s + │ │└destruct H ---------------------- 5.2% 5.2% 16 0.048s + │ └─rewrite <- (ZRange.is_bounded_by_ 5.3% 5.3% 4 0.328s + └─IntegrationTestTemporaryMiscCommon. 0.0% 2.6% 1 0.312s + â””<Crypto.Util.Tactics.MoveLetIn.with 0.5% 2.5% 3 0.300s +─Pipeline.refine_reflectively_gen ------ 0.0% 36.8% 1 4.396s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 31.0% 1 3.712s + │└ReflectiveTactics.solve_side_conditio 0.0% 30.6% 1 3.656s + │ ├─ReflectiveTactics.solve_post_reifie 0.5% 17.3% 1 2.064s + │ │ ├─UnifyAbstractReflexivity.unify_tr 11.8% 13.9% 8 0.452s + │ │ └─ReflectiveTactics.unify_abstract_ 2.0% 2.8% 1 0.340s + │ └─ReflectiveTactics.do_reify -------- 0.0% 13.3% 1 1.592s + │ â””Reify.Reify_rhs_gen --------------- 0.9% 12.8% 1 1.536s + │ â””Reify.do_reify_abs_goal ----------- 6.0% 6.1% 2 0.724s + │ â””Reify.do_reifyf_goal -------------- 5.5% 5.6% 80 0.660s + └─Glue.refine_to_reflective_glue' ----- 0.0% 5.7% 1 0.680s + â””Glue.zrange_to_reflective ----------- 0.0% 3.6% 1 0.432s + â””Glue.zrange_to_reflective_goal ------ 1.7% 2.7% 1 0.324s + +Finished transaction in 14.576 secs (13.372u,0.004s) (successful) +Closed under the global context +total time: 11.956s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 63.2% 1 7.560s +─IntegrationTestTemporaryMiscCommon.fact 15.6% 48.5% 1 5.796s +─Pipeline.refine_reflectively_gen ------ 0.0% 36.8% 1 4.396s +─ReflectiveTactics.do_reflective_pipelin 0.0% 31.0% 1 3.712s +─ReflectiveTactics.solve_side_conditions 0.0% 30.6% 1 3.656s +─reflexivity --------------------------- 20.3% 20.3% 8 2.312s +─ReflectiveTactics.solve_post_reified_si 0.5% 17.3% 1 2.064s +─UnifyAbstractReflexivity.unify_transfor 11.8% 13.9% 8 0.452s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 13.7% 1 1.636s +─ReflectiveTactics.do_reify ------------ 0.0% 13.3% 1 1.592s +─Reify.Reify_rhs_gen ------------------- 0.9% 12.8% 1 1.536s +─DestructHyps.do_all_matches_then ------ 0.1% 12.6% 8 0.224s +─DestructHyps.do_one_match_then -------- 0.5% 12.5% 44 0.056s +─op_sig_side_conditions_t -------------- 0.0% 12.2% 1 1.456s +─do_tac -------------------------------- 0.0% 12.0% 43 0.052s +─destruct H ---------------------------- 11.9% 11.9% 36 0.052s +─rewrite <- (lem : lemT) by by_tac ltac: 0.2% 11.1% 1 1.324s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 11.1% 1 1.324s +─by_tac -------------------------------- 0.0% 10.9% 4 0.488s +─rewrite <- (ZRange.is_bounded_by_None_r 10.1% 10.2% 8 0.328s +─Reify.do_reify_abs_goal --------------- 6.0% 6.1% 2 0.724s +─Glue.refine_to_reflective_glue' ------- 0.0% 5.7% 1 0.680s +─Reify.do_reifyf_goal ------------------ 5.5% 5.6% 80 0.660s +─Glue.zrange_to_reflective ------------- 0.0% 3.6% 1 0.432s +─ReflectiveTactics.unify_abstract_cbv_in 2.0% 2.8% 1 0.340s +─Glue.zrange_to_reflective_goal -------- 1.7% 2.7% 1 0.324s +─IntegrationTestTemporaryMiscCommon.do_s 0.0% 2.6% 1 0.312s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.5% 2.5% 3 0.300s +─unify (constr) (constr) --------------- 2.4% 2.4% 9 0.100s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 63.2% 1 7.560s + ├─IntegrationTestTemporaryMiscCommon.fa 15.6% 48.5% 1 5.796s + │ ├─reflexivity ----------------------- 19.3% 19.3% 1 2.312s + │ └─op_sig_side_conditions_t ---------- 0.0% 12.2% 1 1.456s + │ ├─DestructHyps.do_all_matches_then 0.1% 7.1% 4 0.224s + │ │└DestructHyps.do_one_match_then -- 0.3% 7.1% 24 0.056s + │ │└do_tac -------------------------- 0.0% 6.7% 20 0.052s + │ │└destruct H ---------------------- 6.7% 6.7% 20 0.052s + │ └─rewrite <- (ZRange.is_bounded_by_ 4.9% 4.9% 4 0.292s + └─IntegrationTestTemporaryMiscCommon.do 0.0% 13.7% 1 1.636s + ├─IntegrationTestTemporaryMiscCommon. 0.0% 11.1% 1 1.324s + │└rewrite <- (lem : lemT) by by_tac l 0.2% 11.1% 1 1.324s + │└by_tac ---------------------------- 0.0% 10.9% 4 0.488s + │ ├─DestructHyps.do_all_matches_then 0.0% 5.5% 4 0.176s + │ │└DestructHyps.do_one_match_then -- 0.2% 5.5% 20 0.048s + │ │└do_tac -------------------------- 0.0% 5.3% 16 0.048s + │ │└destruct H ---------------------- 5.2% 5.2% 16 0.048s + │ └─rewrite <- (ZRange.is_bounded_by_ 5.3% 5.3% 4 0.328s + └─IntegrationTestTemporaryMiscCommon. 0.0% 2.6% 1 0.312s + â””<Crypto.Util.Tactics.MoveLetIn.with 0.5% 2.5% 3 0.300s +─Pipeline.refine_reflectively_gen ------ 0.0% 36.8% 1 4.396s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 31.0% 1 3.712s + │└ReflectiveTactics.solve_side_conditio 0.0% 30.6% 1 3.656s + │ ├─ReflectiveTactics.solve_post_reifie 0.5% 17.3% 1 2.064s + │ │ ├─UnifyAbstractReflexivity.unify_tr 11.8% 13.9% 8 0.452s + │ │ └─ReflectiveTactics.unify_abstract_ 2.0% 2.8% 1 0.340s + │ └─ReflectiveTactics.do_reify -------- 0.0% 13.3% 1 1.592s + │ â””Reify.Reify_rhs_gen --------------- 0.9% 12.8% 1 1.536s + │ â””Reify.do_reify_abs_goal ----------- 6.0% 6.1% 2 0.724s + │ â””Reify.do_reifyf_goal -------------- 5.5% 5.6% 80 0.660s + └─Glue.refine_to_reflective_glue' ----- 0.0% 5.7% 1 0.680s + â””Glue.zrange_to_reflective ----------- 0.0% 3.6% 1 0.432s + â””Glue.zrange_to_reflective_goal ------ 1.7% 2.7% 1 0.324s + +src/Specific/NISTP256/AMD64/fesub (real: 43.78, user: 40.09, sys: 0.30, mem: 799668 ko) +COQC src/Specific/NISTP256/AMD64/feaddDisplay > src/Specific/NISTP256/AMD64/feaddDisplay.log +COQC src/Specific/NISTP256/AMD64/fenzDisplay > src/Specific/NISTP256/AMD64/fenzDisplay.log +COQC src/Specific/NISTP256/AMD64/feoppDisplay > src/Specific/NISTP256/AMD64/feoppDisplay.log +COQC src/Specific/NISTP256/AMD64/fesubDisplay > src/Specific/NISTP256/AMD64/fesubDisplay.log +COQC src/Specific/X25519/C64/fesquareDisplay > src/Specific/X25519/C64/fesquareDisplay.log +COQC src/Specific/solinas32_2e255m765_12limbs/femul.v +Finished transaction in 60.265 secs (55.388u,0.103s) (successful) +total time: 55.440s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 95.9% 1 53.156s +─ReflectiveTactics.do_reflective_pipelin 0.0% 89.2% 1 49.464s +─ReflectiveTactics.solve_side_conditions 0.0% 88.9% 1 49.288s +─ReflectiveTactics.do_reify ------------ -0.0% 49.9% 1 27.684s +─Reify.Reify_rhs_gen ------------------- 1.3% 49.3% 1 27.348s +─ReflectiveTactics.solve_post_reified_si 0.1% 39.0% 1 21.604s +─Reify.do_reify_abs_goal --------------- 36.3% 36.6% 2 20.272s +─UnifyAbstractReflexivity.unify_transfor 30.8% 36.1% 8 8.636s +─Reify.do_reifyf_goal ------------------ 35.7% 35.9% 108 10.356s +─eexact -------------------------------- 11.5% 11.5% 110 0.128s +─Glue.refine_to_reflective_glue' ------- 0.0% 6.7% 1 3.692s +─Glue.zrange_to_reflective ------------- 0.0% 6.2% 1 3.424s +─unify (constr) (constr) --------------- 4.9% 4.9% 7 1.140s +─Glue.zrange_to_reflective_goal -------- 1.4% 4.7% 1 2.592s +─synthesize ---------------------------- 0.0% 4.1% 1 2.284s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 4.0% 1 2.220s +─change G' ----------------------------- 3.9% 3.9% 1 2.148s +─pose proof (pf : Interpretation.Bo 3.1% 3.1% 1 1.736s +─rewrite H ----------------------------- 3.1% 3.1% 1 1.692s +─prove_interp_compile_correct ---------- 0.0% 3.0% 1 1.636s +─rewrite ?EtaInterp.InterpExprEta ------ 2.7% 2.7% 1 1.484s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 95.9% 1 53.156s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 89.2% 1 49.464s + │└ReflectiveTactics.solve_side_conditio 0.0% 88.9% 1 49.288s + │ ├─ReflectiveTactics.do_reify -------- -0.0% 49.9% 1 27.684s + │ │└Reify.Reify_rhs_gen --------------- 1.3% 49.3% 1 27.348s + │ │ ├─Reify.do_reify_abs_goal --------- 36.3% 36.6% 2 20.272s + │ │ │└Reify.do_reifyf_goal ------------ 35.7% 35.9% 108 10.356s + │ │ │└eexact -------------------------- 11.1% 11.1% 108 0.072s + │ │ ├─rewrite H ----------------------- 3.1% 3.1% 1 1.692s + │ │ └─prove_interp_compile_correct ---- 0.0% 3.0% 1 1.636s + │ │ â””rewrite ?EtaInterp.InterpExprEta 2.7% 2.7% 1 1.484s + │ └─ReflectiveTactics.solve_post_reifie 0.1% 39.0% 1 21.604s + │ â””UnifyAbstractReflexivity.unify_tran 30.8% 36.1% 8 8.636s + │ â””unify (constr) (constr) ----------- 4.4% 4.4% 6 1.140s + └─Glue.refine_to_reflective_glue' ----- 0.0% 6.7% 1 3.692s + â””Glue.zrange_to_reflective ----------- 0.0% 6.2% 1 3.424s + â””Glue.zrange_to_reflective_goal ------ 1.4% 4.7% 1 2.592s + â””pose proof (pf : Interpretation. 3.1% 3.1% 1 1.736s +─synthesize ---------------------------- 0.0% 4.1% 1 2.284s +â””IntegrationTestTemporaryMiscCommon.do_r 0.0% 4.0% 1 2.220s +â””change G' ----------------------------- 3.9% 3.9% 1 2.148s + +Finished transaction in 92.046 secs (84.315u,0.032s) (successful) +Closed under the global context +total time: 55.440s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 95.9% 1 53.156s +─ReflectiveTactics.do_reflective_pipelin 0.0% 89.2% 1 49.464s +─ReflectiveTactics.solve_side_conditions 0.0% 88.9% 1 49.288s +─ReflectiveTactics.do_reify ------------ -0.0% 49.9% 1 27.684s +─Reify.Reify_rhs_gen ------------------- 1.3% 49.3% 1 27.348s +─ReflectiveTactics.solve_post_reified_si 0.1% 39.0% 1 21.604s +─Reify.do_reify_abs_goal --------------- 36.3% 36.6% 2 20.272s +─UnifyAbstractReflexivity.unify_transfor 30.8% 36.1% 8 8.636s +─Reify.do_reifyf_goal ------------------ 35.7% 35.9% 108 10.356s +─eexact -------------------------------- 11.5% 11.5% 110 0.128s +─Glue.refine_to_reflective_glue' ------- 0.0% 6.7% 1 3.692s +─Glue.zrange_to_reflective ------------- 0.0% 6.2% 1 3.424s +─unify (constr) (constr) --------------- 4.9% 4.9% 7 1.140s +─Glue.zrange_to_reflective_goal -------- 1.4% 4.7% 1 2.592s +─synthesize ---------------------------- 0.0% 4.1% 1 2.284s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 4.0% 1 2.220s +─change G' ----------------------------- 3.9% 3.9% 1 2.148s +─pose proof (pf : Interpretation.Bo 3.1% 3.1% 1 1.736s +─rewrite H ----------------------------- 3.1% 3.1% 1 1.692s +─prove_interp_compile_correct ---------- 0.0% 3.0% 1 1.636s +─rewrite ?EtaInterp.InterpExprEta ------ 2.7% 2.7% 1 1.484s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 95.9% 1 53.156s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 89.2% 1 49.464s + │└ReflectiveTactics.solve_side_conditio 0.0% 88.9% 1 49.288s + │ ├─ReflectiveTactics.do_reify -------- -0.0% 49.9% 1 27.684s + │ │└Reify.Reify_rhs_gen --------------- 1.3% 49.3% 1 27.348s + │ │ ├─Reify.do_reify_abs_goal --------- 36.3% 36.6% 2 20.272s + │ │ │└Reify.do_reifyf_goal ------------ 35.7% 35.9% 108 10.356s + │ │ │└eexact -------------------------- 11.1% 11.1% 108 0.072s + │ │ ├─rewrite H ----------------------- 3.1% 3.1% 1 1.692s + │ │ └─prove_interp_compile_correct ---- 0.0% 3.0% 1 1.636s + │ │ â””rewrite ?EtaInterp.InterpExprEta 2.7% 2.7% 1 1.484s + │ └─ReflectiveTactics.solve_post_reifie 0.1% 39.0% 1 21.604s + │ â””UnifyAbstractReflexivity.unify_tran 30.8% 36.1% 8 8.636s + │ â””unify (constr) (constr) ----------- 4.4% 4.4% 6 1.140s + └─Glue.refine_to_reflective_glue' ----- 0.0% 6.7% 1 3.692s + â””Glue.zrange_to_reflective ----------- 0.0% 6.2% 1 3.424s + â””Glue.zrange_to_reflective_goal ------ 1.4% 4.7% 1 2.592s + â””pose proof (pf : Interpretation. 3.1% 3.1% 1 1.736s +─synthesize ---------------------------- 0.0% 4.1% 1 2.284s +â””IntegrationTestTemporaryMiscCommon.do_r 0.0% 4.0% 1 2.220s +â””change G' ----------------------------- 3.9% 3.9% 1 2.148s + +src/Specific/solinas32_2e255m765_12limbs/femul (real: 179.21, user: 164.11, sys: 0.42, mem: 1549104 ko) +COQC src/Specific/X25519/C64/fesubDisplay > src/Specific/X25519/C64/fesubDisplay.log +COQC src/Specific/X25519/C64/freezeDisplay > src/Specific/X25519/C64/freezeDisplay.log +COQC src/Specific/solinas32_2e255m765_13limbs/femul.v +Finished transaction in 74.548 secs (68.928u,0.079s) (successful) +total time: 68.948s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 95.7% 1 65.956s +─ReflectiveTactics.do_reflective_pipelin 0.0% 88.7% 1 61.172s +─ReflectiveTactics.solve_side_conditions 0.0% 88.4% 1 60.944s +─ReflectiveTactics.do_reify ------------ 0.0% 48.5% 1 33.408s +─Reify.Reify_rhs_gen ------------------- 1.3% 47.9% 1 33.020s +─ReflectiveTactics.solve_post_reified_si 0.1% 39.9% 1 27.536s +─UnifyAbstractReflexivity.unify_transfor 32.0% 37.2% 8 11.528s +─Reify.do_reify_abs_goal --------------- 36.0% 36.2% 2 24.960s +─Reify.do_reifyf_goal ------------------ 35.3% 35.5% 117 12.840s +─eexact -------------------------------- 11.4% 11.4% 119 0.160s +─Glue.refine_to_reflective_glue' ------- 0.0% 6.9% 1 4.784s +─Glue.zrange_to_reflective ------------- 0.0% 6.5% 1 4.512s +─Glue.zrange_to_reflective_goal -------- 1.3% 4.9% 1 3.396s +─unify (constr) (constr) --------------- 4.9% 4.9% 7 1.524s +─synthesize ---------------------------- 0.0% 4.3% 1 2.992s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 4.2% 1 2.912s +─change G' ----------------------------- 4.1% 4.1% 1 2.840s +─pose proof (pf : Interpretation.Bo 3.5% 3.5% 1 2.420s +─rewrite H ----------------------------- 3.0% 3.0% 1 2.084s +─prove_interp_compile_correct ---------- 0.0% 2.7% 1 1.856s +─rewrite ?EtaInterp.InterpExprEta ------ 2.5% 2.5% 1 1.692s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 95.7% 1 65.956s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 88.7% 1 61.172s + │└ReflectiveTactics.solve_side_conditio 0.0% 88.4% 1 60.944s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 48.5% 1 33.408s + │ │└Reify.Reify_rhs_gen --------------- 1.3% 47.9% 1 33.020s + │ │ ├─Reify.do_reify_abs_goal --------- 36.0% 36.2% 2 24.960s + │ │ │└Reify.do_reifyf_goal ------------ 35.3% 35.5% 117 12.840s + │ │ │└eexact -------------------------- 10.9% 10.9% 117 0.088s + │ │ ├─rewrite H ----------------------- 3.0% 3.0% 1 2.084s + │ │ └─prove_interp_compile_correct ---- 0.0% 2.7% 1 1.856s + │ │ â””rewrite ?EtaInterp.InterpExprEta 2.5% 2.5% 1 1.692s + │ └─ReflectiveTactics.solve_post_reifie 0.1% 39.9% 1 27.536s + │ â””UnifyAbstractReflexivity.unify_tran 32.0% 37.2% 8 11.528s + │ â””unify (constr) (constr) ----------- 4.3% 4.3% 6 1.524s + └─Glue.refine_to_reflective_glue' ----- 0.0% 6.9% 1 4.784s + â””Glue.zrange_to_reflective ----------- 0.0% 6.5% 1 4.512s + â””Glue.zrange_to_reflective_goal ------ 1.3% 4.9% 1 3.396s + â””pose proof (pf : Interpretation. 3.5% 3.5% 1 2.420s +─synthesize ---------------------------- 0.0% 4.3% 1 2.992s +â””IntegrationTestTemporaryMiscCommon.do_r 0.0% 4.2% 1 2.912s +â””change G' ----------------------------- 4.1% 4.1% 1 2.840s + +Finished transaction in 105.62 secs (97.6u,0.02s) (successful) +Closed under the global context +total time: 68.948s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 95.7% 1 65.956s +─ReflectiveTactics.do_reflective_pipelin 0.0% 88.7% 1 61.172s +─ReflectiveTactics.solve_side_conditions 0.0% 88.4% 1 60.944s +─ReflectiveTactics.do_reify ------------ 0.0% 48.5% 1 33.408s +─Reify.Reify_rhs_gen ------------------- 1.3% 47.9% 1 33.020s +─ReflectiveTactics.solve_post_reified_si 0.1% 39.9% 1 27.536s +─UnifyAbstractReflexivity.unify_transfor 32.0% 37.2% 8 11.528s +─Reify.do_reify_abs_goal --------------- 36.0% 36.2% 2 24.960s +─Reify.do_reifyf_goal ------------------ 35.3% 35.5% 117 12.840s +─eexact -------------------------------- 11.4% 11.4% 119 0.160s +─Glue.refine_to_reflective_glue' ------- 0.0% 6.9% 1 4.784s +─Glue.zrange_to_reflective ------------- 0.0% 6.5% 1 4.512s +─Glue.zrange_to_reflective_goal -------- 1.3% 4.9% 1 3.396s +─unify (constr) (constr) --------------- 4.9% 4.9% 7 1.524s +─synthesize ---------------------------- 0.0% 4.3% 1 2.992s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 4.2% 1 2.912s +─change G' ----------------------------- 4.1% 4.1% 1 2.840s +─pose proof (pf : Interpretation.Bo 3.5% 3.5% 1 2.420s +─rewrite H ----------------------------- 3.0% 3.0% 1 2.084s +─prove_interp_compile_correct ---------- 0.0% 2.7% 1 1.856s +─rewrite ?EtaInterp.InterpExprEta ------ 2.5% 2.5% 1 1.692s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 95.7% 1 65.956s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 88.7% 1 61.172s + │└ReflectiveTactics.solve_side_conditio 0.0% 88.4% 1 60.944s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 48.5% 1 33.408s + │ │└Reify.Reify_rhs_gen --------------- 1.3% 47.9% 1 33.020s + │ │ ├─Reify.do_reify_abs_goal --------- 36.0% 36.2% 2 24.960s + │ │ │└Reify.do_reifyf_goal ------------ 35.3% 35.5% 117 12.840s + │ │ │└eexact -------------------------- 10.9% 10.9% 117 0.088s + │ │ ├─rewrite H ----------------------- 3.0% 3.0% 1 2.084s + │ │ └─prove_interp_compile_correct ---- 0.0% 2.7% 1 1.856s + │ │ â””rewrite ?EtaInterp.InterpExprEta 2.5% 2.5% 1 1.692s + │ └─ReflectiveTactics.solve_post_reifie 0.1% 39.9% 1 27.536s + │ â””UnifyAbstractReflexivity.unify_tran 32.0% 37.2% 8 11.528s + │ â””unify (constr) (constr) ----------- 4.3% 4.3% 6 1.524s + └─Glue.refine_to_reflective_glue' ----- 0.0% 6.9% 1 4.784s + â””Glue.zrange_to_reflective ----------- 0.0% 6.5% 1 4.512s + â””Glue.zrange_to_reflective_goal ------ 1.3% 4.9% 1 3.396s + â””pose proof (pf : Interpretation. 3.5% 3.5% 1 2.420s +─synthesize ---------------------------- 0.0% 4.3% 1 2.992s +â””IntegrationTestTemporaryMiscCommon.do_r 0.0% 4.2% 1 2.912s +â””change G' ----------------------------- 4.1% 4.1% 1 2.840s + +src/Specific/solinas32_2e255m765_13limbs/femul (real: 207.94, user: 192.95, sys: 0.48, mem: 1656912 ko) +COQC src/Specific/NISTP256/AMD64/femul.v +Finished transaction in 122.29 secs (111.972u,0.239s) (successful) +total time: 112.164s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.1% 1 108.944s +─ReflectiveTactics.do_reflective_pipelin -0.0% 96.5% 1 108.236s +─ReflectiveTactics.solve_side_conditions 0.0% 96.3% 1 108.000s +─ReflectiveTactics.do_reify ------------ 0.0% 81.8% 1 91.740s +─Reify.Reify_rhs_gen ------------------- 0.7% 81.6% 1 91.504s +─Reify.do_reify_abs_goal --------------- 75.6% 75.7% 2 84.892s +─Reify.do_reifyf_goal ------------------ 75.2% 75.4% 901 84.532s +─eexact -------------------------------- 17.1% 17.1% 903 0.140s +─ReflectiveTactics.solve_post_reified_si 0.2% 14.5% 1 16.260s +─UnifyAbstractReflexivity.unify_transfor 11.7% 13.3% 8 3.152s +─synthesize_montgomery ----------------- 0.0% 2.9% 1 3.220s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.1% 1 108.944s +â””ReflectiveTactics.do_reflective_pipelin -0.0% 96.5% 1 108.236s +â””ReflectiveTactics.solve_side_conditions 0.0% 96.3% 1 108.000s + ├─ReflectiveTactics.do_reify ---------- 0.0% 81.8% 1 91.740s + │└Reify.Reify_rhs_gen ----------------- 0.7% 81.6% 1 91.504s + │└Reify.do_reify_abs_goal ------------- 75.6% 75.7% 2 84.892s + │└Reify.do_reifyf_goal ---------------- 75.2% 75.4% 901 84.532s + │└eexact ------------------------------ 16.9% 16.9% 901 0.140s + └─ReflectiveTactics.solve_post_reified_ 0.2% 14.5% 1 16.260s + └UnifyAbstractReflexivity.unify_transf 11.7% 13.3% 8 3.152s +─synthesize_montgomery ----------------- 0.0% 2.9% 1 3.220s + +Finished transaction in 72.408 secs (68.432u,0.064s) (successful) +Closed under the global context +total time: 112.164s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.1% 1 108.944s +─ReflectiveTactics.do_reflective_pipelin -0.0% 96.5% 1 108.236s +─ReflectiveTactics.solve_side_conditions 0.0% 96.3% 1 108.000s +─ReflectiveTactics.do_reify ------------ 0.0% 81.8% 1 91.740s +─Reify.Reify_rhs_gen ------------------- 0.7% 81.6% 1 91.504s +─Reify.do_reify_abs_goal --------------- 75.6% 75.7% 2 84.892s +─Reify.do_reifyf_goal ------------------ 75.2% 75.4% 901 84.532s +─eexact -------------------------------- 17.1% 17.1% 903 0.140s +─ReflectiveTactics.solve_post_reified_si 0.2% 14.5% 1 16.260s +─UnifyAbstractReflexivity.unify_transfor 11.7% 13.3% 8 3.152s +─synthesize_montgomery ----------------- 0.0% 2.9% 1 3.220s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.1% 1 108.944s +└ReflectiveTactics.do_reflective_pipelin -0.0% 96.5% 1 108.236s +└ReflectiveTactics.solve_side_conditions 0.0% 96.3% 1 108.000s + ├─ReflectiveTactics.do_reify ---------- 0.0% 81.8% 1 91.740s + │└Reify.Reify_rhs_gen ----------------- 0.7% 81.6% 1 91.504s + │└Reify.do_reify_abs_goal ------------- 75.6% 75.7% 2 84.892s + │└Reify.do_reifyf_goal ---------------- 75.2% 75.4% 901 84.532s + │└eexact ------------------------------ 16.9% 16.9% 901 0.140s + └─ReflectiveTactics.solve_post_reified_ 0.2% 14.5% 1 16.260s + └UnifyAbstractReflexivity.unify_transf 11.7% 13.3% 8 3.152s +─synthesize_montgomery ----------------- 0.0% 2.9% 1 3.220s + +src/Specific/NISTP256/AMD64/femul (real: 217.80, user: 202.52, sys: 0.53, mem: 3307052 ko) +COQC src/Specific/NISTP256/AMD64/femulDisplay > src/Specific/NISTP256/AMD64/femulDisplay.log +COQC src/Specific/X25519/C64/ladderstep.v +total time: 82.012s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_xzladderstep --------------- 0.0% 100.0% 1 82.012s +─Pipeline.refine_reflectively_gen ------ 0.0% 99.0% 1 81.228s +─ReflectiveTactics.do_reflective_pipelin 0.0% 96.1% 1 78.784s +─ReflectiveTactics.solve_side_conditions 0.0% 95.9% 1 78.684s +─ReflectiveTactics.solve_post_reified_si 0.1% 72.6% 1 59.540s +─UnifyAbstractReflexivity.unify_transfor 64.6% 68.0% 8 30.740s +─ReflectiveTactics.do_reify ------------ 0.0% 23.3% 1 19.144s +─Reify.Reify_rhs_gen ------------------- 1.2% 14.5% 1 11.860s +─Reify.do_reifyf_goal ------------------ 7.1% 7.2% 138 1.908s +─Compilers.Reify.reify_context_variables 0.0% 5.9% 1 4.828s +─rewrite H ----------------------------- 4.4% 4.4% 1 3.600s +─ReflectiveTactics.unify_abstract_cbv_in 2.9% 4.0% 1 3.288s +─Glue.refine_to_reflective_glue' ------- 0.0% 3.0% 1 2.444s +─Glue.zrange_to_reflective ------------- 0.0% 2.5% 1 2.060s +─reflexivity --------------------------- 2.3% 2.3% 11 0.816s +─Reify.transitivity_tt ----------------- 0.0% 2.1% 2 0.968s +─Glue.zrange_to_reflective_goal -------- 1.4% 2.1% 1 1.720s +─clear (var_list) ---------------------- 2.0% 2.0% 159 0.584s +─eexact -------------------------------- 2.0% 2.0% 140 0.032s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_xzladderstep --------------- 0.0% 100.0% 1 82.012s +└Pipeline.refine_reflectively_gen ------ 0.0% 99.0% 1 81.228s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 96.1% 1 78.784s + │└ReflectiveTactics.solve_side_conditio 0.0% 95.9% 1 78.684s + │ ├─ReflectiveTactics.solve_post_reifie 0.1% 72.6% 1 59.540s + │ │ ├─UnifyAbstractReflexivity.unify_tr 64.6% 68.0% 8 30.740s + │ │ └─ReflectiveTactics.unify_abstract_ 2.9% 4.0% 1 3.288s + │ └─ReflectiveTactics.do_reify -------- 0.0% 23.3% 1 19.144s + │ ├─Reify.Reify_rhs_gen ------------- 1.2% 14.5% 1 11.860s + │ │ ├─rewrite H --------------------- 4.4% 4.4% 1 3.600s + │ │ └─Reify.transitivity_tt --------- 0.0% 2.1% 2 0.968s + │ └─Compilers.Reify.reify_context_var 0.0% 5.9% 1 4.828s + │ └Reify.do_reifyf_goal ------------ 5.7% 5.8% 113 1.908s + └─Glue.refine_to_reflective_glue' ----- 0.0% 3.0% 1 2.444s + └Glue.zrange_to_reflective ----------- 0.0% 2.5% 1 2.060s + └Glue.zrange_to_reflective_goal ------ 1.4% 2.1% 1 1.720s + +Finished transaction in 194.903 secs (185.732u,0.043s) (successful) +Closed under the global context +total time: 82.012s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_xzladderstep --------------- 0.0% 100.0% 1 82.012s +─Pipeline.refine_reflectively_gen ------ 0.0% 99.0% 1 81.228s +─ReflectiveTactics.do_reflective_pipelin 0.0% 96.1% 1 78.784s +─ReflectiveTactics.solve_side_conditions 0.0% 95.9% 1 78.684s +─ReflectiveTactics.solve_post_reified_si 0.1% 72.6% 1 59.540s +─UnifyAbstractReflexivity.unify_transfor 64.6% 68.0% 8 30.740s +─ReflectiveTactics.do_reify ------------ 0.0% 23.3% 1 19.144s +─Reify.Reify_rhs_gen ------------------- 1.2% 14.5% 1 11.860s +─Reify.do_reifyf_goal ------------------ 7.1% 7.2% 138 1.908s +─Compilers.Reify.reify_context_variables 0.0% 5.9% 1 4.828s +─rewrite H ----------------------------- 4.4% 4.4% 1 3.600s +─ReflectiveTactics.unify_abstract_cbv_in 2.9% 4.0% 1 3.288s +─Glue.refine_to_reflective_glue' ------- 0.0% 3.0% 1 2.444s +─Glue.zrange_to_reflective ------------- 0.0% 2.5% 1 2.060s +─reflexivity --------------------------- 2.3% 2.3% 11 0.816s +─Reify.transitivity_tt ----------------- 0.0% 2.1% 2 0.968s +─Glue.zrange_to_reflective_goal -------- 1.4% 2.1% 1 1.720s +─clear (var_list) ---------------------- 2.0% 2.0% 159 0.584s +─eexact -------------------------------- 2.0% 2.0% 140 0.032s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_xzladderstep --------------- 0.0% 100.0% 1 82.012s +└Pipeline.refine_reflectively_gen ------ 0.0% 99.0% 1 81.228s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 96.1% 1 78.784s + │└ReflectiveTactics.solve_side_conditio 0.0% 95.9% 1 78.684s + │ ├─ReflectiveTactics.solve_post_reifie 0.1% 72.6% 1 59.540s + │ │ ├─UnifyAbstractReflexivity.unify_tr 64.6% 68.0% 8 30.740s + │ │ └─ReflectiveTactics.unify_abstract_ 2.9% 4.0% 1 3.288s + │ └─ReflectiveTactics.do_reify -------- 0.0% 23.3% 1 19.144s + │ ├─Reify.Reify_rhs_gen ------------- 1.2% 14.5% 1 11.860s + │ │ ├─rewrite H --------------------- 4.4% 4.4% 1 3.600s + │ │ └─Reify.transitivity_tt --------- 0.0% 2.1% 2 0.968s + │ └─Compilers.Reify.reify_context_var 0.0% 5.9% 1 4.828s + │ └Reify.do_reifyf_goal ------------ 5.7% 5.8% 113 1.908s + └─Glue.refine_to_reflective_glue' ----- 0.0% 3.0% 1 2.444s + └Glue.zrange_to_reflective ----------- 0.0% 2.5% 1 2.060s + └Glue.zrange_to_reflective_goal ------ 1.4% 2.1% 1 1.720s + +src/Specific/X25519/C64/ladderstep (real: 316.83, user: 299.49, sys: 0.52, mem: 1621500 ko) +COQC src/Specific/X25519/C64/ladderstepDisplay > src/Specific/X25519/C64/ladderstepDisplay.log diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both.log.expected new file mode 100644 index 0000000000..975e359b78 --- /dev/null +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/001-correct-diff-sorting-order/time-of-build-both.log.expected @@ -0,0 +1,26 @@ +After | File Name | Before || Change | % Change +---------------------------------------------------------------------------------------------- +19m16.05s | Total | 21m25.28s || -2m09.23s | -10.05% +---------------------------------------------------------------------------------------------- +4m01.34s | Specific/X25519/C64/ladderstep | 4m59.49s || -0m58.15s | -19.41% +2m48.52s | Specific/solinas32_2e255m765_13limbs/femul | 3m12.95s || -0m24.42s | -12.66% +2m23.70s | Specific/solinas32_2e255m765_12limbs/femul | 2m44.11s || -0m20.41s | -12.43% +3m09.62s | Specific/NISTP256/AMD64/femul | 3m22.52s || -0m12.90s | -6.36% +0m36.32s | Specific/X25519/C64/femul | 0m39.50s || -0m03.17s | -8.05% +0m30.13s | Specific/X25519/C64/fesquare | 0m32.24s || -0m02.11s | -6.54% +0m35.40s | Specific/NISTP256/AMD64/feadd | 0m37.21s || -0m01.81s | -4.86% +0m31.50s | Specific/X25519/C64/freeze | 0m33.24s || -0m01.74s | -5.23% +0m24.99s | Specific/X25519/C64/fecarry | 0m26.31s || -0m01.32s | -5.01% +0m22.65s | Specific/X25519/C64/fesub | 0m23.72s || -0m01.07s | -4.51% +0m45.75s | Specific/solinas32_2e255m765_13limbs/Synthesis | 0m45.58s || +0m00.17s | +0.37% +0m39.59s | Specific/NISTP256/AMD64/fesub | 0m40.09s || -0m00.50s | -1.24% +0m36.92s | Specific/solinas32_2e255m765_12limbs/Synthesis | 0m36.64s || +0m00.28s | +0.76% +0m28.51s | Specific/NISTP256/AMD64/feopp | 0m29.46s || -0m00.94s | -3.22% +0m25.50s | Specific/NISTP256/AMD64/fenz | 0m26.41s || -0m00.91s | -3.44% +0m20.93s | Specific/X25519/C64/feadd | 0m21.41s || -0m00.48s | -2.24% +0m12.55s | Specific/NISTP256/AMD64/Synthesis | 0m12.54s || +0m00.01s | +0.07% +0m10.37s | Specific/X25519/C64/Synthesis | 0m10.30s || +0m00.06s | +0.67% +0m07.18s | Compilers/Z/Bounds/Pipeline/Definition | 0m07.22s || -0m00.04s | -0.55% +0m01.72s | Compilers/Z/Bounds/Pipeline/ReflectiveTactics | 0m01.58s || +0m00.13s | +8.86% +0m01.67s | Specific/Framework/SynthesisFramework | 0m01.72s || -0m00.05s | -2.90% +0m01.19s | Compilers/Z/Bounds/Pipeline | 0m01.04s || +0m00.14s | +14.42%
\ No newline at end of file diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/002-single-file-sorting/run.sh b/test-suite/coq-makefile/timing/precomputed-time-tests/002-single-file-sorting/run.sh new file mode 100755 index 0000000000..4f39b3ce7e --- /dev/null +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/002-single-file-sorting/run.sh @@ -0,0 +1,10 @@ +#!/usr/bin/env bash + +set -x +set -e + +cd "$(dirname "${BASH_SOURCE[0]}")" + +"$COQLIB"/tools/make-one-time-file.py time-of-build.log.in time-of-build-pretty.log + +diff -u time-of-build-pretty.log.expected time-of-build-pretty.log || exit $? diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/002-single-file-sorting/time-of-build-pretty.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/002-single-file-sorting/time-of-build-pretty.log.expected new file mode 100644 index 0000000000..fdd5ec21d6 --- /dev/null +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/002-single-file-sorting/time-of-build-pretty.log.expected @@ -0,0 +1,26 @@ +Time | File Name +---------------------------------------------------------- +19m16.05s | Total +---------------------------------------------------------- +4m01.34s | Specific/X25519/C64/ladderstep +3m09.62s | Specific/NISTP256/AMD64/femul +2m48.52s | Specific/solinas32_2e255m765_13limbs/femul +2m23.70s | Specific/solinas32_2e255m765_12limbs/femul +0m45.75s | Specific/solinas32_2e255m765_13limbs/Synthesis +0m39.59s | Specific/NISTP256/AMD64/fesub +0m36.92s | Specific/solinas32_2e255m765_12limbs/Synthesis +0m36.32s | Specific/X25519/C64/femul +0m35.40s | Specific/NISTP256/AMD64/feadd +0m31.50s | Specific/X25519/C64/freeze +0m30.13s | Specific/X25519/C64/fesquare +0m28.51s | Specific/NISTP256/AMD64/feopp +0m25.50s | Specific/NISTP256/AMD64/fenz +0m24.99s | Specific/X25519/C64/fecarry +0m22.65s | Specific/X25519/C64/fesub +0m20.93s | Specific/X25519/C64/feadd +0m12.55s | Specific/NISTP256/AMD64/Synthesis +0m10.37s | Specific/X25519/C64/Synthesis +0m07.18s | Compilers/Z/Bounds/Pipeline/Definition +0m01.72s | Compilers/Z/Bounds/Pipeline/ReflectiveTactics +0m01.67s | Specific/Framework/SynthesisFramework +0m01.19s | Compilers/Z/Bounds/Pipeline
\ No newline at end of file diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/002-single-file-sorting/time-of-build.log.in b/test-suite/coq-makefile/timing/precomputed-time-tests/002-single-file-sorting/time-of-build.log.in new file mode 100644 index 0000000000..5757018e9b --- /dev/null +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/002-single-file-sorting/time-of-build.log.in @@ -0,0 +1,1760 @@ +COQDEP src/Compilers/Z/Bounds/Pipeline/ReflectiveTactics.v +COQDEP src/Compilers/Z/Bounds/Pipeline/Definition.v +/home/jgross/.local64/coq/coq-master/bin/coq_makefile -f _CoqProject INSTALLDEFAULTROOT = Crypto -o Makefile-old +COQ_MAKEFILE -f _CoqProject > Makefile.coq +make --no-print-directory -C coqprime +make[1]: Nothing to be done for 'all'. +ECHO > _CoqProject +COQC src/Compilers/Z/Bounds/Pipeline/Definition.v +src/Compilers/Z/Bounds/Pipeline/Definition (real: 7.33, user: 7.18, sys: 0.14, mem: 574388 ko) +COQC src/Compilers/Z/Bounds/Pipeline/ReflectiveTactics.v +src/Compilers/Z/Bounds/Pipeline/ReflectiveTactics (real: 1.93, user: 1.72, sys: 0.20, mem: 544172 ko) +COQC src/Compilers/Z/Bounds/Pipeline.v +src/Compilers/Z/Bounds/Pipeline (real: 1.38, user: 1.19, sys: 0.16, mem: 539808 ko) +COQC src/Specific/Framework/SynthesisFramework.v +src/Specific/Framework/SynthesisFramework (real: 1.85, user: 1.67, sys: 0.17, mem: 646300 ko) +COQC src/Specific/X25519/C64/Synthesis.v +src/Specific/X25519/C64/Synthesis (real: 11.15, user: 10.37, sys: 0.18, mem: 687760 ko) +COQC src/Specific/NISTP256/AMD64/Synthesis.v +src/Specific/NISTP256/AMD64/Synthesis (real: 13.45, user: 12.55, sys: 0.19, mem: 668216 ko) +COQC src/Specific/X25519/C64/feadd.v +Finished transaction in 2.814 secs (2.624u,0.s) (successful) +total time: 2.576s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.2% 97.4% 1 2.508s +─ReflectiveTactics.do_reflective_pipelin 0.0% 66.9% 1 1.724s +─ReflectiveTactics.solve_side_conditions 0.0% 65.5% 1 1.688s +─ReflectiveTactics.solve_post_reified_si 1.2% 37.0% 1 0.952s +─Glue.refine_to_reflective_glue' ------- 0.0% 30.3% 1 0.780s +─ReflectiveTactics.do_reify ------------ 0.0% 28.6% 1 0.736s +─Reify.Reify_rhs_gen ------------------- 2.2% 26.6% 1 0.684s +─UnifyAbstractReflexivity.unify_transfor 20.3% 24.1% 7 0.164s +─Glue.zrange_to_reflective ------------- 0.0% 20.3% 1 0.524s +─Glue.zrange_to_reflective_goal -------- 9.5% 15.2% 1 0.392s +─Reify.do_reify_abs_goal --------------- 13.7% 13.8% 2 0.356s +─Reify.do_reifyf_goal ------------------ 12.4% 12.6% 16 0.324s +─ReflectiveTactics.unify_abstract_cbv_in 8.4% 11.2% 1 0.288s +─unify (constr) (constr) --------------- 5.7% 5.7% 6 0.072s +─Glue.pattern_sig_sig_assoc ------------ 0.0% 5.4% 1 0.140s +─assert (H : is_bounded_by' bounds (map' 4.8% 5.1% 2 0.072s +─Glue.pattern_proj1_sig_in_sig --------- 1.7% 5.1% 1 0.132s +─pose proof (pf : Interpretation.Bo 3.7% 3.7% 1 0.096s +─Glue.split_BoundedWordToZ ------------- 0.3% 3.7% 1 0.096s +─destruct_sig -------------------------- 0.2% 3.3% 4 0.044s +─destruct x ---------------------------- 3.1% 3.1% 4 0.036s +─eexact -------------------------------- 3.0% 3.0% 18 0.008s +─clearbody (ne_var_list) --------------- 3.0% 3.0% 4 0.060s +─prove_interp_compile_correct ---------- 0.0% 2.8% 1 0.072s +─synthesize ---------------------------- 0.0% 2.6% 1 0.068s +─rewrite ?EtaInterp.InterpExprEta ------ 2.5% 2.5% 1 0.064s +─ClearbodyAll.clearbody_all ------------ 0.0% 2.3% 2 0.060s +─rewrite H ----------------------------- 2.2% 2.2% 1 0.056s +─reflexivity --------------------------- 2.2% 2.2% 7 0.032s +─Reify.transitivity_tt ----------------- 0.0% 2.2% 2 0.032s +─transitivity -------------------------- 2.0% 2.0% 5 0.024s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.2% 97.4% 1 2.508s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 66.9% 1 1.724s + │└ReflectiveTactics.solve_side_conditio 0.0% 65.5% 1 1.688s + │ ├─ReflectiveTactics.solve_post_reifie 1.2% 37.0% 1 0.952s + │ │ ├─UnifyAbstractReflexivity.unify_tr 20.3% 24.1% 7 0.164s + │ │ │└unify (constr) (constr) --------- 3.0% 3.0% 5 0.028s + │ │ └─ReflectiveTactics.unify_abstract_ 8.4% 11.2% 1 0.288s + │ │ └unify (constr) (constr) --------- 2.8% 2.8% 1 0.072s + │ └─ReflectiveTactics.do_reify -------- 0.0% 28.6% 1 0.736s + │ └Reify.Reify_rhs_gen --------------- 2.2% 26.6% 1 0.684s + │ ├─Reify.do_reify_abs_goal --------- 13.7% 13.8% 2 0.356s + │ │└Reify.do_reifyf_goal ------------ 12.4% 12.6% 16 0.324s + │ │└eexact -------------------------- 2.6% 2.6% 16 0.008s + │ ├─prove_interp_compile_correct ---- 0.0% 2.8% 1 0.072s + │ │└rewrite ?EtaInterp.InterpExprEta 2.5% 2.5% 1 0.064s + │ ├─rewrite H ----------------------- 2.2% 2.2% 1 0.056s + │ └─Reify.transitivity_tt ----------- 0.0% 2.2% 2 0.032s + └─Glue.refine_to_reflective_glue' ----- 0.0% 30.3% 1 0.780s + ├─Glue.zrange_to_reflective --------- 0.0% 20.3% 1 0.524s + │ ├─Glue.zrange_to_reflective_goal -- 9.5% 15.2% 1 0.392s + │ │└pose proof (pf : Interpretat 3.7% 3.7% 1 0.096s + │ └─assert (H : is_bounded_by' bounds 4.8% 5.1% 2 0.072s + ├─Glue.pattern_sig_sig_assoc -------- 0.0% 5.4% 1 0.140s + │└Glue.pattern_proj1_sig_in_sig ----- 1.7% 5.1% 1 0.132s + │└ClearbodyAll.clearbody_all -------- 0.0% 2.3% 2 0.060s + │└clearbody (ne_var_list) ----------- 2.3% 2.3% 1 0.060s + └─Glue.split_BoundedWordToZ --------- 0.3% 3.7% 1 0.096s + └destruct_sig ---------------------- 0.2% 3.3% 4 0.044s + └destruct x ------------------------ 2.5% 2.5% 2 0.036s +─synthesize ---------------------------- 0.0% 2.6% 1 0.068s + +Finished transaction in 5.021 secs (4.636u,0.s) (successful) +Closed under the global context +total time: 2.576s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.2% 97.4% 1 2.508s +─ReflectiveTactics.do_reflective_pipelin 0.0% 66.9% 1 1.724s +─ReflectiveTactics.solve_side_conditions 0.0% 65.5% 1 1.688s +─ReflectiveTactics.solve_post_reified_si 1.2% 37.0% 1 0.952s +─Glue.refine_to_reflective_glue' ------- 0.0% 30.3% 1 0.780s +─ReflectiveTactics.do_reify ------------ 0.0% 28.6% 1 0.736s +─Reify.Reify_rhs_gen ------------------- 2.2% 26.6% 1 0.684s +─UnifyAbstractReflexivity.unify_transfor 20.3% 24.1% 7 0.164s +─Glue.zrange_to_reflective ------------- 0.0% 20.3% 1 0.524s +─Glue.zrange_to_reflective_goal -------- 9.5% 15.2% 1 0.392s +─Reify.do_reify_abs_goal --------------- 13.7% 13.8% 2 0.356s +─Reify.do_reifyf_goal ------------------ 12.4% 12.6% 16 0.324s +─ReflectiveTactics.unify_abstract_cbv_in 8.4% 11.2% 1 0.288s +─unify (constr) (constr) --------------- 5.7% 5.7% 6 0.072s +─Glue.pattern_sig_sig_assoc ------------ 0.0% 5.4% 1 0.140s +─assert (H : is_bounded_by' bounds (map' 4.8% 5.1% 2 0.072s +─Glue.pattern_proj1_sig_in_sig --------- 1.7% 5.1% 1 0.132s +─pose proof (pf : Interpretation.Bo 3.7% 3.7% 1 0.096s +─Glue.split_BoundedWordToZ ------------- 0.3% 3.7% 1 0.096s +─destruct_sig -------------------------- 0.2% 3.3% 4 0.044s +─destruct x ---------------------------- 3.1% 3.1% 4 0.036s +─eexact -------------------------------- 3.0% 3.0% 18 0.008s +─clearbody (ne_var_list) --------------- 3.0% 3.0% 4 0.060s +─prove_interp_compile_correct ---------- 0.0% 2.8% 1 0.072s +─synthesize ---------------------------- 0.0% 2.6% 1 0.068s +─rewrite ?EtaInterp.InterpExprEta ------ 2.5% 2.5% 1 0.064s +─ClearbodyAll.clearbody_all ------------ 0.0% 2.3% 2 0.060s +─rewrite H ----------------------------- 2.2% 2.2% 1 0.056s +─reflexivity --------------------------- 2.2% 2.2% 7 0.032s +─Reify.transitivity_tt ----------------- 0.0% 2.2% 2 0.032s +─transitivity -------------------------- 2.0% 2.0% 5 0.024s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.2% 97.4% 1 2.508s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 66.9% 1 1.724s + │└ReflectiveTactics.solve_side_conditio 0.0% 65.5% 1 1.688s + │ ├─ReflectiveTactics.solve_post_reifie 1.2% 37.0% 1 0.952s + │ │ ├─UnifyAbstractReflexivity.unify_tr 20.3% 24.1% 7 0.164s + │ │ │└unify (constr) (constr) --------- 3.0% 3.0% 5 0.028s + │ │ └─ReflectiveTactics.unify_abstract_ 8.4% 11.2% 1 0.288s + │ │ └unify (constr) (constr) --------- 2.8% 2.8% 1 0.072s + │ └─ReflectiveTactics.do_reify -------- 0.0% 28.6% 1 0.736s + │ └Reify.Reify_rhs_gen --------------- 2.2% 26.6% 1 0.684s + │ ├─Reify.do_reify_abs_goal --------- 13.7% 13.8% 2 0.356s + │ │└Reify.do_reifyf_goal ------------ 12.4% 12.6% 16 0.324s + │ │└eexact -------------------------- 2.6% 2.6% 16 0.008s + │ ├─prove_interp_compile_correct ---- 0.0% 2.8% 1 0.072s + │ │└rewrite ?EtaInterp.InterpExprEta 2.5% 2.5% 1 0.064s + │ ├─rewrite H ----------------------- 2.2% 2.2% 1 0.056s + │ └─Reify.transitivity_tt ----------- 0.0% 2.2% 2 0.032s + └─Glue.refine_to_reflective_glue' ----- 0.0% 30.3% 1 0.780s + ├─Glue.zrange_to_reflective --------- 0.0% 20.3% 1 0.524s + │ ├─Glue.zrange_to_reflective_goal -- 9.5% 15.2% 1 0.392s + │ │└pose proof (pf : Interpretat 3.7% 3.7% 1 0.096s + │ └─assert (H : is_bounded_by' bounds 4.8% 5.1% 2 0.072s + ├─Glue.pattern_sig_sig_assoc -------- 0.0% 5.4% 1 0.140s + │└Glue.pattern_proj1_sig_in_sig ----- 1.7% 5.1% 1 0.132s + │└ClearbodyAll.clearbody_all -------- 0.0% 2.3% 2 0.060s + │└clearbody (ne_var_list) ----------- 2.3% 2.3% 1 0.060s + └─Glue.split_BoundedWordToZ --------- 0.3% 3.7% 1 0.096s + └destruct_sig ---------------------- 0.2% 3.3% 4 0.044s + └destruct x ------------------------ 2.5% 2.5% 2 0.036s +─synthesize ---------------------------- 0.0% 2.6% 1 0.068s + +src/Specific/X25519/C64/feadd (real: 22.81, user: 20.93, sys: 0.25, mem: 766300 ko) +COQC src/Specific/X25519/C64/fecarry.v +Finished transaction in 4.343 secs (4.016u,0.004s) (successful) +total time: 3.976s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 99.0% 1 3.936s +─ReflectiveTactics.do_reflective_pipelin 0.0% 87.9% 1 3.496s +─ReflectiveTactics.solve_side_conditions 0.0% 86.9% 1 3.456s +─ReflectiveTactics.do_reify ------------ 0.0% 56.9% 1 2.264s +─Reify.Reify_rhs_gen ------------------- 1.8% 56.2% 1 2.236s +─Reify.do_reify_abs_goal --------------- 36.1% 36.5% 2 1.452s +─Reify.do_reifyf_goal ------------------ 34.8% 35.1% 29 1.396s +─ReflectiveTactics.solve_post_reified_si 0.6% 30.0% 1 1.192s +─UnifyAbstractReflexivity.unify_transfor 17.7% 21.7% 7 0.240s +─Glue.refine_to_reflective_glue' ------- 0.0% 11.1% 1 0.440s +─eexact -------------------------------- 10.9% 10.9% 31 0.024s +─ReflectiveTactics.unify_abstract_cbv_in 5.2% 7.3% 1 0.292s +─Glue.zrange_to_reflective ------------- 0.0% 7.1% 1 0.284s +─prove_interp_compile_correct ---------- 0.0% 5.7% 1 0.228s +─Glue.zrange_to_reflective_goal -------- 4.3% 5.5% 1 0.220s +─unify (constr) (constr) --------------- 5.3% 5.3% 6 0.084s +─rewrite ?EtaInterp.InterpExprEta ------ 5.2% 5.2% 1 0.208s +─rewrite H ----------------------------- 3.5% 3.5% 1 0.140s +─tac ----------------------------------- 1.9% 2.6% 2 0.104s +─reflexivity --------------------------- 2.2% 2.2% 7 0.028s +─Reify.transitivity_tt ----------------- 0.0% 2.2% 2 0.056s +─transitivity -------------------------- 2.0% 2.0% 5 0.048s +─Glue.split_BoundedWordToZ ------------- 0.1% 2.0% 1 0.080s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 99.0% 1 3.936s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 87.9% 1 3.496s + │└ReflectiveTactics.solve_side_conditio 0.0% 86.9% 1 3.456s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 56.9% 1 2.264s + │ │└Reify.Reify_rhs_gen --------------- 1.8% 56.2% 1 2.236s + │ │ ├─Reify.do_reify_abs_goal --------- 36.1% 36.5% 2 1.452s + │ │ │└Reify.do_reifyf_goal ------------ 34.8% 35.1% 29 1.396s + │ │ │└eexact -------------------------- 10.1% 10.1% 29 0.024s + │ │ ├─prove_interp_compile_correct ---- 0.0% 5.7% 1 0.228s + │ │ │└rewrite ?EtaInterp.InterpExprEta 5.2% 5.2% 1 0.208s + │ │ ├─rewrite H ----------------------- 3.5% 3.5% 1 0.140s + │ │ ├─tac ----------------------------- 1.9% 2.6% 1 0.104s + │ │ └─Reify.transitivity_tt ----------- 0.0% 2.2% 2 0.056s + │ │ └transitivity -------------------- 2.0% 2.0% 4 0.048s + │ └─ReflectiveTactics.solve_post_reifie 0.6% 30.0% 1 1.192s + │ ├─UnifyAbstractReflexivity.unify_tr 17.7% 21.7% 7 0.240s + │ │└unify (constr) (constr) --------- 3.2% 3.2% 5 0.048s + │ └─ReflectiveTactics.unify_abstract_ 5.2% 7.3% 1 0.292s + │ └unify (constr) (constr) --------- 2.1% 2.1% 1 0.084s + └─Glue.refine_to_reflective_glue' ----- 0.0% 11.1% 1 0.440s + ├─Glue.zrange_to_reflective --------- 0.0% 7.1% 1 0.284s + │└Glue.zrange_to_reflective_goal ---- 4.3% 5.5% 1 0.220s + └─Glue.split_BoundedWordToZ --------- 0.1% 2.0% 1 0.080s + +Finished transaction in 7.078 secs (6.728u,0.s) (successful) +Closed under the global context +total time: 3.976s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 99.0% 1 3.936s +─ReflectiveTactics.do_reflective_pipelin 0.0% 87.9% 1 3.496s +─ReflectiveTactics.solve_side_conditions 0.0% 86.9% 1 3.456s +─ReflectiveTactics.do_reify ------------ 0.0% 56.9% 1 2.264s +─Reify.Reify_rhs_gen ------------------- 1.8% 56.2% 1 2.236s +─Reify.do_reify_abs_goal --------------- 36.1% 36.5% 2 1.452s +─Reify.do_reifyf_goal ------------------ 34.8% 35.1% 29 1.396s +─ReflectiveTactics.solve_post_reified_si 0.6% 30.0% 1 1.192s +─UnifyAbstractReflexivity.unify_transfor 17.7% 21.7% 7 0.240s +─Glue.refine_to_reflective_glue' ------- 0.0% 11.1% 1 0.440s +─eexact -------------------------------- 10.9% 10.9% 31 0.024s +─ReflectiveTactics.unify_abstract_cbv_in 5.2% 7.3% 1 0.292s +─Glue.zrange_to_reflective ------------- 0.0% 7.1% 1 0.284s +─prove_interp_compile_correct ---------- 0.0% 5.7% 1 0.228s +─Glue.zrange_to_reflective_goal -------- 4.3% 5.5% 1 0.220s +─unify (constr) (constr) --------------- 5.3% 5.3% 6 0.084s +─rewrite ?EtaInterp.InterpExprEta ------ 5.2% 5.2% 1 0.208s +─rewrite H ----------------------------- 3.5% 3.5% 1 0.140s +─tac ----------------------------------- 1.9% 2.6% 2 0.104s +─reflexivity --------------------------- 2.2% 2.2% 7 0.028s +─Reify.transitivity_tt ----------------- 0.0% 2.2% 2 0.056s +─transitivity -------------------------- 2.0% 2.0% 5 0.048s +─Glue.split_BoundedWordToZ ------------- 0.1% 2.0% 1 0.080s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 99.0% 1 3.936s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 87.9% 1 3.496s + │└ReflectiveTactics.solve_side_conditio 0.0% 86.9% 1 3.456s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 56.9% 1 2.264s + │ │└Reify.Reify_rhs_gen --------------- 1.8% 56.2% 1 2.236s + │ │ ├─Reify.do_reify_abs_goal --------- 36.1% 36.5% 2 1.452s + │ │ │└Reify.do_reifyf_goal ------------ 34.8% 35.1% 29 1.396s + │ │ │└eexact -------------------------- 10.1% 10.1% 29 0.024s + │ │ ├─prove_interp_compile_correct ---- 0.0% 5.7% 1 0.228s + │ │ │└rewrite ?EtaInterp.InterpExprEta 5.2% 5.2% 1 0.208s + │ │ ├─rewrite H ----------------------- 3.5% 3.5% 1 0.140s + │ │ ├─tac ----------------------------- 1.9% 2.6% 1 0.104s + │ │ └─Reify.transitivity_tt ----------- 0.0% 2.2% 2 0.056s + │ │ └transitivity -------------------- 2.0% 2.0% 4 0.048s + │ └─ReflectiveTactics.solve_post_reifie 0.6% 30.0% 1 1.192s + │ ├─UnifyAbstractReflexivity.unify_tr 17.7% 21.7% 7 0.240s + │ │└unify (constr) (constr) --------- 3.2% 3.2% 5 0.048s + │ └─ReflectiveTactics.unify_abstract_ 5.2% 7.3% 1 0.292s + │ └unify (constr) (constr) --------- 2.1% 2.1% 1 0.084s + └─Glue.refine_to_reflective_glue' ----- 0.0% 11.1% 1 0.440s + ├─Glue.zrange_to_reflective --------- 0.0% 7.1% 1 0.284s + │└Glue.zrange_to_reflective_goal ---- 4.3% 5.5% 1 0.220s + └─Glue.split_BoundedWordToZ --------- 0.1% 2.0% 1 0.080s + +src/Specific/X25519/C64/fecarry (real: 27.11, user: 24.99, sys: 0.21, mem: 786052 ko) +COQC src/Specific/solinas32_2e255m765_12limbs/Synthesis.v +src/Specific/solinas32_2e255m765_12limbs/Synthesis (real: 40.13, user: 36.92, sys: 0.26, mem: 728464 ko) +COQC src/Specific/solinas32_2e255m765_13limbs/Synthesis.v +src/Specific/solinas32_2e255m765_13limbs/Synthesis (real: 49.44, user: 45.75, sys: 0.18, mem: 744240 ko) +COQC src/Specific/X25519/C64/femul.v +Finished transaction in 8.415 secs (7.664u,0.015s) (successful) +total time: 7.616s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 94.8% 1 7.220s +─ReflectiveTactics.do_reflective_pipelin 0.0% 85.0% 1 6.476s +─ReflectiveTactics.solve_side_conditions 0.0% 84.2% 1 6.416s +─ReflectiveTactics.do_reify ------------ 0.0% 50.3% 1 3.832s +─Reify.Reify_rhs_gen ------------------- 1.8% 49.4% 1 3.760s +─ReflectiveTactics.solve_post_reified_si 0.5% 33.9% 1 2.584s +─Reify.do_reify_abs_goal --------------- 31.1% 31.4% 2 2.392s +─Reify.do_reifyf_goal ------------------ 30.0% 30.3% 58 1.528s +─UnifyAbstractReflexivity.unify_transfor 22.1% 27.3% 7 0.600s +─Glue.refine_to_reflective_glue' ------- 0.0% 9.8% 1 0.744s +─eexact -------------------------------- 8.2% 8.2% 60 0.024s +─Glue.zrange_to_reflective ------------- 0.1% 6.8% 1 0.516s +─unify (constr) (constr) --------------- 5.9% 5.9% 6 0.124s +─prove_interp_compile_correct ---------- 0.0% 5.8% 1 0.444s +─ReflectiveTactics.unify_abstract_cbv_in 3.9% 5.7% 1 0.432s +─rewrite ?EtaInterp.InterpExprEta ------ 5.4% 5.4% 1 0.408s +─synthesize ---------------------------- 0.0% 5.2% 1 0.396s +─Glue.zrange_to_reflective_goal -------- 3.0% 5.0% 1 0.384s +─IntegrationTestTemporaryMiscCommon.do_r 0.1% 4.8% 1 0.364s +─change G' ----------------------------- 3.9% 3.9% 1 0.300s +─rewrite H ----------------------------- 3.0% 3.0% 1 0.232s +─tac ----------------------------------- 1.5% 2.3% 2 0.176s +─Reify.transitivity_tt ----------------- 0.0% 2.1% 2 0.092s +─reflexivity --------------------------- 2.0% 2.0% 7 0.052s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 94.8% 1 7.220s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 85.0% 1 6.476s + │└ReflectiveTactics.solve_side_conditio 0.0% 84.2% 1 6.416s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 50.3% 1 3.832s + │ │└Reify.Reify_rhs_gen --------------- 1.8% 49.4% 1 3.760s + │ │ ├─Reify.do_reify_abs_goal --------- 31.1% 31.4% 2 2.392s + │ │ │└Reify.do_reifyf_goal ------------ 30.0% 30.3% 58 1.528s + │ │ │└eexact -------------------------- 7.6% 7.6% 58 0.020s + │ │ ├─prove_interp_compile_correct ---- 0.0% 5.8% 1 0.444s + │ │ │└rewrite ?EtaInterp.InterpExprEta 5.4% 5.4% 1 0.408s + │ │ ├─rewrite H ----------------------- 3.0% 3.0% 1 0.232s + │ │ ├─tac ----------------------------- 1.5% 2.3% 1 0.176s + │ │ └─Reify.transitivity_tt ----------- 0.0% 2.1% 2 0.092s + │ └─ReflectiveTactics.solve_post_reifie 0.5% 33.9% 1 2.584s + │ ├─UnifyAbstractReflexivity.unify_tr 22.1% 27.3% 7 0.600s + │ │└unify (constr) (constr) --------- 4.3% 4.3% 5 0.096s + │ └─ReflectiveTactics.unify_abstract_ 3.9% 5.7% 1 0.432s + └─Glue.refine_to_reflective_glue' ----- 0.0% 9.8% 1 0.744s + └Glue.zrange_to_reflective ----------- 0.1% 6.8% 1 0.516s + └Glue.zrange_to_reflective_goal ------ 3.0% 5.0% 1 0.384s +─synthesize ---------------------------- 0.0% 5.2% 1 0.396s +└IntegrationTestTemporaryMiscCommon.do_r 0.1% 4.8% 1 0.364s +└change G' ----------------------------- 3.9% 3.9% 1 0.300s + +Finished transaction in 14.616 secs (13.528u,0.008s) (successful) +Closed under the global context +total time: 7.616s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 94.8% 1 7.220s +─ReflectiveTactics.do_reflective_pipelin 0.0% 85.0% 1 6.476s +─ReflectiveTactics.solve_side_conditions 0.0% 84.2% 1 6.416s +─ReflectiveTactics.do_reify ------------ 0.0% 50.3% 1 3.832s +─Reify.Reify_rhs_gen ------------------- 1.8% 49.4% 1 3.760s +─ReflectiveTactics.solve_post_reified_si 0.5% 33.9% 1 2.584s +─Reify.do_reify_abs_goal --------------- 31.1% 31.4% 2 2.392s +─Reify.do_reifyf_goal ------------------ 30.0% 30.3% 58 1.528s +─UnifyAbstractReflexivity.unify_transfor 22.1% 27.3% 7 0.600s +─Glue.refine_to_reflective_glue' ------- 0.0% 9.8% 1 0.744s +─eexact -------------------------------- 8.2% 8.2% 60 0.024s +─Glue.zrange_to_reflective ------------- 0.1% 6.8% 1 0.516s +─unify (constr) (constr) --------------- 5.9% 5.9% 6 0.124s +─prove_interp_compile_correct ---------- 0.0% 5.8% 1 0.444s +─ReflectiveTactics.unify_abstract_cbv_in 3.9% 5.7% 1 0.432s +─rewrite ?EtaInterp.InterpExprEta ------ 5.4% 5.4% 1 0.408s +─synthesize ---------------------------- 0.0% 5.2% 1 0.396s +─Glue.zrange_to_reflective_goal -------- 3.0% 5.0% 1 0.384s +─IntegrationTestTemporaryMiscCommon.do_r 0.1% 4.8% 1 0.364s +─change G' ----------------------------- 3.9% 3.9% 1 0.300s +─rewrite H ----------------------------- 3.0% 3.0% 1 0.232s +─tac ----------------------------------- 1.5% 2.3% 2 0.176s +─Reify.transitivity_tt ----------------- 0.0% 2.1% 2 0.092s +─reflexivity --------------------------- 2.0% 2.0% 7 0.052s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 94.8% 1 7.220s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 85.0% 1 6.476s + │└ReflectiveTactics.solve_side_conditio 0.0% 84.2% 1 6.416s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 50.3% 1 3.832s + │ │└Reify.Reify_rhs_gen --------------- 1.8% 49.4% 1 3.760s + │ │ ├─Reify.do_reify_abs_goal --------- 31.1% 31.4% 2 2.392s + │ │ │└Reify.do_reifyf_goal ------------ 30.0% 30.3% 58 1.528s + │ │ │└eexact -------------------------- 7.6% 7.6% 58 0.020s + │ │ ├─prove_interp_compile_correct ---- 0.0% 5.8% 1 0.444s + │ │ │└rewrite ?EtaInterp.InterpExprEta 5.4% 5.4% 1 0.408s + │ │ ├─rewrite H ----------------------- 3.0% 3.0% 1 0.232s + │ │ ├─tac ----------------------------- 1.5% 2.3% 1 0.176s + │ │ └─Reify.transitivity_tt ----------- 0.0% 2.1% 2 0.092s + │ └─ReflectiveTactics.solve_post_reifie 0.5% 33.9% 1 2.584s + │ ├─UnifyAbstractReflexivity.unify_tr 22.1% 27.3% 7 0.600s + │ │└unify (constr) (constr) --------- 4.3% 4.3% 5 0.096s + │ └─ReflectiveTactics.unify_abstract_ 3.9% 5.7% 1 0.432s + └─Glue.refine_to_reflective_glue' ----- 0.0% 9.8% 1 0.744s + └Glue.zrange_to_reflective ----------- 0.1% 6.8% 1 0.516s + └Glue.zrange_to_reflective_goal ------ 3.0% 5.0% 1 0.384s +─synthesize ---------------------------- 0.0% 5.2% 1 0.396s +└IntegrationTestTemporaryMiscCommon.do_r 0.1% 4.8% 1 0.364s +└change G' ----------------------------- 3.9% 3.9% 1 0.300s + +src/Specific/X25519/C64/femul (real: 39.72, user: 36.32, sys: 0.26, mem: 825448 ko) +COQC src/Specific/X25519/C64/feaddDisplay > src/Specific/X25519/C64/feaddDisplay.log +COQC src/Specific/X25519/C64/fecarryDisplay > src/Specific/X25519/C64/fecarryDisplay.log +COQC src/Specific/X25519/C64/fesub.v +Finished transaction in 3.513 secs (3.211u,0.s) (successful) +total time: 3.164s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.6% 1 3.088s +─ReflectiveTactics.do_reflective_pipelin 0.0% 74.1% 1 2.344s +─ReflectiveTactics.solve_side_conditions 0.0% 72.9% 1 2.308s +─ReflectiveTactics.do_reify ------------ 0.0% 38.6% 1 1.220s +─Reify.Reify_rhs_gen ------------------- 1.5% 37.2% 1 1.176s +─ReflectiveTactics.solve_post_reified_si 0.9% 34.4% 1 1.088s +─UnifyAbstractReflexivity.unify_transfor 19.2% 23.9% 7 0.204s +─Glue.refine_to_reflective_glue' ------- 0.0% 23.5% 1 0.744s +─Reify.do_reify_abs_goal --------------- 19.2% 19.5% 2 0.616s +─Reify.do_reifyf_goal ------------------ 18.0% 18.3% 16 0.580s +─Glue.zrange_to_reflective ------------- 0.1% 15.4% 1 0.488s +─Glue.zrange_to_reflective_goal -------- 6.8% 11.5% 1 0.364s +─ReflectiveTactics.unify_abstract_cbv_in 6.2% 9.0% 1 0.284s +─unify (constr) (constr) --------------- 5.9% 5.9% 6 0.080s +─Glue.pattern_sig_sig_assoc ------------ 0.0% 4.6% 1 0.144s +─eexact -------------------------------- 4.4% 4.4% 18 0.012s +─Glue.pattern_proj1_sig_in_sig --------- 1.4% 4.3% 1 0.136s +─prove_interp_compile_correct ---------- 0.0% 3.9% 1 0.124s +─rewrite H ----------------------------- 3.8% 3.8% 1 0.120s +─assert (H : is_bounded_by' bounds (map' 3.8% 3.8% 2 0.064s +─rewrite ?EtaInterp.InterpExprEta ------ 3.5% 3.5% 1 0.112s +─pose proof (pf : Interpretation.Bo 2.9% 2.9% 1 0.092s +─Glue.split_BoundedWordToZ ------------- 0.1% 2.8% 1 0.088s +─tac ----------------------------------- 1.9% 2.5% 2 0.080s +─reflexivity --------------------------- 2.4% 2.4% 7 0.028s +─synthesize ---------------------------- 0.0% 2.4% 1 0.076s +─destruct_sig -------------------------- 0.0% 2.4% 4 0.040s +─destruct x ---------------------------- 2.4% 2.4% 4 0.032s +─clearbody (ne_var_list) --------------- 2.3% 2.3% 4 0.060s +─Reify.transitivity_tt ----------------- 0.1% 2.3% 2 0.036s +─transitivity -------------------------- 2.1% 2.1% 5 0.032s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.6% 1 3.088s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 74.1% 1 2.344s + │└ReflectiveTactics.solve_side_conditio 0.0% 72.9% 1 2.308s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 38.6% 1 1.220s + │ │└Reify.Reify_rhs_gen --------------- 1.5% 37.2% 1 1.176s + │ │ ├─Reify.do_reify_abs_goal --------- 19.2% 19.5% 2 0.616s + │ │ │└Reify.do_reifyf_goal ------------ 18.0% 18.3% 16 0.580s + │ │ │└eexact -------------------------- 3.9% 3.9% 16 0.012s + │ │ ├─prove_interp_compile_correct ---- 0.0% 3.9% 1 0.124s + │ │ │└rewrite ?EtaInterp.InterpExprEta 3.5% 3.5% 1 0.112s + │ │ ├─rewrite H ----------------------- 3.8% 3.8% 1 0.120s + │ │ ├─tac ----------------------------- 1.9% 2.5% 1 0.080s + │ │ └─Reify.transitivity_tt ----------- 0.1% 2.3% 2 0.036s + │ │ └transitivity -------------------- 2.0% 2.0% 4 0.032s + │ └─ReflectiveTactics.solve_post_reifie 0.9% 34.4% 1 1.088s + │ ├─UnifyAbstractReflexivity.unify_tr 19.2% 23.9% 7 0.204s + │ │└unify (constr) (constr) --------- 3.4% 3.4% 5 0.036s + │ └─ReflectiveTactics.unify_abstract_ 6.2% 9.0% 1 0.284s + │ └unify (constr) (constr) --------- 2.5% 2.5% 1 0.080s + └─Glue.refine_to_reflective_glue' ----- 0.0% 23.5% 1 0.744s + ├─Glue.zrange_to_reflective --------- 0.1% 15.4% 1 0.488s + │ ├─Glue.zrange_to_reflective_goal -- 6.8% 11.5% 1 0.364s + │ │└pose proof (pf : Interpretat 2.9% 2.9% 1 0.092s + │ └─assert (H : is_bounded_by' bounds 3.8% 3.8% 2 0.064s + ├─Glue.pattern_sig_sig_assoc -------- 0.0% 4.6% 1 0.144s + │└Glue.pattern_proj1_sig_in_sig ----- 1.4% 4.3% 1 0.136s + └─Glue.split_BoundedWordToZ --------- 0.1% 2.8% 1 0.088s + └destruct_sig ---------------------- 0.0% 2.4% 4 0.040s +─synthesize ---------------------------- 0.0% 2.4% 1 0.076s + +Finished transaction in 6.12 secs (5.64u,0.008s) (successful) +Closed under the global context +total time: 3.164s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.6% 1 3.088s +─ReflectiveTactics.do_reflective_pipelin 0.0% 74.1% 1 2.344s +─ReflectiveTactics.solve_side_conditions 0.0% 72.9% 1 2.308s +─ReflectiveTactics.do_reify ------------ 0.0% 38.6% 1 1.220s +─Reify.Reify_rhs_gen ------------------- 1.5% 37.2% 1 1.176s +─ReflectiveTactics.solve_post_reified_si 0.9% 34.4% 1 1.088s +─UnifyAbstractReflexivity.unify_transfor 19.2% 23.9% 7 0.204s +─Glue.refine_to_reflective_glue' ------- 0.0% 23.5% 1 0.744s +─Reify.do_reify_abs_goal --------------- 19.2% 19.5% 2 0.616s +─Reify.do_reifyf_goal ------------------ 18.0% 18.3% 16 0.580s +─Glue.zrange_to_reflective ------------- 0.1% 15.4% 1 0.488s +─Glue.zrange_to_reflective_goal -------- 6.8% 11.5% 1 0.364s +─ReflectiveTactics.unify_abstract_cbv_in 6.2% 9.0% 1 0.284s +─unify (constr) (constr) --------------- 5.9% 5.9% 6 0.080s +─Glue.pattern_sig_sig_assoc ------------ 0.0% 4.6% 1 0.144s +─eexact -------------------------------- 4.4% 4.4% 18 0.012s +─Glue.pattern_proj1_sig_in_sig --------- 1.4% 4.3% 1 0.136s +─prove_interp_compile_correct ---------- 0.0% 3.9% 1 0.124s +─rewrite H ----------------------------- 3.8% 3.8% 1 0.120s +─assert (H : is_bounded_by' bounds (map' 3.8% 3.8% 2 0.064s +─rewrite ?EtaInterp.InterpExprEta ------ 3.5% 3.5% 1 0.112s +─pose proof (pf : Interpretation.Bo 2.9% 2.9% 1 0.092s +─Glue.split_BoundedWordToZ ------------- 0.1% 2.8% 1 0.088s +─tac ----------------------------------- 1.9% 2.5% 2 0.080s +─reflexivity --------------------------- 2.4% 2.4% 7 0.028s +─synthesize ---------------------------- 0.0% 2.4% 1 0.076s +─destruct_sig -------------------------- 0.0% 2.4% 4 0.040s +─destruct x ---------------------------- 2.4% 2.4% 4 0.032s +─clearbody (ne_var_list) --------------- 2.3% 2.3% 4 0.060s +─Reify.transitivity_tt ----------------- 0.1% 2.3% 2 0.036s +─transitivity -------------------------- 2.1% 2.1% 5 0.032s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.6% 1 3.088s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 74.1% 1 2.344s + │└ReflectiveTactics.solve_side_conditio 0.0% 72.9% 1 2.308s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 38.6% 1 1.220s + │ │└Reify.Reify_rhs_gen --------------- 1.5% 37.2% 1 1.176s + │ │ ├─Reify.do_reify_abs_goal --------- 19.2% 19.5% 2 0.616s + │ │ │└Reify.do_reifyf_goal ------------ 18.0% 18.3% 16 0.580s + │ │ │└eexact -------------------------- 3.9% 3.9% 16 0.012s + │ │ ├─prove_interp_compile_correct ---- 0.0% 3.9% 1 0.124s + │ │ │└rewrite ?EtaInterp.InterpExprEta 3.5% 3.5% 1 0.112s + │ │ ├─rewrite H ----------------------- 3.8% 3.8% 1 0.120s + │ │ ├─tac ----------------------------- 1.9% 2.5% 1 0.080s + │ │ └─Reify.transitivity_tt ----------- 0.1% 2.3% 2 0.036s + │ │ └transitivity -------------------- 2.0% 2.0% 4 0.032s + │ └─ReflectiveTactics.solve_post_reifie 0.9% 34.4% 1 1.088s + │ ├─UnifyAbstractReflexivity.unify_tr 19.2% 23.9% 7 0.204s + │ │└unify (constr) (constr) --------- 3.4% 3.4% 5 0.036s + │ └─ReflectiveTactics.unify_abstract_ 6.2% 9.0% 1 0.284s + │ └unify (constr) (constr) --------- 2.5% 2.5% 1 0.080s + └─Glue.refine_to_reflective_glue' ----- 0.0% 23.5% 1 0.744s + ├─Glue.zrange_to_reflective --------- 0.1% 15.4% 1 0.488s + │ ├─Glue.zrange_to_reflective_goal -- 6.8% 11.5% 1 0.364s + │ │└pose proof (pf : Interpretat 2.9% 2.9% 1 0.092s + │ └─assert (H : is_bounded_by' bounds 3.8% 3.8% 2 0.064s + ├─Glue.pattern_sig_sig_assoc -------- 0.0% 4.6% 1 0.144s + │└Glue.pattern_proj1_sig_in_sig ----- 1.4% 4.3% 1 0.136s + └─Glue.split_BoundedWordToZ --------- 0.1% 2.8% 1 0.088s + └destruct_sig ---------------------- 0.0% 2.4% 4 0.040s +─synthesize ---------------------------- 0.0% 2.4% 1 0.076s + +src/Specific/X25519/C64/fesub (real: 24.71, user: 22.65, sys: 0.24, mem: 778792 ko) +COQC src/Specific/X25519/C64/fesquare.v +Finished transaction in 6.132 secs (5.516u,0.012s) (successful) +total time: 5.480s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize ---------------------------- -0.0% 100.0% 1 5.480s +─Pipeline.refine_reflectively_gen ------ 0.0% 95.7% 1 5.244s +─ReflectiveTactics.do_reflective_pipelin 0.0% 88.6% 1 4.856s +─ReflectiveTactics.solve_side_conditions 0.0% 87.7% 1 4.804s +─ReflectiveTactics.do_reify ------------ 0.0% 53.3% 1 2.920s +─Reify.Reify_rhs_gen ------------------- 2.0% 52.5% 1 2.876s +─ReflectiveTactics.solve_post_reified_si 0.6% 34.4% 1 1.884s +─Reify.do_reify_abs_goal --------------- 33.2% 33.6% 2 1.844s +─Reify.do_reifyf_goal ------------------ 31.5% 32.0% 47 1.392s +─UnifyAbstractReflexivity.unify_transfor 21.9% 26.6% 7 0.400s +─eexact -------------------------------- 10.0% 10.0% 49 0.028s +─Glue.refine_to_reflective_glue' ------- 0.0% 7.1% 1 0.388s +─ReflectiveTactics.unify_abstract_cbv_in 5.0% 6.9% 1 0.380s +─unify (constr) (constr) --------------- 5.8% 5.8% 6 0.104s +─prove_interp_compile_correct ---------- 0.0% 5.8% 1 0.316s +─rewrite ?EtaInterp.InterpExprEta ------ 5.3% 5.3% 1 0.288s +─Glue.zrange_to_reflective ------------- 0.1% 5.1% 1 0.280s +─IntegrationTestTemporaryMiscCommon.do_r 0.1% 4.0% 1 0.220s +─Glue.zrange_to_reflective_goal -------- 3.1% 3.9% 1 0.212s +─change G' ----------------------------- 3.4% 3.4% 1 0.184s +─tac ----------------------------------- 2.0% 2.8% 2 0.156s +─rewrite H ----------------------------- 2.8% 2.8% 1 0.156s +─reflexivity --------------------------- 2.8% 2.8% 7 0.064s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize ---------------------------- -0.0% 100.0% 1 5.480s + ├─Pipeline.refine_reflectively_gen ---- 0.0% 95.7% 1 5.244s + │ ├─ReflectiveTactics.do_reflective_pip 0.0% 88.6% 1 4.856s + │ │└ReflectiveTactics.solve_side_condit 0.0% 87.7% 1 4.804s + │ │ ├─ReflectiveTactics.do_reify ------ 0.0% 53.3% 1 2.920s + │ │ │└Reify.Reify_rhs_gen ------------- 2.0% 52.5% 1 2.876s + │ │ │ ├─Reify.do_reify_abs_goal ------- 33.2% 33.6% 2 1.844s + │ │ │ │└Reify.do_reifyf_goal ---------- 31.5% 32.0% 47 1.392s + │ │ │ │└eexact ------------------------ 9.1% 9.1% 47 0.024s + │ │ │ ├─prove_interp_compile_correct -- 0.0% 5.8% 1 0.316s + │ │ │ │└rewrite ?EtaInterp.InterpExprEt 5.3% 5.3% 1 0.288s + │ │ │ ├─tac --------------------------- 2.0% 2.8% 1 0.156s + │ │ │ └─rewrite H --------------------- 2.8% 2.8% 1 0.156s + │ │ └─ReflectiveTactics.solve_post_reif 0.6% 34.4% 1 1.884s + │ │ ├─UnifyAbstractReflexivity.unify_ 21.9% 26.6% 7 0.400s + │ │ │└unify (constr) (constr) ------- 3.9% 3.9% 5 0.072s + │ │ └─ReflectiveTactics.unify_abstrac 5.0% 6.9% 1 0.380s + │ └─Glue.refine_to_reflective_glue' --- 0.0% 7.1% 1 0.388s + │ └Glue.zrange_to_reflective --------- 0.1% 5.1% 1 0.280s + │ └Glue.zrange_to_reflective_goal ---- 3.1% 3.9% 1 0.212s + └─IntegrationTestTemporaryMiscCommon.do 0.1% 4.0% 1 0.220s + └change G' --------------------------- 3.4% 3.4% 1 0.184s + +Finished transaction in 10.475 secs (9.728u,0.007s) (successful) +Closed under the global context +total time: 5.480s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize ---------------------------- -0.0% 100.0% 1 5.480s +─Pipeline.refine_reflectively_gen ------ 0.0% 95.7% 1 5.244s +─ReflectiveTactics.do_reflective_pipelin 0.0% 88.6% 1 4.856s +─ReflectiveTactics.solve_side_conditions 0.0% 87.7% 1 4.804s +─ReflectiveTactics.do_reify ------------ 0.0% 53.3% 1 2.920s +─Reify.Reify_rhs_gen ------------------- 2.0% 52.5% 1 2.876s +─ReflectiveTactics.solve_post_reified_si 0.6% 34.4% 1 1.884s +─Reify.do_reify_abs_goal --------------- 33.2% 33.6% 2 1.844s +─Reify.do_reifyf_goal ------------------ 31.5% 32.0% 47 1.392s +─UnifyAbstractReflexivity.unify_transfor 21.9% 26.6% 7 0.400s +─eexact -------------------------------- 10.0% 10.0% 49 0.028s +─Glue.refine_to_reflective_glue' ------- 0.0% 7.1% 1 0.388s +─ReflectiveTactics.unify_abstract_cbv_in 5.0% 6.9% 1 0.380s +─unify (constr) (constr) --------------- 5.8% 5.8% 6 0.104s +─prove_interp_compile_correct ---------- 0.0% 5.8% 1 0.316s +─rewrite ?EtaInterp.InterpExprEta ------ 5.3% 5.3% 1 0.288s +─Glue.zrange_to_reflective ------------- 0.1% 5.1% 1 0.280s +─IntegrationTestTemporaryMiscCommon.do_r 0.1% 4.0% 1 0.220s +─Glue.zrange_to_reflective_goal -------- 3.1% 3.9% 1 0.212s +─change G' ----------------------------- 3.4% 3.4% 1 0.184s +─tac ----------------------------------- 2.0% 2.8% 2 0.156s +─rewrite H ----------------------------- 2.8% 2.8% 1 0.156s +─reflexivity --------------------------- 2.8% 2.8% 7 0.064s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize ---------------------------- -0.0% 100.0% 1 5.480s + ├─Pipeline.refine_reflectively_gen ---- 0.0% 95.7% 1 5.244s + │ ├─ReflectiveTactics.do_reflective_pip 0.0% 88.6% 1 4.856s + │ │└ReflectiveTactics.solve_side_condit 0.0% 87.7% 1 4.804s + │ │ ├─ReflectiveTactics.do_reify ------ 0.0% 53.3% 1 2.920s + │ │ │└Reify.Reify_rhs_gen ------------- 2.0% 52.5% 1 2.876s + │ │ │ ├─Reify.do_reify_abs_goal ------- 33.2% 33.6% 2 1.844s + │ │ │ │└Reify.do_reifyf_goal ---------- 31.5% 32.0% 47 1.392s + │ │ │ │└eexact ------------------------ 9.1% 9.1% 47 0.024s + │ │ │ ├─prove_interp_compile_correct -- 0.0% 5.8% 1 0.316s + │ │ │ │└rewrite ?EtaInterp.InterpExprEt 5.3% 5.3% 1 0.288s + │ │ │ ├─tac --------------------------- 2.0% 2.8% 1 0.156s + │ │ │ └─rewrite H --------------------- 2.8% 2.8% 1 0.156s + │ │ └─ReflectiveTactics.solve_post_reif 0.6% 34.4% 1 1.884s + │ │ ├─UnifyAbstractReflexivity.unify_ 21.9% 26.6% 7 0.400s + │ │ │└unify (constr) (constr) ------- 3.9% 3.9% 5 0.072s + │ │ └─ReflectiveTactics.unify_abstrac 5.0% 6.9% 1 0.380s + │ └─Glue.refine_to_reflective_glue' --- 0.0% 7.1% 1 0.388s + │ └Glue.zrange_to_reflective --------- 0.1% 5.1% 1 0.280s + │ └Glue.zrange_to_reflective_goal ---- 3.1% 3.9% 1 0.212s + └─IntegrationTestTemporaryMiscCommon.do 0.1% 4.0% 1 0.220s + └change G' --------------------------- 3.4% 3.4% 1 0.184s + +src/Specific/X25519/C64/fesquare (real: 33.08, user: 30.13, sys: 0.24, mem: 799620 ko) +COQC src/Specific/X25519/C64/femulDisplay > src/Specific/X25519/C64/femulDisplay.log +COQC src/Specific/X25519/C64/freeze.v +Finished transaction in 7.307 secs (6.763u,0.011s) (successful) +total time: 6.732s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_freeze --------------------- 0.0% 100.0% 1 6.732s +─Pipeline.refine_reflectively_gen ------ 0.0% 99.3% 1 6.684s +─ReflectiveTactics.do_reflective_pipelin 0.0% 92.8% 1 6.248s +─ReflectiveTactics.solve_side_conditions 0.0% 92.0% 1 6.192s +─ReflectiveTactics.do_reify ------------ -0.0% 60.3% 1 4.060s +─Reify.Reify_rhs_gen ------------------- 1.5% 59.6% 1 4.012s +─Reify.do_reify_abs_goal --------------- 42.4% 42.7% 2 2.876s +─Reify.do_reifyf_goal ------------------ 41.3% 41.7% 129 2.804s +─ReflectiveTactics.solve_post_reified_si 0.6% 31.7% 1 2.132s +─UnifyAbstractReflexivity.unify_transfor 21.7% 25.8% 7 0.424s +─eexact -------------------------------- 13.7% 13.7% 131 0.036s +─Glue.refine_to_reflective_glue' ------- 0.0% 6.5% 1 0.436s +─prove_interp_compile_correct ---------- 0.0% 5.1% 1 0.344s +─ReflectiveTactics.unify_abstract_cbv_in 3.4% 5.0% 1 0.336s +─rewrite ?EtaInterp.InterpExprEta ------ 4.7% 4.7% 1 0.316s +─unify (constr) (constr) --------------- 4.6% 4.6% 6 0.100s +─Glue.zrange_to_reflective ------------- 0.0% 4.2% 1 0.280s +─Glue.zrange_to_reflective_goal -------- 2.4% 3.3% 1 0.220s +─Reify.transitivity_tt ----------------- 0.1% 2.6% 2 0.116s +─rewrite H ----------------------------- 2.6% 2.6% 1 0.172s +─tac ----------------------------------- 1.5% 2.3% 2 0.156s +─reflexivity --------------------------- 2.3% 2.3% 7 0.052s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_freeze --------------------- 0.0% 100.0% 1 6.732s +└Pipeline.refine_reflectively_gen ------ 0.0% 99.3% 1 6.684s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 92.8% 1 6.248s + │└ReflectiveTactics.solve_side_conditio 0.0% 92.0% 1 6.192s + │ ├─ReflectiveTactics.do_reify -------- -0.0% 60.3% 1 4.060s + │ │└Reify.Reify_rhs_gen --------------- 1.5% 59.6% 1 4.012s + │ │ ├─Reify.do_reify_abs_goal --------- 42.4% 42.7% 2 2.876s + │ │ │└Reify.do_reifyf_goal ------------ 41.3% 41.7% 129 2.804s + │ │ │└eexact -------------------------- 13.0% 13.0% 129 0.036s + │ │ ├─prove_interp_compile_correct ---- 0.0% 5.1% 1 0.344s + │ │ │└rewrite ?EtaInterp.InterpExprEta 4.7% 4.7% 1 0.316s + │ │ ├─Reify.transitivity_tt ----------- 0.1% 2.6% 2 0.116s + │ │ ├─rewrite H ----------------------- 2.6% 2.6% 1 0.172s + │ │ └─tac ----------------------------- 1.5% 2.3% 1 0.156s + │ └─ReflectiveTactics.solve_post_reifie 0.6% 31.7% 1 2.132s + │ ├─UnifyAbstractReflexivity.unify_tr 21.7% 25.8% 7 0.424s + │ │└unify (constr) (constr) --------- 3.1% 3.1% 5 0.084s + │ └─ReflectiveTactics.unify_abstract_ 3.4% 5.0% 1 0.336s + └─Glue.refine_to_reflective_glue' ----- 0.0% 6.5% 1 0.436s + └Glue.zrange_to_reflective ----------- 0.0% 4.2% 1 0.280s + └Glue.zrange_to_reflective_goal ------ 2.4% 3.3% 1 0.220s + +Finished transaction in 10.495 secs (9.756u,0.s) (successful) +Closed under the global context +total time: 6.732s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_freeze --------------------- 0.0% 100.0% 1 6.732s +─Pipeline.refine_reflectively_gen ------ 0.0% 99.3% 1 6.684s +─ReflectiveTactics.do_reflective_pipelin 0.0% 92.8% 1 6.248s +─ReflectiveTactics.solve_side_conditions 0.0% 92.0% 1 6.192s +─ReflectiveTactics.do_reify ------------ -0.0% 60.3% 1 4.060s +─Reify.Reify_rhs_gen ------------------- 1.5% 59.6% 1 4.012s +─Reify.do_reify_abs_goal --------------- 42.4% 42.7% 2 2.876s +─Reify.do_reifyf_goal ------------------ 41.3% 41.7% 129 2.804s +─ReflectiveTactics.solve_post_reified_si 0.6% 31.7% 1 2.132s +─UnifyAbstractReflexivity.unify_transfor 21.7% 25.8% 7 0.424s +─eexact -------------------------------- 13.7% 13.7% 131 0.036s +─Glue.refine_to_reflective_glue' ------- 0.0% 6.5% 1 0.436s +─prove_interp_compile_correct ---------- 0.0% 5.1% 1 0.344s +─ReflectiveTactics.unify_abstract_cbv_in 3.4% 5.0% 1 0.336s +─rewrite ?EtaInterp.InterpExprEta ------ 4.7% 4.7% 1 0.316s +─unify (constr) (constr) --------------- 4.6% 4.6% 6 0.100s +─Glue.zrange_to_reflective ------------- 0.0% 4.2% 1 0.280s +─Glue.zrange_to_reflective_goal -------- 2.4% 3.3% 1 0.220s +─Reify.transitivity_tt ----------------- 0.1% 2.6% 2 0.116s +─rewrite H ----------------------------- 2.6% 2.6% 1 0.172s +─tac ----------------------------------- 1.5% 2.3% 2 0.156s +─reflexivity --------------------------- 2.3% 2.3% 7 0.052s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_freeze --------------------- 0.0% 100.0% 1 6.732s +└Pipeline.refine_reflectively_gen ------ 0.0% 99.3% 1 6.684s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 92.8% 1 6.248s + │└ReflectiveTactics.solve_side_conditio 0.0% 92.0% 1 6.192s + │ ├─ReflectiveTactics.do_reify -------- -0.0% 60.3% 1 4.060s + │ │└Reify.Reify_rhs_gen --------------- 1.5% 59.6% 1 4.012s + │ │ ├─Reify.do_reify_abs_goal --------- 42.4% 42.7% 2 2.876s + │ │ │└Reify.do_reifyf_goal ------------ 41.3% 41.7% 129 2.804s + │ │ │└eexact -------------------------- 13.0% 13.0% 129 0.036s + │ │ ├─prove_interp_compile_correct ---- 0.0% 5.1% 1 0.344s + │ │ │└rewrite ?EtaInterp.InterpExprEta 4.7% 4.7% 1 0.316s + │ │ ├─Reify.transitivity_tt ----------- 0.1% 2.6% 2 0.116s + │ │ ├─rewrite H ----------------------- 2.6% 2.6% 1 0.172s + │ │ └─tac ----------------------------- 1.5% 2.3% 1 0.156s + │ └─ReflectiveTactics.solve_post_reifie 0.6% 31.7% 1 2.132s + │ ├─UnifyAbstractReflexivity.unify_tr 21.7% 25.8% 7 0.424s + │ │└unify (constr) (constr) --------- 3.1% 3.1% 5 0.084s + │ └─ReflectiveTactics.unify_abstract_ 3.4% 5.0% 1 0.336s + └─Glue.refine_to_reflective_glue' ----- 0.0% 6.5% 1 0.436s + └Glue.zrange_to_reflective ----------- 0.0% 4.2% 1 0.280s + └Glue.zrange_to_reflective_goal ------ 2.4% 3.3% 1 0.220s + +src/Specific/X25519/C64/freeze (real: 34.35, user: 31.50, sys: 0.24, mem: 828104 ko) +COQC src/Specific/NISTP256/AMD64/feadd.v +Finished transaction in 8.784 secs (8.176u,0.011s) (successful) +total time: 8.140s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 52.4% 1 4.268s +─synthesize_montgomery ----------------- 0.0% 47.6% 1 3.872s +─ReflectiveTactics.do_reflective_pipelin 0.0% 43.8% 1 3.568s +─ReflectiveTactics.solve_side_conditions 0.0% 43.2% 1 3.520s +─IntegrationTestTemporaryMiscCommon.fact 1.4% 23.6% 1 1.924s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 22.1% 1 1.796s +─ReflectiveTactics.do_reify ------------ 0.1% 21.7% 1 1.768s +─ReflectiveTactics.solve_post_reified_si 0.6% 21.5% 1 1.752s +─Reify.Reify_rhs_gen ------------------- 1.0% 20.9% 1 1.704s +─op_sig_side_conditions_t -------------- 0.0% 20.0% 1 1.624s +─DestructHyps.do_all_matches_then ------ 0.0% 20.0% 8 0.244s +─DestructHyps.do_one_match_then -------- 0.7% 19.9% 44 0.052s +─do_tac -------------------------------- 0.0% 19.2% 36 0.052s +─destruct H ---------------------------- 19.2% 19.2% 36 0.052s +─rewrite <- (lem : lemT) by by_tac ltac: 0.2% 17.3% 1 1.408s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 17.3% 1 1.408s +─by_tac -------------------------------- 0.0% 17.1% 4 0.504s +─rewrite <- (ZRange.is_bounded_by_None_r 16.7% 16.7% 8 0.344s +─UnifyAbstractReflexivity.unify_transfor 13.3% 16.1% 7 0.360s +─Reify.do_reify_abs_goal --------------- 9.9% 10.1% 2 0.820s +─Reify.do_reifyf_goal ------------------ 9.1% 9.3% 93 0.748s +─Glue.refine_to_reflective_glue' ------- 0.0% 8.6% 1 0.700s +─Glue.zrange_to_reflective ------------- 0.0% 5.3% 1 0.432s +─IntegrationTestTemporaryMiscCommon.do_s 0.0% 4.8% 1 0.388s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.9% 4.6% 3 0.368s +─ReflectiveTactics.unify_abstract_cbv_in 3.3% 4.5% 1 0.368s +─Glue.zrange_to_reflective_goal -------- 2.6% 4.0% 1 0.324s +─k ------------------------------------- 3.5% 3.6% 1 0.296s +─unify (constr) (constr) --------------- 3.3% 3.3% 8 0.092s +─rewrite H ----------------------------- 2.6% 2.6% 2 0.196s +─eexact -------------------------------- 2.6% 2.6% 95 0.024s +─prove_interp_compile_correct ---------- 0.0% 2.5% 1 0.204s +─apply (fun f => MapProjections.proj2 2.4% 2.4% 2 0.120s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 52.4% 1 4.268s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 43.8% 1 3.568s + │└ReflectiveTactics.solve_side_conditio 0.0% 43.2% 1 3.520s + │ ├─ReflectiveTactics.do_reify -------- 0.1% 21.7% 1 1.768s + │ │└Reify.Reify_rhs_gen --------------- 1.0% 20.9% 1 1.704s + │ │ ├─Reify.do_reify_abs_goal --------- 9.9% 10.1% 2 0.820s + │ │ │└Reify.do_reifyf_goal ------------ 9.1% 9.3% 93 0.748s + │ │ │└eexact -------------------------- 2.3% 2.3% 93 0.024s + │ │ ├─prove_interp_compile_correct ---- 0.0% 2.5% 1 0.204s + │ │ └─rewrite H ----------------------- 2.4% 2.4% 1 0.196s + │ └─ReflectiveTactics.solve_post_reifie 0.6% 21.5% 1 1.752s + │ ├─UnifyAbstractReflexivity.unify_tr 13.3% 16.1% 7 0.360s + │ │└unify (constr) (constr) --------- 2.2% 2.2% 5 0.064s + │ └─ReflectiveTactics.unify_abstract_ 3.3% 4.5% 1 0.368s + └─Glue.refine_to_reflective_glue' ----- 0.0% 8.6% 1 0.700s + └Glue.zrange_to_reflective ----------- 0.0% 5.3% 1 0.432s + └Glue.zrange_to_reflective_goal ------ 2.6% 4.0% 1 0.324s +─synthesize_montgomery ----------------- 0.0% 47.6% 1 3.872s + ├─IntegrationTestTemporaryMiscCommon.fa 1.4% 23.6% 1 1.924s + │└op_sig_side_conditions_t ------------ 0.0% 20.0% 1 1.624s + │ ├─DestructHyps.do_all_matches_then -- 0.0% 11.4% 4 0.244s + │ │└DestructHyps.do_one_match_then ---- 0.3% 11.4% 24 0.052s + │ │└do_tac ---------------------------- 0.0% 11.1% 20 0.052s + │ │└destruct H ------------------------ 11.1% 11.1% 20 0.052s + │ └─rewrite <- (ZRange.is_bounded_by_No 8.4% 8.4% 4 0.328s + └─IntegrationTestTemporaryMiscCommon.do 0.0% 22.1% 1 1.796s + ├─IntegrationTestTemporaryMiscCommon. 0.0% 17.3% 1 1.408s + │└rewrite <- (lem : lemT) by by_tac l 0.2% 17.3% 1 1.408s + │└by_tac ---------------------------- 0.0% 17.1% 4 0.504s + │ ├─DestructHyps.do_all_matches_then 0.0% 8.6% 4 0.184s + │ │└DestructHyps.do_one_match_then -- 0.3% 8.5% 20 0.052s + │ │└do_tac -------------------------- 0.0% 8.2% 16 0.052s + │ │└destruct H ---------------------- 8.2% 8.2% 16 0.052s + │ └─rewrite <- (ZRange.is_bounded_by_ 8.3% 8.3% 4 0.344s + └─IntegrationTestTemporaryMiscCommon. 0.0% 4.8% 1 0.388s + └<Crypto.Util.Tactics.MoveLetIn.with 0.9% 4.6% 3 0.368s + └k --------------------------------- 3.5% 3.6% 1 0.296s + +Finished transaction in 13.363 secs (12.516u,0.008s) (successful) +Closed under the global context +total time: 8.140s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 52.4% 1 4.268s +─synthesize_montgomery ----------------- 0.0% 47.6% 1 3.872s +─ReflectiveTactics.do_reflective_pipelin 0.0% 43.8% 1 3.568s +─ReflectiveTactics.solve_side_conditions 0.0% 43.2% 1 3.520s +─IntegrationTestTemporaryMiscCommon.fact 1.4% 23.6% 1 1.924s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 22.1% 1 1.796s +─ReflectiveTactics.do_reify ------------ 0.1% 21.7% 1 1.768s +─ReflectiveTactics.solve_post_reified_si 0.6% 21.5% 1 1.752s +─Reify.Reify_rhs_gen ------------------- 1.0% 20.9% 1 1.704s +─op_sig_side_conditions_t -------------- 0.0% 20.0% 1 1.624s +─DestructHyps.do_all_matches_then ------ 0.0% 20.0% 8 0.244s +─DestructHyps.do_one_match_then -------- 0.7% 19.9% 44 0.052s +─do_tac -------------------------------- 0.0% 19.2% 36 0.052s +─destruct H ---------------------------- 19.2% 19.2% 36 0.052s +─rewrite <- (lem : lemT) by by_tac ltac: 0.2% 17.3% 1 1.408s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 17.3% 1 1.408s +─by_tac -------------------------------- 0.0% 17.1% 4 0.504s +─rewrite <- (ZRange.is_bounded_by_None_r 16.7% 16.7% 8 0.344s +─UnifyAbstractReflexivity.unify_transfor 13.3% 16.1% 7 0.360s +─Reify.do_reify_abs_goal --------------- 9.9% 10.1% 2 0.820s +─Reify.do_reifyf_goal ------------------ 9.1% 9.3% 93 0.748s +─Glue.refine_to_reflective_glue' ------- 0.0% 8.6% 1 0.700s +─Glue.zrange_to_reflective ------------- 0.0% 5.3% 1 0.432s +─IntegrationTestTemporaryMiscCommon.do_s 0.0% 4.8% 1 0.388s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.9% 4.6% 3 0.368s +─ReflectiveTactics.unify_abstract_cbv_in 3.3% 4.5% 1 0.368s +─Glue.zrange_to_reflective_goal -------- 2.6% 4.0% 1 0.324s +─k ------------------------------------- 3.5% 3.6% 1 0.296s +─unify (constr) (constr) --------------- 3.3% 3.3% 8 0.092s +─rewrite H ----------------------------- 2.6% 2.6% 2 0.196s +─eexact -------------------------------- 2.6% 2.6% 95 0.024s +─prove_interp_compile_correct ---------- 0.0% 2.5% 1 0.204s +─apply (fun f => MapProjections.proj2 2.4% 2.4% 2 0.120s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 52.4% 1 4.268s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 43.8% 1 3.568s + │└ReflectiveTactics.solve_side_conditio 0.0% 43.2% 1 3.520s + │ ├─ReflectiveTactics.do_reify -------- 0.1% 21.7% 1 1.768s + │ │└Reify.Reify_rhs_gen --------------- 1.0% 20.9% 1 1.704s + │ │ ├─Reify.do_reify_abs_goal --------- 9.9% 10.1% 2 0.820s + │ │ │└Reify.do_reifyf_goal ------------ 9.1% 9.3% 93 0.748s + │ │ │└eexact -------------------------- 2.3% 2.3% 93 0.024s + │ │ ├─prove_interp_compile_correct ---- 0.0% 2.5% 1 0.204s + │ │ └─rewrite H ----------------------- 2.4% 2.4% 1 0.196s + │ └─ReflectiveTactics.solve_post_reifie 0.6% 21.5% 1 1.752s + │ ├─UnifyAbstractReflexivity.unify_tr 13.3% 16.1% 7 0.360s + │ │└unify (constr) (constr) --------- 2.2% 2.2% 5 0.064s + │ └─ReflectiveTactics.unify_abstract_ 3.3% 4.5% 1 0.368s + └─Glue.refine_to_reflective_glue' ----- 0.0% 8.6% 1 0.700s + └Glue.zrange_to_reflective ----------- 0.0% 5.3% 1 0.432s + └Glue.zrange_to_reflective_goal ------ 2.6% 4.0% 1 0.324s +─synthesize_montgomery ----------------- 0.0% 47.6% 1 3.872s + ├─IntegrationTestTemporaryMiscCommon.fa 1.4% 23.6% 1 1.924s + │└op_sig_side_conditions_t ------------ 0.0% 20.0% 1 1.624s + │ ├─DestructHyps.do_all_matches_then -- 0.0% 11.4% 4 0.244s + │ │└DestructHyps.do_one_match_then ---- 0.3% 11.4% 24 0.052s + │ │└do_tac ---------------------------- 0.0% 11.1% 20 0.052s + │ │└destruct H ------------------------ 11.1% 11.1% 20 0.052s + │ └─rewrite <- (ZRange.is_bounded_by_No 8.4% 8.4% 4 0.328s + └─IntegrationTestTemporaryMiscCommon.do 0.0% 22.1% 1 1.796s + ├─IntegrationTestTemporaryMiscCommon. 0.0% 17.3% 1 1.408s + │└rewrite <- (lem : lemT) by by_tac l 0.2% 17.3% 1 1.408s + │└by_tac ---------------------------- 0.0% 17.1% 4 0.504s + │ ├─DestructHyps.do_all_matches_then 0.0% 8.6% 4 0.184s + │ │└DestructHyps.do_one_match_then -- 0.3% 8.5% 20 0.052s + │ │└do_tac -------------------------- 0.0% 8.2% 16 0.052s + │ │└destruct H ---------------------- 8.2% 8.2% 16 0.052s + │ └─rewrite <- (ZRange.is_bounded_by_ 8.3% 8.3% 4 0.344s + └─IntegrationTestTemporaryMiscCommon. 0.0% 4.8% 1 0.388s + └<Crypto.Util.Tactics.MoveLetIn.with 0.9% 4.6% 3 0.368s + └k --------------------------------- 3.5% 3.6% 1 0.296s + +src/Specific/NISTP256/AMD64/feadd (real: 38.19, user: 35.40, sys: 0.30, mem: 799216 ko) +COQC src/Specific/NISTP256/AMD64/fenz.v +Finished transaction in 6.356 secs (5.82u,0.004s) (successful) +total time: 5.800s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_nonzero -------------------- 0.0% 100.0% 1 5.800s +─IntegrationTestTemporaryMiscCommon.nonz 0.2% 85.5% 1 4.960s +─destruct (Decidable.dec x), (Decidable. 37.4% 37.4% 1 2.168s +─destruct (Decidable.dec x) as [H| H] -- 22.0% 22.0% 1 1.276s +─Pipeline.refine_reflectively_gen ------ 0.0% 14.5% 1 0.840s +─ReflectiveTactics.do_reflective_pipelin 0.0% 10.9% 1 0.632s +─ReflectiveTactics.solve_side_conditions 0.0% 10.6% 1 0.612s +─ReflectiveTactics.solve_post_reified_si 0.3% 8.5% 1 0.492s +─IntegrationTestTemporaryMiscCommon.op_s 0.1% 8.1% 2 0.368s +─rewrite <- (ZRange.is_bounded_by_None_r 5.2% 5.2% 2 0.288s +─UnifyAbstractReflexivity.unify_transfor 3.4% 4.3% 7 0.076s +─ReflectiveTactics.unify_abstract_cbv_in 2.8% 3.8% 1 0.220s +─Glue.refine_to_reflective_glue' ------- 0.1% 3.6% 1 0.208s +─rewrite H' ---------------------------- 3.4% 3.4% 1 0.200s +─generalize dependent (constr) --------- 3.0% 3.0% 4 0.060s +─congruence ---------------------------- 2.8% 2.8% 1 0.160s +─do_tac -------------------------------- 0.0% 2.6% 4 0.044s +─destruct H ---------------------------- 2.6% 2.6% 4 0.044s +─IntegrationTestTemporaryMiscCommon.do_s 0.1% 2.6% 1 0.152s +─DestructHyps.do_one_match_then -------- 0.0% 2.6% 6 0.044s +─DestructHyps.do_all_matches_then ------ 0.0% 2.6% 2 0.076s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.4% 2.5% 3 0.140s +─Glue.zrange_to_reflective ------------- 0.0% 2.2% 1 0.128s +─rewrite H ----------------------------- 1.9% 2.1% 3 0.112s +─ReflectiveTactics.do_reify ------------ 0.0% 2.1% 1 0.120s +─k ------------------------------------- 1.9% 2.0% 1 0.116s +─Reify.Reify_rhs_gen ------------------- 0.1% 2.0% 1 0.116s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_nonzero -------------------- 0.0% 100.0% 1 5.800s + ├─IntegrationTestTemporaryMiscCommon.no 0.2% 85.5% 1 4.960s + │ ├─destruct (Decidable.dec x), (Decida 37.4% 37.4% 1 2.168s + │ ├─destruct (Decidable.dec x) as [H| H 22.0% 22.0% 1 1.276s + │ ├─IntegrationTestTemporaryMiscCommon. 0.1% 8.1% 2 0.368s + │ │ ├─rewrite <- (ZRange.is_bounded_by_ 5.2% 5.2% 2 0.288s + │ │ └─DestructHyps.do_all_matches_then 0.0% 2.6% 2 0.076s + │ │ └DestructHyps.do_one_match_then -- 0.0% 2.6% 6 0.044s + │ │ └do_tac -------------------------- 0.0% 2.6% 4 0.044s + │ │ └destruct H ---------------------- 2.6% 2.6% 4 0.044s + │ ├─rewrite H' ------------------------ 3.4% 3.4% 1 0.200s + │ ├─generalize dependent (constr) ----- 3.0% 3.0% 4 0.060s + │ ├─congruence ------------------------ 2.8% 2.8% 1 0.160s + │ ├─IntegrationTestTemporaryMiscCommon. 0.1% 2.6% 1 0.152s + │ │└<Crypto.Util.Tactics.MoveLetIn.with 0.4% 2.5% 3 0.140s + │ │└k --------------------------------- 1.9% 2.0% 1 0.116s + │ └─rewrite H ------------------------- 1.7% 2.0% 2 0.112s + └─Pipeline.refine_reflectively_gen ---- 0.0% 14.5% 1 0.840s + ├─ReflectiveTactics.do_reflective_pip 0.0% 10.9% 1 0.632s + │└ReflectiveTactics.solve_side_condit 0.0% 10.6% 1 0.612s + │ ├─ReflectiveTactics.solve_post_reif 0.3% 8.5% 1 0.492s + │ │ ├─UnifyAbstractReflexivity.unify_ 3.4% 4.3% 7 0.076s + │ │ └─ReflectiveTactics.unify_abstrac 2.8% 3.8% 1 0.220s + │ └─ReflectiveTactics.do_reify ------ 0.0% 2.1% 1 0.120s + │ └Reify.Reify_rhs_gen ------------- 0.1% 2.0% 1 0.116s + └─Glue.refine_to_reflective_glue' --- 0.1% 3.6% 1 0.208s + └Glue.zrange_to_reflective --------- 0.0% 2.2% 1 0.128s + +Finished transaction in 6.657 secs (6.299u,0.s) (successful) +Closed under the global context +total time: 5.800s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_nonzero -------------------- 0.0% 100.0% 1 5.800s +─IntegrationTestTemporaryMiscCommon.nonz 0.2% 85.5% 1 4.960s +─destruct (Decidable.dec x), (Decidable. 37.4% 37.4% 1 2.168s +─destruct (Decidable.dec x) as [H| H] -- 22.0% 22.0% 1 1.276s +─Pipeline.refine_reflectively_gen ------ 0.0% 14.5% 1 0.840s +─ReflectiveTactics.do_reflective_pipelin 0.0% 10.9% 1 0.632s +─ReflectiveTactics.solve_side_conditions 0.0% 10.6% 1 0.612s +─ReflectiveTactics.solve_post_reified_si 0.3% 8.5% 1 0.492s +─IntegrationTestTemporaryMiscCommon.op_s 0.1% 8.1% 2 0.368s +─rewrite <- (ZRange.is_bounded_by_None_r 5.2% 5.2% 2 0.288s +─UnifyAbstractReflexivity.unify_transfor 3.4% 4.3% 7 0.076s +─ReflectiveTactics.unify_abstract_cbv_in 2.8% 3.8% 1 0.220s +─Glue.refine_to_reflective_glue' ------- 0.1% 3.6% 1 0.208s +─rewrite H' ---------------------------- 3.4% 3.4% 1 0.200s +─generalize dependent (constr) --------- 3.0% 3.0% 4 0.060s +─congruence ---------------------------- 2.8% 2.8% 1 0.160s +─do_tac -------------------------------- 0.0% 2.6% 4 0.044s +─destruct H ---------------------------- 2.6% 2.6% 4 0.044s +─IntegrationTestTemporaryMiscCommon.do_s 0.1% 2.6% 1 0.152s +─DestructHyps.do_one_match_then -------- 0.0% 2.6% 6 0.044s +─DestructHyps.do_all_matches_then ------ 0.0% 2.6% 2 0.076s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.4% 2.5% 3 0.140s +─Glue.zrange_to_reflective ------------- 0.0% 2.2% 1 0.128s +─rewrite H ----------------------------- 1.9% 2.1% 3 0.112s +─ReflectiveTactics.do_reify ------------ 0.0% 2.1% 1 0.120s +─k ------------------------------------- 1.9% 2.0% 1 0.116s +─Reify.Reify_rhs_gen ------------------- 0.1% 2.0% 1 0.116s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_nonzero -------------------- 0.0% 100.0% 1 5.800s + ├─IntegrationTestTemporaryMiscCommon.no 0.2% 85.5% 1 4.960s + │ ├─destruct (Decidable.dec x), (Decida 37.4% 37.4% 1 2.168s + │ ├─destruct (Decidable.dec x) as [H| H 22.0% 22.0% 1 1.276s + │ ├─IntegrationTestTemporaryMiscCommon. 0.1% 8.1% 2 0.368s + │ │ ├─rewrite <- (ZRange.is_bounded_by_ 5.2% 5.2% 2 0.288s + │ │ └─DestructHyps.do_all_matches_then 0.0% 2.6% 2 0.076s + │ │ └DestructHyps.do_one_match_then -- 0.0% 2.6% 6 0.044s + │ │ └do_tac -------------------------- 0.0% 2.6% 4 0.044s + │ │ └destruct H ---------------------- 2.6% 2.6% 4 0.044s + │ ├─rewrite H' ------------------------ 3.4% 3.4% 1 0.200s + │ ├─generalize dependent (constr) ----- 3.0% 3.0% 4 0.060s + │ ├─congruence ------------------------ 2.8% 2.8% 1 0.160s + │ ├─IntegrationTestTemporaryMiscCommon. 0.1% 2.6% 1 0.152s + │ │└<Crypto.Util.Tactics.MoveLetIn.with 0.4% 2.5% 3 0.140s + │ │└k --------------------------------- 1.9% 2.0% 1 0.116s + │ └─rewrite H ------------------------- 1.7% 2.0% 2 0.112s + └─Pipeline.refine_reflectively_gen ---- 0.0% 14.5% 1 0.840s + ├─ReflectiveTactics.do_reflective_pip 0.0% 10.9% 1 0.632s + │└ReflectiveTactics.solve_side_condit 0.0% 10.6% 1 0.612s + │ ├─ReflectiveTactics.solve_post_reif 0.3% 8.5% 1 0.492s + │ │ ├─UnifyAbstractReflexivity.unify_ 3.4% 4.3% 7 0.076s + │ │ └─ReflectiveTactics.unify_abstrac 2.8% 3.8% 1 0.220s + │ └─ReflectiveTactics.do_reify ------ 0.0% 2.1% 1 0.120s + │ └Reify.Reify_rhs_gen ------------- 0.1% 2.0% 1 0.116s + └─Glue.refine_to_reflective_glue' --- 0.1% 3.6% 1 0.208s + └Glue.zrange_to_reflective --------- 0.0% 2.2% 1 0.128s + +src/Specific/NISTP256/AMD64/fenz (real: 27.81, user: 25.50, sys: 0.22, mem: 756080 ko) +COQC src/Specific/NISTP256/AMD64/feopp.v +Finished transaction in 7.73 secs (7.112u,0.008s) (successful) +total time: 7.072s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 62.5% 1 4.420s +─IntegrationTestTemporaryMiscCommon.fact 18.7% 51.6% 1 3.648s +─Pipeline.refine_reflectively_gen ------ 0.0% 37.5% 1 2.652s +─ReflectiveTactics.do_reflective_pipelin 0.0% 32.6% 1 2.308s +─ReflectiveTactics.solve_side_conditions 0.0% 32.2% 1 2.276s +─reflexivity --------------------------- 24.8% 24.8% 8 1.700s +─ReflectiveTactics.solve_post_reified_si 0.5% 18.5% 1 1.308s +─ReflectiveTactics.do_reify ------------ 0.0% 13.7% 1 0.968s +─UnifyAbstractReflexivity.unify_transfor 11.2% 13.6% 7 0.284s +─Reify.Reify_rhs_gen ------------------- 0.6% 13.4% 1 0.948s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 9.7% 1 0.684s +─rewrite <- (ZRange.is_bounded_by_None_r 9.0% 9.0% 4 0.328s +─op_sig_side_conditions_t -------------- 0.0% 7.8% 1 0.552s +─rewrite <- (lem : lemT) by by_tac ltac: 0.1% 7.4% 1 0.520s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 7.4% 1 0.520s +─by_tac -------------------------------- 0.0% 7.2% 2 0.404s +─Reify.do_reify_abs_goal --------------- 7.1% 7.2% 2 0.512s +─Reify.do_reifyf_goal ------------------ 6.6% 6.7% 62 0.472s +─DestructHyps.do_one_match_then -------- 0.2% 5.8% 14 0.048s +─DestructHyps.do_all_matches_then ------ 0.0% 5.8% 4 0.124s +─do_tac -------------------------------- 0.0% 5.6% 10 0.048s +─destruct H ---------------------------- 5.6% 5.6% 10 0.048s +─Glue.refine_to_reflective_glue' ------- 0.0% 4.9% 1 0.344s +─ReflectiveTactics.unify_abstract_cbv_in 2.9% 4.2% 1 0.300s +─Glue.zrange_to_reflective ------------- 0.0% 3.3% 1 0.232s +─unify (constr) (constr) --------------- 3.2% 3.2% 7 0.088s +─Glue.zrange_to_reflective_goal -------- 1.9% 2.6% 1 0.184s +─IntegrationTestTemporaryMiscCommon.do_s 0.0% 2.3% 1 0.164s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.4% 2.2% 3 0.152s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 62.5% 1 4.420s + ├─IntegrationTestTemporaryMiscCommon.fa 18.7% 51.6% 1 3.648s + │ ├─reflexivity ----------------------- 24.0% 24.0% 1 1.700s + │ └─op_sig_side_conditions_t ---------- 0.0% 7.8% 1 0.552s + │ ├─rewrite <- (ZRange.is_bounded_by_ 4.2% 4.2% 2 0.284s + │ └─DestructHyps.do_all_matches_then 0.0% 3.5% 2 0.124s + │ └DestructHyps.do_one_match_then -- 0.2% 3.5% 8 0.044s + │ └do_tac -------------------------- 0.0% 3.3% 6 0.040s + │ └destruct H ---------------------- 3.3% 3.3% 6 0.040s + └─IntegrationTestTemporaryMiscCommon.do 0.0% 9.7% 1 0.684s + ├─IntegrationTestTemporaryMiscCommon. 0.0% 7.4% 1 0.520s + │└rewrite <- (lem : lemT) by by_tac l 0.1% 7.4% 1 0.520s + │└by_tac ---------------------------- 0.0% 7.2% 2 0.404s + │ ├─rewrite <- (ZRange.is_bounded_by_ 4.8% 4.8% 2 0.328s + │ └─DestructHyps.do_all_matches_then 0.0% 2.3% 2 0.088s + │ └DestructHyps.do_one_match_then -- 0.0% 2.3% 6 0.048s + │ └do_tac -------------------------- 0.0% 2.3% 4 0.048s + │ └destruct H ---------------------- 2.3% 2.3% 4 0.048s + └─IntegrationTestTemporaryMiscCommon. 0.0% 2.3% 1 0.164s + └<Crypto.Util.Tactics.MoveLetIn.with 0.4% 2.2% 3 0.152s +─Pipeline.refine_reflectively_gen ------ 0.0% 37.5% 1 2.652s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 32.6% 1 2.308s + │└ReflectiveTactics.solve_side_conditio 0.0% 32.2% 1 2.276s + │ ├─ReflectiveTactics.solve_post_reifie 0.5% 18.5% 1 1.308s + │ │ ├─UnifyAbstractReflexivity.unify_tr 11.2% 13.6% 7 0.284s + │ │ └─ReflectiveTactics.unify_abstract_ 2.9% 4.2% 1 0.300s + │ └─ReflectiveTactics.do_reify -------- 0.0% 13.7% 1 0.968s + │ └Reify.Reify_rhs_gen --------------- 0.6% 13.4% 1 0.948s + │ └Reify.do_reify_abs_goal ----------- 7.1% 7.2% 2 0.512s + │ └Reify.do_reifyf_goal -------------- 6.6% 6.7% 62 0.472s + └─Glue.refine_to_reflective_glue' ----- 0.0% 4.9% 1 0.344s + └Glue.zrange_to_reflective ----------- 0.0% 3.3% 1 0.232s + └Glue.zrange_to_reflective_goal ------ 1.9% 2.6% 1 0.184s + +Finished transaction in 7.732 secs (7.1u,0.003s) (successful) +Closed under the global context +total time: 7.072s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 62.5% 1 4.420s +─IntegrationTestTemporaryMiscCommon.fact 18.7% 51.6% 1 3.648s +─Pipeline.refine_reflectively_gen ------ 0.0% 37.5% 1 2.652s +─ReflectiveTactics.do_reflective_pipelin 0.0% 32.6% 1 2.308s +─ReflectiveTactics.solve_side_conditions 0.0% 32.2% 1 2.276s +─reflexivity --------------------------- 24.8% 24.8% 8 1.700s +─ReflectiveTactics.solve_post_reified_si 0.5% 18.5% 1 1.308s +─ReflectiveTactics.do_reify ------------ 0.0% 13.7% 1 0.968s +─UnifyAbstractReflexivity.unify_transfor 11.2% 13.6% 7 0.284s +─Reify.Reify_rhs_gen ------------------- 0.6% 13.4% 1 0.948s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 9.7% 1 0.684s +─rewrite <- (ZRange.is_bounded_by_None_r 9.0% 9.0% 4 0.328s +─op_sig_side_conditions_t -------------- 0.0% 7.8% 1 0.552s +─rewrite <- (lem : lemT) by by_tac ltac: 0.1% 7.4% 1 0.520s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 7.4% 1 0.520s +─by_tac -------------------------------- 0.0% 7.2% 2 0.404s +─Reify.do_reify_abs_goal --------------- 7.1% 7.2% 2 0.512s +─Reify.do_reifyf_goal ------------------ 6.6% 6.7% 62 0.472s +─DestructHyps.do_one_match_then -------- 0.2% 5.8% 14 0.048s +─DestructHyps.do_all_matches_then ------ 0.0% 5.8% 4 0.124s +─do_tac -------------------------------- 0.0% 5.6% 10 0.048s +─destruct H ---------------------------- 5.6% 5.6% 10 0.048s +─Glue.refine_to_reflective_glue' ------- 0.0% 4.9% 1 0.344s +─ReflectiveTactics.unify_abstract_cbv_in 2.9% 4.2% 1 0.300s +─Glue.zrange_to_reflective ------------- 0.0% 3.3% 1 0.232s +─unify (constr) (constr) --------------- 3.2% 3.2% 7 0.088s +─Glue.zrange_to_reflective_goal -------- 1.9% 2.6% 1 0.184s +─IntegrationTestTemporaryMiscCommon.do_s 0.0% 2.3% 1 0.164s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.4% 2.2% 3 0.152s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 62.5% 1 4.420s + ├─IntegrationTestTemporaryMiscCommon.fa 18.7% 51.6% 1 3.648s + │ ├─reflexivity ----------------------- 24.0% 24.0% 1 1.700s + │ └─op_sig_side_conditions_t ---------- 0.0% 7.8% 1 0.552s + │ ├─rewrite <- (ZRange.is_bounded_by_ 4.2% 4.2% 2 0.284s + │ └─DestructHyps.do_all_matches_then 0.0% 3.5% 2 0.124s + │ └DestructHyps.do_one_match_then -- 0.2% 3.5% 8 0.044s + │ └do_tac -------------------------- 0.0% 3.3% 6 0.040s + │ └destruct H ---------------------- 3.3% 3.3% 6 0.040s + └─IntegrationTestTemporaryMiscCommon.do 0.0% 9.7% 1 0.684s + ├─IntegrationTestTemporaryMiscCommon. 0.0% 7.4% 1 0.520s + │└rewrite <- (lem : lemT) by by_tac l 0.1% 7.4% 1 0.520s + │└by_tac ---------------------------- 0.0% 7.2% 2 0.404s + │ ├─rewrite <- (ZRange.is_bounded_by_ 4.8% 4.8% 2 0.328s + │ └─DestructHyps.do_all_matches_then 0.0% 2.3% 2 0.088s + │ └DestructHyps.do_one_match_then -- 0.0% 2.3% 6 0.048s + │ └do_tac -------------------------- 0.0% 2.3% 4 0.048s + │ └destruct H ---------------------- 2.3% 2.3% 4 0.048s + └─IntegrationTestTemporaryMiscCommon. 0.0% 2.3% 1 0.164s + └<Crypto.Util.Tactics.MoveLetIn.with 0.4% 2.2% 3 0.152s +─Pipeline.refine_reflectively_gen ------ 0.0% 37.5% 1 2.652s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 32.6% 1 2.308s + │└ReflectiveTactics.solve_side_conditio 0.0% 32.2% 1 2.276s + │ ├─ReflectiveTactics.solve_post_reifie 0.5% 18.5% 1 1.308s + │ │ ├─UnifyAbstractReflexivity.unify_tr 11.2% 13.6% 7 0.284s + │ │ └─ReflectiveTactics.unify_abstract_ 2.9% 4.2% 1 0.300s + │ └─ReflectiveTactics.do_reify -------- 0.0% 13.7% 1 0.968s + │ └Reify.Reify_rhs_gen --------------- 0.6% 13.4% 1 0.948s + │ └Reify.do_reify_abs_goal ----------- 7.1% 7.2% 2 0.512s + │ └Reify.do_reifyf_goal -------------- 6.6% 6.7% 62 0.472s + └─Glue.refine_to_reflective_glue' ----- 0.0% 4.9% 1 0.344s + └Glue.zrange_to_reflective ----------- 0.0% 3.3% 1 0.232s + └Glue.zrange_to_reflective_goal ------ 1.9% 2.6% 1 0.184s + +src/Specific/NISTP256/AMD64/feopp (real: 31.00, user: 28.51, sys: 0.20, mem: 765208 ko) +COQC src/Specific/NISTP256/AMD64/fesub.v +Finished transaction in 12.996 secs (12.091u,0.004s) (successful) +total time: 12.048s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 66.1% 1 7.964s +─IntegrationTestTemporaryMiscCommon.fact 16.2% 50.9% 1 6.128s +─Pipeline.refine_reflectively_gen ------ 0.0% 33.9% 1 4.084s +─ReflectiveTactics.do_reflective_pipelin 0.0% 28.3% 1 3.404s +─ReflectiveTactics.solve_side_conditions 0.0% 27.8% 1 3.352s +─reflexivity --------------------------- 21.7% 21.7% 8 2.480s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 14.1% 1 1.704s +─ReflectiveTactics.solve_post_reified_si 0.4% 14.1% 1 1.696s +─ReflectiveTactics.do_reify ------------ 0.0% 13.7% 1 1.656s +─Reify.Reify_rhs_gen ------------------- 0.9% 13.2% 1 1.592s +─DestructHyps.do_all_matches_then ------ 0.0% 12.9% 8 0.232s +─DestructHyps.do_one_match_then -------- 0.6% 12.9% 44 0.052s +─op_sig_side_conditions_t -------------- 0.0% 12.7% 1 1.528s +─do_tac -------------------------------- 0.0% 12.3% 36 0.048s +─destruct H ---------------------------- 12.3% 12.3% 36 0.048s +─rewrite <- (lem : lemT) by by_tac ltac: 0.1% 11.2% 1 1.352s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 11.2% 1 1.352s +─by_tac -------------------------------- 0.0% 11.1% 4 0.476s +─UnifyAbstractReflexivity.unify_transfor 8.8% 10.6% 7 0.344s +─rewrite <- (ZRange.is_bounded_by_None_r 10.5% 10.5% 8 0.316s +─Reify.do_reify_abs_goal --------------- 6.0% 6.1% 2 0.732s +─Glue.refine_to_reflective_glue' ------- 0.0% 5.6% 1 0.680s +─Reify.do_reifyf_goal ------------------ 5.4% 5.5% 80 0.660s +─Glue.zrange_to_reflective ------------- 0.0% 3.6% 1 0.428s +─ReflectiveTactics.unify_abstract_cbv_in 2.2% 3.0% 1 0.360s +─IntegrationTestTemporaryMiscCommon.do_s 0.0% 2.9% 1 0.348s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.5% 2.8% 3 0.332s +─Glue.zrange_to_reflective_goal -------- 1.7% 2.6% 1 0.316s +─k ------------------------------------- 2.1% 2.2% 1 0.268s +─unify (constr) (constr) --------------- 2.1% 2.1% 8 0.092s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 66.1% 1 7.964s + ├─IntegrationTestTemporaryMiscCommon.fa 16.2% 50.9% 1 6.128s + │ ├─reflexivity ----------------------- 20.6% 20.6% 1 2.480s + │ └─op_sig_side_conditions_t ---------- 0.0% 12.7% 1 1.528s + │ ├─DestructHyps.do_all_matches_then 0.0% 7.3% 4 0.232s + │ │└DestructHyps.do_one_match_then -- 0.3% 7.3% 24 0.052s + │ │└do_tac -------------------------- 0.0% 7.0% 20 0.048s + │ │└destruct H ---------------------- 6.9% 6.9% 20 0.048s + │ └─rewrite <- (ZRange.is_bounded_by_ 5.2% 5.2% 4 0.300s + └─IntegrationTestTemporaryMiscCommon.do 0.0% 14.1% 1 1.704s + ├─IntegrationTestTemporaryMiscCommon. 0.0% 11.2% 1 1.352s + │└rewrite <- (lem : lemT) by by_tac l 0.1% 11.2% 1 1.352s + │└by_tac ---------------------------- 0.0% 11.1% 4 0.476s + │ ├─DestructHyps.do_all_matches_then 0.0% 5.6% 4 0.176s + │ │└DestructHyps.do_one_match_then -- 0.2% 5.6% 20 0.052s + │ │└do_tac -------------------------- 0.0% 5.3% 16 0.048s + │ │└destruct H ---------------------- 5.3% 5.3% 16 0.048s + │ └─rewrite <- (ZRange.is_bounded_by_ 5.3% 5.3% 4 0.316s + └─IntegrationTestTemporaryMiscCommon. 0.0% 2.9% 1 0.348s + └<Crypto.Util.Tactics.MoveLetIn.with 0.5% 2.8% 3 0.332s + └k --------------------------------- 2.1% 2.2% 1 0.268s +─Pipeline.refine_reflectively_gen ------ 0.0% 33.9% 1 4.084s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 28.3% 1 3.404s + │└ReflectiveTactics.solve_side_conditio 0.0% 27.8% 1 3.352s + │ ├─ReflectiveTactics.solve_post_reifie 0.4% 14.1% 1 1.696s + │ │ ├─UnifyAbstractReflexivity.unify_tr 8.8% 10.6% 7 0.344s + │ │ └─ReflectiveTactics.unify_abstract_ 2.2% 3.0% 1 0.360s + │ └─ReflectiveTactics.do_reify -------- 0.0% 13.7% 1 1.656s + │ └Reify.Reify_rhs_gen --------------- 0.9% 13.2% 1 1.592s + │ └Reify.do_reify_abs_goal ----------- 6.0% 6.1% 2 0.732s + │ └Reify.do_reifyf_goal -------------- 5.4% 5.5% 80 0.660s + └─Glue.refine_to_reflective_glue' ----- 0.0% 5.6% 1 0.680s + └Glue.zrange_to_reflective ----------- 0.0% 3.6% 1 0.428s + └Glue.zrange_to_reflective_goal ------ 1.7% 2.6% 1 0.316s + +Finished transaction in 13.895 secs (12.78u,0.02s) (successful) +Closed under the global context +total time: 12.048s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 66.1% 1 7.964s +─IntegrationTestTemporaryMiscCommon.fact 16.2% 50.9% 1 6.128s +─Pipeline.refine_reflectively_gen ------ 0.0% 33.9% 1 4.084s +─ReflectiveTactics.do_reflective_pipelin 0.0% 28.3% 1 3.404s +─ReflectiveTactics.solve_side_conditions 0.0% 27.8% 1 3.352s +─reflexivity --------------------------- 21.7% 21.7% 8 2.480s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 14.1% 1 1.704s +─ReflectiveTactics.solve_post_reified_si 0.4% 14.1% 1 1.696s +─ReflectiveTactics.do_reify ------------ 0.0% 13.7% 1 1.656s +─Reify.Reify_rhs_gen ------------------- 0.9% 13.2% 1 1.592s +─DestructHyps.do_all_matches_then ------ 0.0% 12.9% 8 0.232s +─DestructHyps.do_one_match_then -------- 0.6% 12.9% 44 0.052s +─op_sig_side_conditions_t -------------- 0.0% 12.7% 1 1.528s +─do_tac -------------------------------- 0.0% 12.3% 36 0.048s +─destruct H ---------------------------- 12.3% 12.3% 36 0.048s +─rewrite <- (lem : lemT) by by_tac ltac: 0.1% 11.2% 1 1.352s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 11.2% 1 1.352s +─by_tac -------------------------------- 0.0% 11.1% 4 0.476s +─UnifyAbstractReflexivity.unify_transfor 8.8% 10.6% 7 0.344s +─rewrite <- (ZRange.is_bounded_by_None_r 10.5% 10.5% 8 0.316s +─Reify.do_reify_abs_goal --------------- 6.0% 6.1% 2 0.732s +─Glue.refine_to_reflective_glue' ------- 0.0% 5.6% 1 0.680s +─Reify.do_reifyf_goal ------------------ 5.4% 5.5% 80 0.660s +─Glue.zrange_to_reflective ------------- 0.0% 3.6% 1 0.428s +─ReflectiveTactics.unify_abstract_cbv_in 2.2% 3.0% 1 0.360s +─IntegrationTestTemporaryMiscCommon.do_s 0.0% 2.9% 1 0.348s +─<Crypto.Util.Tactics.MoveLetIn.with_uco 0.5% 2.8% 3 0.332s +─Glue.zrange_to_reflective_goal -------- 1.7% 2.6% 1 0.316s +─k ------------------------------------- 2.1% 2.2% 1 0.268s +─unify (constr) (constr) --------------- 2.1% 2.1% 8 0.092s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_montgomery ----------------- 0.0% 66.1% 1 7.964s + ├─IntegrationTestTemporaryMiscCommon.fa 16.2% 50.9% 1 6.128s + │ ├─reflexivity ----------------------- 20.6% 20.6% 1 2.480s + │ └─op_sig_side_conditions_t ---------- 0.0% 12.7% 1 1.528s + │ ├─DestructHyps.do_all_matches_then 0.0% 7.3% 4 0.232s + │ │└DestructHyps.do_one_match_then -- 0.3% 7.3% 24 0.052s + │ │└do_tac -------------------------- 0.0% 7.0% 20 0.048s + │ │└destruct H ---------------------- 6.9% 6.9% 20 0.048s + │ └─rewrite <- (ZRange.is_bounded_by_ 5.2% 5.2% 4 0.300s + └─IntegrationTestTemporaryMiscCommon.do 0.0% 14.1% 1 1.704s + ├─IntegrationTestTemporaryMiscCommon. 0.0% 11.2% 1 1.352s + │└rewrite <- (lem : lemT) by by_tac l 0.1% 11.2% 1 1.352s + │└by_tac ---------------------------- 0.0% 11.1% 4 0.476s + │ ├─DestructHyps.do_all_matches_then 0.0% 5.6% 4 0.176s + │ │└DestructHyps.do_one_match_then -- 0.2% 5.6% 20 0.052s + │ │└do_tac -------------------------- 0.0% 5.3% 16 0.048s + │ │└destruct H ---------------------- 5.3% 5.3% 16 0.048s + │ └─rewrite <- (ZRange.is_bounded_by_ 5.3% 5.3% 4 0.316s + └─IntegrationTestTemporaryMiscCommon. 0.0% 2.9% 1 0.348s + └<Crypto.Util.Tactics.MoveLetIn.with 0.5% 2.8% 3 0.332s + └k --------------------------------- 2.1% 2.2% 1 0.268s +─Pipeline.refine_reflectively_gen ------ 0.0% 33.9% 1 4.084s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 28.3% 1 3.404s + │└ReflectiveTactics.solve_side_conditio 0.0% 27.8% 1 3.352s + │ ├─ReflectiveTactics.solve_post_reifie 0.4% 14.1% 1 1.696s + │ │ ├─UnifyAbstractReflexivity.unify_tr 8.8% 10.6% 7 0.344s + │ │ └─ReflectiveTactics.unify_abstract_ 2.2% 3.0% 1 0.360s + │ └─ReflectiveTactics.do_reify -------- 0.0% 13.7% 1 1.656s + │ └Reify.Reify_rhs_gen --------------- 0.9% 13.2% 1 1.592s + │ └Reify.do_reify_abs_goal ----------- 6.0% 6.1% 2 0.732s + │ └Reify.do_reifyf_goal -------------- 5.4% 5.5% 80 0.660s + └─Glue.refine_to_reflective_glue' ----- 0.0% 5.6% 1 0.680s + └Glue.zrange_to_reflective ----------- 0.0% 3.6% 1 0.428s + └Glue.zrange_to_reflective_goal ------ 1.7% 2.6% 1 0.316s + +src/Specific/NISTP256/AMD64/fesub (real: 43.34, user: 39.59, sys: 0.26, mem: 793376 ko) +COQC src/Specific/NISTP256/AMD64/feaddDisplay > src/Specific/NISTP256/AMD64/feaddDisplay.log +COQC src/Specific/NISTP256/AMD64/fenzDisplay > src/Specific/NISTP256/AMD64/fenzDisplay.log +COQC src/Specific/solinas32_2e255m765_12limbs/femul.v +Finished transaction in 50.426 secs (46.528u,0.072s) (successful) +total time: 46.544s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ -0.0% 94.9% 1 44.164s +─ReflectiveTactics.do_reflective_pipelin 0.0% 87.1% 1 40.552s +─ReflectiveTactics.solve_side_conditions 0.0% 86.7% 1 40.372s +─ReflectiveTactics.do_reify ------------ 0.0% 59.6% 1 27.740s +─Reify.Reify_rhs_gen ------------------- 1.6% 58.9% 1 27.432s +─Reify.do_reify_abs_goal --------------- 43.3% 43.6% 2 20.312s +─Reify.do_reifyf_goal ------------------ 42.5% 42.8% 108 10.328s +─ReflectiveTactics.solve_post_reified_si 0.1% 27.1% 1 12.632s +─UnifyAbstractReflexivity.unify_transfor 18.6% 23.5% 7 3.552s +─eexact -------------------------------- 13.7% 13.7% 110 0.136s +─Glue.refine_to_reflective_glue' ------- 0.0% 7.8% 1 3.612s +─Glue.zrange_to_reflective ------------- 0.0% 7.2% 1 3.332s +─Glue.zrange_to_reflective_goal -------- 1.7% 5.5% 1 2.544s +─synthesize ---------------------------- 0.0% 5.1% 1 2.380s +─unify (constr) (constr) --------------- 5.1% 5.1% 6 1.068s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 5.0% 1 2.320s +─change G' ----------------------------- 4.8% 4.8% 1 2.252s +─rewrite H ----------------------------- 3.8% 3.8% 1 1.748s +─pose proof (pf : Interpretation.Bo 3.6% 3.6% 1 1.664s +─prove_interp_compile_correct ---------- 0.0% 3.5% 1 1.616s +─rewrite ?EtaInterp.InterpExprEta ------ 3.2% 3.2% 1 1.468s +─ReflectiveTactics.unify_abstract_cbv_in 1.6% 2.4% 1 1.124s +─reflexivity --------------------------- 2.1% 2.1% 7 0.396s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ -0.0% 94.9% 1 44.164s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 87.1% 1 40.552s + │└ReflectiveTactics.solve_side_conditio 0.0% 86.7% 1 40.372s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 59.6% 1 27.740s + │ │└Reify.Reify_rhs_gen --------------- 1.6% 58.9% 1 27.432s + │ │ ├─Reify.do_reify_abs_goal --------- 43.3% 43.6% 2 20.312s + │ │ │└Reify.do_reifyf_goal ------------ 42.5% 42.8% 108 10.328s + │ │ │└eexact -------------------------- 13.2% 13.2% 108 0.072s + │ │ ├─rewrite H ----------------------- 3.8% 3.8% 1 1.748s + │ │ └─prove_interp_compile_correct ---- 0.0% 3.5% 1 1.616s + │ │ └rewrite ?EtaInterp.InterpExprEta 3.2% 3.2% 1 1.468s + │ └─ReflectiveTactics.solve_post_reifie 0.1% 27.1% 1 12.632s + │ ├─UnifyAbstractReflexivity.unify_tr 18.6% 23.5% 7 3.552s + │ │└unify (constr) (constr) --------- 4.3% 4.3% 5 1.068s + │ └─ReflectiveTactics.unify_abstract_ 1.6% 2.4% 1 1.124s + └─Glue.refine_to_reflective_glue' ----- 0.0% 7.8% 1 3.612s + └Glue.zrange_to_reflective ----------- 0.0% 7.2% 1 3.332s + └Glue.zrange_to_reflective_goal ------ 1.7% 5.5% 1 2.544s + └pose proof (pf : Interpretation. 3.6% 3.6% 1 1.664s +─synthesize ---------------------------- 0.0% 5.1% 1 2.380s +└IntegrationTestTemporaryMiscCommon.do_r 0.0% 5.0% 1 2.320s +└change G' ----------------------------- 4.8% 4.8% 1 2.252s + +Finished transaction in 80.129 secs (74.068u,0.024s) (successful) +Closed under the global context +total time: 46.544s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ -0.0% 94.9% 1 44.164s +─ReflectiveTactics.do_reflective_pipelin 0.0% 87.1% 1 40.552s +─ReflectiveTactics.solve_side_conditions 0.0% 86.7% 1 40.372s +─ReflectiveTactics.do_reify ------------ 0.0% 59.6% 1 27.740s +─Reify.Reify_rhs_gen ------------------- 1.6% 58.9% 1 27.432s +─Reify.do_reify_abs_goal --------------- 43.3% 43.6% 2 20.312s +─Reify.do_reifyf_goal ------------------ 42.5% 42.8% 108 10.328s +─ReflectiveTactics.solve_post_reified_si 0.1% 27.1% 1 12.632s +─UnifyAbstractReflexivity.unify_transfor 18.6% 23.5% 7 3.552s +─eexact -------------------------------- 13.7% 13.7% 110 0.136s +─Glue.refine_to_reflective_glue' ------- 0.0% 7.8% 1 3.612s +─Glue.zrange_to_reflective ------------- 0.0% 7.2% 1 3.332s +─Glue.zrange_to_reflective_goal -------- 1.7% 5.5% 1 2.544s +─synthesize ---------------------------- 0.0% 5.1% 1 2.380s +─unify (constr) (constr) --------------- 5.1% 5.1% 6 1.068s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 5.0% 1 2.320s +─change G' ----------------------------- 4.8% 4.8% 1 2.252s +─rewrite H ----------------------------- 3.8% 3.8% 1 1.748s +─pose proof (pf : Interpretation.Bo 3.6% 3.6% 1 1.664s +─prove_interp_compile_correct ---------- 0.0% 3.5% 1 1.616s +─rewrite ?EtaInterp.InterpExprEta ------ 3.2% 3.2% 1 1.468s +─ReflectiveTactics.unify_abstract_cbv_in 1.6% 2.4% 1 1.124s +─reflexivity --------------------------- 2.1% 2.1% 7 0.396s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ -0.0% 94.9% 1 44.164s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 87.1% 1 40.552s + │└ReflectiveTactics.solve_side_conditio 0.0% 86.7% 1 40.372s + │ ├─ReflectiveTactics.do_reify -------- 0.0% 59.6% 1 27.740s + │ │└Reify.Reify_rhs_gen --------------- 1.6% 58.9% 1 27.432s + │ │ ├─Reify.do_reify_abs_goal --------- 43.3% 43.6% 2 20.312s + │ │ │└Reify.do_reifyf_goal ------------ 42.5% 42.8% 108 10.328s + │ │ │└eexact -------------------------- 13.2% 13.2% 108 0.072s + │ │ ├─rewrite H ----------------------- 3.8% 3.8% 1 1.748s + │ │ └─prove_interp_compile_correct ---- 0.0% 3.5% 1 1.616s + │ │ └rewrite ?EtaInterp.InterpExprEta 3.2% 3.2% 1 1.468s + │ └─ReflectiveTactics.solve_post_reifie 0.1% 27.1% 1 12.632s + │ ├─UnifyAbstractReflexivity.unify_tr 18.6% 23.5% 7 3.552s + │ │└unify (constr) (constr) --------- 4.3% 4.3% 5 1.068s + │ └─ReflectiveTactics.unify_abstract_ 1.6% 2.4% 1 1.124s + └─Glue.refine_to_reflective_glue' ----- 0.0% 7.8% 1 3.612s + └Glue.zrange_to_reflective ----------- 0.0% 7.2% 1 3.332s + └Glue.zrange_to_reflective_goal ------ 1.7% 5.5% 1 2.544s + └pose proof (pf : Interpretation. 3.6% 3.6% 1 1.664s +─synthesize ---------------------------- 0.0% 5.1% 1 2.380s +└IntegrationTestTemporaryMiscCommon.do_r 0.0% 5.0% 1 2.320s +└change G' ----------------------------- 4.8% 4.8% 1 2.252s + +src/Specific/solinas32_2e255m765_12limbs/femul (real: 155.79, user: 143.70, sys: 0.32, mem: 1454696 ko) +COQC src/Specific/NISTP256/AMD64/feoppDisplay > src/Specific/NISTP256/AMD64/feoppDisplay.log +COQC src/Specific/NISTP256/AMD64/fesubDisplay > src/Specific/NISTP256/AMD64/fesubDisplay.log +COQC src/Specific/X25519/C64/fesquareDisplay > src/Specific/X25519/C64/fesquareDisplay.log +COQC src/Specific/X25519/C64/fesubDisplay > src/Specific/X25519/C64/fesubDisplay.log +COQC src/Specific/X25519/C64/freezeDisplay > src/Specific/X25519/C64/freezeDisplay.log +COQC src/Specific/solinas32_2e255m765_13limbs/femul.v +Finished transaction in 61.854 secs (57.328u,0.079s) (successful) +total time: 57.348s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 94.6% 1 54.224s +─ReflectiveTactics.do_reflective_pipelin 0.0% 86.2% 1 49.452s +─ReflectiveTactics.solve_side_conditions 0.0% 85.9% 1 49.264s +─ReflectiveTactics.do_reify ------------ -0.0% 57.6% 1 33.004s +─Reify.Reify_rhs_gen ------------------- 1.3% 56.9% 1 32.608s +─Reify.do_reify_abs_goal --------------- 43.1% 43.3% 2 24.840s +─Reify.do_reifyf_goal ------------------ 42.3% 42.6% 117 12.704s +─ReflectiveTactics.solve_post_reified_si 0.1% 28.4% 1 16.260s +─UnifyAbstractReflexivity.unify_transfor 19.6% 25.0% 7 4.824s +─eexact -------------------------------- 13.9% 13.9% 119 0.144s +─Glue.refine_to_reflective_glue' ------- 0.0% 8.3% 1 4.772s +─Glue.zrange_to_reflective ------------- 0.0% 7.8% 1 4.484s +─Glue.zrange_to_reflective_goal -------- 1.7% 6.0% 1 3.464s +─synthesize ---------------------------- 0.0% 5.4% 1 3.124s +─unify (constr) (constr) --------------- 5.4% 5.4% 6 1.540s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 5.3% 1 3.040s +─change G' ----------------------------- 5.2% 5.2% 1 2.964s +─pose proof (pf : Interpretation.Bo 4.2% 4.2% 1 2.416s +─prove_interp_compile_correct ---------- 0.0% 3.3% 1 1.904s +─rewrite H ----------------------------- 3.3% 3.3% 1 1.896s +─rewrite ?EtaInterp.InterpExprEta ------ 3.0% 3.0% 1 1.732s +─ReflectiveTactics.unify_abstract_cbv_in 1.4% 2.1% 1 1.212s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 94.6% 1 54.224s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 86.2% 1 49.452s + │└ReflectiveTactics.solve_side_conditio 0.0% 85.9% 1 49.264s + │ ├─ReflectiveTactics.do_reify -------- -0.0% 57.6% 1 33.004s + │ │└Reify.Reify_rhs_gen --------------- 1.3% 56.9% 1 32.608s + │ │ ├─Reify.do_reify_abs_goal --------- 43.1% 43.3% 2 24.840s + │ │ │└Reify.do_reifyf_goal ------------ 42.3% 42.6% 117 12.704s + │ │ │└eexact -------------------------- 13.4% 13.4% 117 0.084s + │ │ ├─prove_interp_compile_correct ---- 0.0% 3.3% 1 1.904s + │ │ │└rewrite ?EtaInterp.InterpExprEta 3.0% 3.0% 1 1.732s + │ │ └─rewrite H ----------------------- 3.3% 3.3% 1 1.896s + │ └─ReflectiveTactics.solve_post_reifie 0.1% 28.4% 1 16.260s + │ ├─UnifyAbstractReflexivity.unify_tr 19.6% 25.0% 7 4.824s + │ │└unify (constr) (constr) --------- 4.8% 4.8% 5 1.540s + │ └─ReflectiveTactics.unify_abstract_ 1.4% 2.1% 1 1.212s + └─Glue.refine_to_reflective_glue' ----- 0.0% 8.3% 1 4.772s + └Glue.zrange_to_reflective ----------- 0.0% 7.8% 1 4.484s + └Glue.zrange_to_reflective_goal ------ 1.7% 6.0% 1 3.464s + └pose proof (pf : Interpretation. 4.2% 4.2% 1 2.416s +─synthesize ---------------------------- 0.0% 5.4% 1 3.124s +└IntegrationTestTemporaryMiscCommon.do_r 0.0% 5.3% 1 3.040s +└change G' ----------------------------- 5.2% 5.2% 1 2.964s + +Finished transaction in 94.432 secs (86.96u,0.02s) (successful) +Closed under the global context +total time: 57.348s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 94.6% 1 54.224s +─ReflectiveTactics.do_reflective_pipelin 0.0% 86.2% 1 49.452s +─ReflectiveTactics.solve_side_conditions 0.0% 85.9% 1 49.264s +─ReflectiveTactics.do_reify ------------ -0.0% 57.6% 1 33.004s +─Reify.Reify_rhs_gen ------------------- 1.3% 56.9% 1 32.608s +─Reify.do_reify_abs_goal --------------- 43.1% 43.3% 2 24.840s +─Reify.do_reifyf_goal ------------------ 42.3% 42.6% 117 12.704s +─ReflectiveTactics.solve_post_reified_si 0.1% 28.4% 1 16.260s +─UnifyAbstractReflexivity.unify_transfor 19.6% 25.0% 7 4.824s +─eexact -------------------------------- 13.9% 13.9% 119 0.144s +─Glue.refine_to_reflective_glue' ------- 0.0% 8.3% 1 4.772s +─Glue.zrange_to_reflective ------------- 0.0% 7.8% 1 4.484s +─Glue.zrange_to_reflective_goal -------- 1.7% 6.0% 1 3.464s +─synthesize ---------------------------- 0.0% 5.4% 1 3.124s +─unify (constr) (constr) --------------- 5.4% 5.4% 6 1.540s +─IntegrationTestTemporaryMiscCommon.do_r 0.0% 5.3% 1 3.040s +─change G' ----------------------------- 5.2% 5.2% 1 2.964s +─pose proof (pf : Interpretation.Bo 4.2% 4.2% 1 2.416s +─prove_interp_compile_correct ---------- 0.0% 3.3% 1 1.904s +─rewrite H ----------------------------- 3.3% 3.3% 1 1.896s +─rewrite ?EtaInterp.InterpExprEta ------ 3.0% 3.0% 1 1.732s +─ReflectiveTactics.unify_abstract_cbv_in 1.4% 2.1% 1 1.212s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 94.6% 1 54.224s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 86.2% 1 49.452s + │└ReflectiveTactics.solve_side_conditio 0.0% 85.9% 1 49.264s + │ ├─ReflectiveTactics.do_reify -------- -0.0% 57.6% 1 33.004s + │ │└Reify.Reify_rhs_gen --------------- 1.3% 56.9% 1 32.608s + │ │ ├─Reify.do_reify_abs_goal --------- 43.1% 43.3% 2 24.840s + │ │ │└Reify.do_reifyf_goal ------------ 42.3% 42.6% 117 12.704s + │ │ │└eexact -------------------------- 13.4% 13.4% 117 0.084s + │ │ ├─prove_interp_compile_correct ---- 0.0% 3.3% 1 1.904s + │ │ │└rewrite ?EtaInterp.InterpExprEta 3.0% 3.0% 1 1.732s + │ │ └─rewrite H ----------------------- 3.3% 3.3% 1 1.896s + │ └─ReflectiveTactics.solve_post_reifie 0.1% 28.4% 1 16.260s + │ ├─UnifyAbstractReflexivity.unify_tr 19.6% 25.0% 7 4.824s + │ │└unify (constr) (constr) --------- 4.8% 4.8% 5 1.540s + │ └─ReflectiveTactics.unify_abstract_ 1.4% 2.1% 1 1.212s + └─Glue.refine_to_reflective_glue' ----- 0.0% 8.3% 1 4.772s + └Glue.zrange_to_reflective ----------- 0.0% 7.8% 1 4.484s + └Glue.zrange_to_reflective_goal ------ 1.7% 6.0% 1 3.464s + └pose proof (pf : Interpretation. 4.2% 4.2% 1 2.416s +─synthesize ---------------------------- 0.0% 5.4% 1 3.124s +└IntegrationTestTemporaryMiscCommon.do_r 0.0% 5.3% 1 3.040s +└change G' ----------------------------- 5.2% 5.2% 1 2.964s + +src/Specific/solinas32_2e255m765_13limbs/femul (real: 181.77, user: 168.52, sys: 0.40, mem: 1589516 ko) +COQC src/Specific/NISTP256/AMD64/femul.v +Finished transaction in 119.257 secs (109.936u,0.256s) (successful) +total time: 110.140s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.1% 1 106.964s +─ReflectiveTactics.do_reflective_pipelin -0.0% 96.4% 1 106.196s +─ReflectiveTactics.solve_side_conditions 0.0% 96.2% 1 105.992s +─ReflectiveTactics.do_reify ------------ -0.0% 83.7% 1 92.208s +─Reify.Reify_rhs_gen ------------------- 0.7% 83.5% 1 91.960s +─Reify.do_reify_abs_goal --------------- 77.7% 77.8% 2 85.708s +─Reify.do_reifyf_goal ------------------ 77.4% 77.5% 901 85.364s +─eexact -------------------------------- 17.9% 17.9% 903 0.136s +─ReflectiveTactics.solve_post_reified_si 0.3% 12.5% 1 13.784s +─UnifyAbstractReflexivity.unify_transfor 9.8% 11.2% 7 3.356s +─synthesize_montgomery ----------------- 0.0% 2.9% 1 3.176s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.1% 1 106.964s +└ReflectiveTactics.do_reflective_pipelin -0.0% 96.4% 1 106.196s +└ReflectiveTactics.solve_side_conditions 0.0% 96.2% 1 105.992s + ├─ReflectiveTactics.do_reify ---------- -0.0% 83.7% 1 92.208s + │└Reify.Reify_rhs_gen ----------------- 0.7% 83.5% 1 91.960s + │└Reify.do_reify_abs_goal ------------- 77.7% 77.8% 2 85.708s + │└Reify.do_reifyf_goal ---------------- 77.4% 77.5% 901 85.364s + │└eexact ------------------------------ 17.7% 17.7% 901 0.136s + └─ReflectiveTactics.solve_post_reified_ 0.3% 12.5% 1 13.784s + └UnifyAbstractReflexivity.unify_transf 9.8% 11.2% 7 3.356s +─synthesize_montgomery ----------------- 0.0% 2.9% 1 3.176s + +Finished transaction in 61.452 secs (58.503u,0.055s) (successful) +Closed under the global context +total time: 110.140s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.1% 1 106.964s +─ReflectiveTactics.do_reflective_pipelin -0.0% 96.4% 1 106.196s +─ReflectiveTactics.solve_side_conditions 0.0% 96.2% 1 105.992s +─ReflectiveTactics.do_reify ------------ -0.0% 83.7% 1 92.208s +─Reify.Reify_rhs_gen ------------------- 0.7% 83.5% 1 91.960s +─Reify.do_reify_abs_goal --------------- 77.7% 77.8% 2 85.708s +─Reify.do_reifyf_goal ------------------ 77.4% 77.5% 901 85.364s +─eexact -------------------------------- 17.9% 17.9% 903 0.136s +─ReflectiveTactics.solve_post_reified_si 0.3% 12.5% 1 13.784s +─UnifyAbstractReflexivity.unify_transfor 9.8% 11.2% 7 3.356s +─synthesize_montgomery ----------------- 0.0% 2.9% 1 3.176s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─Pipeline.refine_reflectively_gen ------ 0.0% 97.1% 1 106.964s +└ReflectiveTactics.do_reflective_pipelin -0.0% 96.4% 1 106.196s +└ReflectiveTactics.solve_side_conditions 0.0% 96.2% 1 105.992s + ├─ReflectiveTactics.do_reify ---------- -0.0% 83.7% 1 92.208s + │└Reify.Reify_rhs_gen ----------------- 0.7% 83.5% 1 91.960s + │└Reify.do_reify_abs_goal ------------- 77.7% 77.8% 2 85.708s + │└Reify.do_reifyf_goal ---------------- 77.4% 77.5% 901 85.364s + │└eexact ------------------------------ 17.7% 17.7% 901 0.136s + └─ReflectiveTactics.solve_post_reified_ 0.3% 12.5% 1 13.784s + └UnifyAbstractReflexivity.unify_transf 9.8% 11.2% 7 3.356s +─synthesize_montgomery ----------------- 0.0% 2.9% 1 3.176s + +src/Specific/NISTP256/AMD64/femul (real: 202.96, user: 189.62, sys: 0.64, mem: 3302508 ko) +COQC src/Specific/NISTP256/AMD64/femulDisplay > src/Specific/NISTP256/AMD64/femulDisplay.log +COQC src/Specific/X25519/C64/ladderstep.v +total time: 52.080s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_xzladderstep --------------- 0.0% 100.0% 1 52.080s +─Pipeline.refine_reflectively_gen ------ 0.0% 98.5% 1 51.320s +─ReflectiveTactics.do_reflective_pipelin 0.0% 93.8% 1 48.872s +─ReflectiveTactics.solve_side_conditions 0.0% 93.7% 1 48.776s +─ReflectiveTactics.solve_post_reified_si 0.2% 56.5% 1 29.412s +─UnifyAbstractReflexivity.unify_transfor 44.7% 49.1% 7 6.968s +─ReflectiveTactics.do_reify ------------ 0.0% 37.2% 1 19.364s +─Reify.Reify_rhs_gen ------------------- 2.1% 23.4% 1 12.200s +─Reify.do_reifyf_goal ------------------ 11.2% 11.3% 138 1.884s +─Compilers.Reify.reify_context_variables 0.1% 9.2% 1 4.808s +─rewrite H ----------------------------- 7.3% 7.3% 1 3.816s +─ReflectiveTactics.unify_abstract_cbv_in 4.7% 6.4% 1 3.336s +─Glue.refine_to_reflective_glue' ------- 0.0% 4.7% 1 2.448s +─Glue.zrange_to_reflective ------------- 0.0% 4.0% 1 2.068s +─Reify.transitivity_tt ----------------- 0.1% 3.7% 2 0.984s +─transitivity -------------------------- 3.5% 3.5% 10 0.880s +─reflexivity --------------------------- 3.4% 3.4% 11 0.772s +─Glue.zrange_to_reflective_goal -------- 2.4% 3.3% 1 1.728s +─eexact -------------------------------- 3.2% 3.2% 140 0.032s +─unify (constr) (constr) --------------- 3.1% 3.1% 6 0.852s +─clear (var_list) ---------------------- 3.1% 3.1% 98 0.584s +─UnfoldArg.unfold_second_arg ----------- 0.4% 3.0% 2 1.576s +─tac ----------------------------------- 2.1% 3.0% 2 1.564s +─ClearAll.clear_all -------------------- 0.2% 2.8% 7 0.584s +─ChangeInAll.change_with_compute_in_all 0.0% 2.6% 221 0.012s +─change c with c' in * ----------------- 2.5% 2.5% 221 0.012s +─Reify.do_reify_abs_goal --------------- 2.4% 2.5% 2 1.276s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_xzladderstep --------------- 0.0% 100.0% 1 52.080s +└Pipeline.refine_reflectively_gen ------ 0.0% 98.5% 1 51.320s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 93.8% 1 48.872s + │└ReflectiveTactics.solve_side_conditio 0.0% 93.7% 1 48.776s + │ ├─ReflectiveTactics.solve_post_reifie 0.2% 56.5% 1 29.412s + │ │ ├─UnifyAbstractReflexivity.unify_tr 44.7% 49.1% 7 6.968s + │ │ │└ClearAll.clear_all -------------- 0.2% 2.8% 7 0.584s + │ │ │└clear (var_list) ---------------- 2.7% 2.7% 65 0.584s + │ │ └─ReflectiveTactics.unify_abstract_ 4.7% 6.4% 1 3.336s + │ └─ReflectiveTactics.do_reify -------- 0.0% 37.2% 1 19.364s + │ ├─Reify.Reify_rhs_gen ------------- 2.1% 23.4% 1 12.200s + │ │ ├─rewrite H --------------------- 7.3% 7.3% 1 3.816s + │ │ ├─Reify.transitivity_tt --------- 0.1% 3.7% 2 0.984s + │ │ │└transitivity ------------------ 3.4% 3.4% 4 0.880s + │ │ ├─tac --------------------------- 2.1% 3.0% 1 1.564s + │ │ └─Reify.do_reify_abs_goal ------- 2.4% 2.5% 2 1.276s + │ │ └Reify.do_reifyf_goal ---------- 2.2% 2.2% 25 1.148s + │ ├─Compilers.Reify.reify_context_var 0.1% 9.2% 1 4.808s + │ │└Reify.do_reifyf_goal ------------ 9.0% 9.1% 113 1.884s + │ │└eexact -------------------------- 2.4% 2.4% 113 0.032s + │ └─UnfoldArg.unfold_second_arg ----- 0.4% 3.0% 2 1.576s + │ └ChangeInAll.change_with_compute_i 0.0% 2.6% 221 0.012s + │ └change c with c' in * ----------- 2.5% 2.5% 221 0.012s + └─Glue.refine_to_reflective_glue' ----- 0.0% 4.7% 1 2.448s + └Glue.zrange_to_reflective ----------- 0.0% 4.0% 1 2.068s + └Glue.zrange_to_reflective_goal ------ 2.4% 3.3% 1 1.728s + +Finished transaction in 171.122 secs (161.392u,0.039s) (successful) +Closed under the global context +total time: 52.080s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_xzladderstep --------------- 0.0% 100.0% 1 52.080s +─Pipeline.refine_reflectively_gen ------ 0.0% 98.5% 1 51.320s +─ReflectiveTactics.do_reflective_pipelin 0.0% 93.8% 1 48.872s +─ReflectiveTactics.solve_side_conditions 0.0% 93.7% 1 48.776s +─ReflectiveTactics.solve_post_reified_si 0.2% 56.5% 1 29.412s +─UnifyAbstractReflexivity.unify_transfor 44.7% 49.1% 7 6.968s +─ReflectiveTactics.do_reify ------------ 0.0% 37.2% 1 19.364s +─Reify.Reify_rhs_gen ------------------- 2.1% 23.4% 1 12.200s +─Reify.do_reifyf_goal ------------------ 11.2% 11.3% 138 1.884s +─Compilers.Reify.reify_context_variables 0.1% 9.2% 1 4.808s +─rewrite H ----------------------------- 7.3% 7.3% 1 3.816s +─ReflectiveTactics.unify_abstract_cbv_in 4.7% 6.4% 1 3.336s +─Glue.refine_to_reflective_glue' ------- 0.0% 4.7% 1 2.448s +─Glue.zrange_to_reflective ------------- 0.0% 4.0% 1 2.068s +─Reify.transitivity_tt ----------------- 0.1% 3.7% 2 0.984s +─transitivity -------------------------- 3.5% 3.5% 10 0.880s +─reflexivity --------------------------- 3.4% 3.4% 11 0.772s +─Glue.zrange_to_reflective_goal -------- 2.4% 3.3% 1 1.728s +─eexact -------------------------------- 3.2% 3.2% 140 0.032s +─unify (constr) (constr) --------------- 3.1% 3.1% 6 0.852s +─clear (var_list) ---------------------- 3.1% 3.1% 98 0.584s +─UnfoldArg.unfold_second_arg ----------- 0.4% 3.0% 2 1.576s +─tac ----------------------------------- 2.1% 3.0% 2 1.564s +─ClearAll.clear_all -------------------- 0.2% 2.8% 7 0.584s +─ChangeInAll.change_with_compute_in_all 0.0% 2.6% 221 0.012s +─change c with c' in * ----------------- 2.5% 2.5% 221 0.012s +─Reify.do_reify_abs_goal --------------- 2.4% 2.5% 2 1.276s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─synthesize_xzladderstep --------------- 0.0% 100.0% 1 52.080s +└Pipeline.refine_reflectively_gen ------ 0.0% 98.5% 1 51.320s + ├─ReflectiveTactics.do_reflective_pipel 0.0% 93.8% 1 48.872s + │└ReflectiveTactics.solve_side_conditio 0.0% 93.7% 1 48.776s + │ ├─ReflectiveTactics.solve_post_reifie 0.2% 56.5% 1 29.412s + │ │ ├─UnifyAbstractReflexivity.unify_tr 44.7% 49.1% 7 6.968s + │ │ │└ClearAll.clear_all -------------- 0.2% 2.8% 7 0.584s + │ │ │└clear (var_list) ---------------- 2.7% 2.7% 65 0.584s + │ │ └─ReflectiveTactics.unify_abstract_ 4.7% 6.4% 1 3.336s + │ └─ReflectiveTactics.do_reify -------- 0.0% 37.2% 1 19.364s + │ ├─Reify.Reify_rhs_gen ------------- 2.1% 23.4% 1 12.200s + │ │ ├─rewrite H --------------------- 7.3% 7.3% 1 3.816s + │ │ ├─Reify.transitivity_tt --------- 0.1% 3.7% 2 0.984s + │ │ │└transitivity ------------------ 3.4% 3.4% 4 0.880s + │ │ ├─tac --------------------------- 2.1% 3.0% 1 1.564s + │ │ └─Reify.do_reify_abs_goal ------- 2.4% 2.5% 2 1.276s + │ │ └Reify.do_reifyf_goal ---------- 2.2% 2.2% 25 1.148s + │ ├─Compilers.Reify.reify_context_var 0.1% 9.2% 1 4.808s + │ │└Reify.do_reifyf_goal ------------ 9.0% 9.1% 113 1.884s + │ │└eexact -------------------------- 2.4% 2.4% 113 0.032s + │ └─UnfoldArg.unfold_second_arg ----- 0.4% 3.0% 2 1.576s + │ └ChangeInAll.change_with_compute_i 0.0% 2.6% 221 0.012s + │ └change c with c' in * ----------- 2.5% 2.5% 221 0.012s + └─Glue.refine_to_reflective_glue' ----- 0.0% 4.7% 1 2.448s + └Glue.zrange_to_reflective ----------- 0.0% 4.0% 1 2.068s + └Glue.zrange_to_reflective_goal ------ 2.4% 3.3% 1 1.728s + +src/Specific/X25519/C64/ladderstep (real: 256.77, user: 241.34, sys: 0.45, mem: 1617000 ko) +COQC src/Specific/X25519/C64/ladderstepDisplay > src/Specific/X25519/C64/ladderstepDisplay.log diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/run.sh b/test-suite/coq-makefile/timing/precomputed-time-tests/run.sh new file mode 100755 index 0000000000..a918cceb66 --- /dev/null +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/run.sh @@ -0,0 +1,10 @@ +#!/usr/bin/env bash + +set -x +set -e + +cd "$(dirname "${BASH_SOURCE[0]}")" +export COQLIB="$(cd ../../../.. && pwd)" + +./001-correct-diff-sorting-order/run.sh || exit $? +./002-single-file-sorting/run.sh || exit $? diff --git a/test-suite/coq-makefile/timing/run.sh b/test-suite/coq-makefile/timing/run.sh index 7e0baaa8f2..898af5590a 100755 --- a/test-suite/coq-makefile/timing/run.sh +++ b/test-suite/coq-makefile/timing/run.sh @@ -3,9 +3,12 @@ #set -x set -e -. ../template/init.sh +. ../template/path-init.sh -cd error +cd precomputed-time-tests +./run.sh || exit $? + +cd ../error coq_makefile -f _CoqProject -o Makefile make cleanall if make pretty-timed TGTS="all" -j1; then @@ -41,6 +44,9 @@ for ext in "" .desired; do done done for file in time-of-build-before.log time-of-build-after.log time-of-build-both.log; do + echo "cat $file" + cat "$file" + echo diff -u $file.desired.processed $file.processed || exit $? done @@ -56,6 +62,13 @@ make all TIMING=after -j2 || exit $? find ../per-file-before/ -name "*.before-timing" -exec 'cp' '{}' './' ';' make all.timing.diff -j2 || exit $? +echo "cat A.v.before-timing" +cat A.v.before-timing +echo +echo "cat A.v.after-timing" +cat A.v.after-timing +echo +echo "cat A.v.timing.diff" cat A.v.timing.diff echo diff --git a/test-suite/coqdoc/links.html.out b/test-suite/coqdoc/links.html.out index 70cbe50657..5e4b676c2f 100644 --- a/test-suite/coqdoc/links.html.out +++ b/test-suite/coqdoc/links.html.out @@ -76,7 +76,7 @@ Various checks for coqdoc <br/> <span class="id" title="keyword">Inductive</span> <a name="eq"><span class="id" title="inductive">eq</span></a> (<span class="id" title="var">A</span>:<span class="id" title="keyword">Type</span>) (<span class="id" title="var">x</span>:<a class="idref" href="Coqdoc.links.html#A"><span class="id" title="variable">A</span></a>) : <span class="id" title="var">A</span> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#d43e996736952df71ebeeae74d10a287"><span class="id" title="notation">→</span></a> <span class="id" title="keyword">Prop</span> := <a name="eq_refl"><span class="id" title="constructor">eq_refl</span></a> : <a class="idref" href="Coqdoc.links.html#x"><span class="id" title="variable">x</span></a> <a class="idref" href="Coqdoc.links.html#8f9364556521ebb498093f28eea2240f"><span class="id" title="notation">=</span></a> <a class="idref" href="Coqdoc.links.html#x"><span class="id" title="variable">x</span></a> <a class="idref" href="Coqdoc.links.html#8f9364556521ebb498093f28eea2240f"><span class="id" title="notation">:></span></a><a class="idref" href="Coqdoc.links.html#A"><span class="id" title="variable">A</span></a><br/> <br/> -<span class="id" title="keyword">where</span> <a name="8f9364556521ebb498093f28eea2240f"><span class="id" title="notation">"</span></a>x = y :> A" := (@<a class="idref" href="Coqdoc.links.html#eq"><span class="id" title="inductive">eq</span></a> <a class="idref" href="Coqdoc.links.html#A"><span class="id" title="variable">A</span></a> <a class="idref" href="Coqdoc.links.html#x"><span class="id" title="variable">x</span></a> <span class="id" title="var">y</span>) : <span class="id" title="var">type_scope</span>.<br/> +<span class="id" title="keyword">where</span> <a name="8f9364556521ebb498093f28eea2240f"><span class="id" title="notation">"</span></a>x = y :> A" := (@<a class="idref" href="Coqdoc.links.html#eq"><span class="id" title="inductive">eq</span></a> <span class="id" title="var">A</span> <span class="id" title="var">x</span> <span class="id" title="var">y</span>) : <span class="id" title="var">type_scope</span>.<br/> <br/> <span class="id" title="keyword">Definition</span> <a name="eq0"><span class="id" title="definition">eq0</span></a> := 0 <a class="idref" href="Coqdoc.links.html#8f9364556521ebb498093f28eea2240f"><span class="id" title="notation">=</span></a> 0 <a class="idref" href="Coqdoc.links.html#8f9364556521ebb498093f28eea2240f"><span class="id" title="notation">:></span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>.<br/> diff --git a/test-suite/coqdoc/links.tex.out b/test-suite/coqdoc/links.tex.out index 7d93189ae2..f42db99dc2 100644 --- a/test-suite/coqdoc/links.tex.out +++ b/test-suite/coqdoc/links.tex.out @@ -69,7 +69,7 @@ Various checks for coqdoc \coqdocnoindent \coqdoceol \coqdocnoindent -\coqdockw{where} \coqdef{Coqdoc.links.:type scope:x '=' x ':>' x}{"}{"}x = y :> A" := (@\coqref{Coqdoc.links.eq}{\coqdocinductive{eq}} \coqdocvariable{A} \coqdocvariable{x} \coqdocvar{y}) : \coqdocvar{type\_scope}.\coqdoceol +\coqdockw{where} \coqdef{Coqdoc.links.:type scope:x '=' x ':>' x}{"}{"}x = y :> A" := (@\coqref{Coqdoc.links.eq}{\coqdocinductive{eq}} \coqdocvar{A} \coqdocvar{x} \coqdocvar{y}) : \coqdocvar{type\_scope}.\coqdoceol \coqdocemptyline \coqdocnoindent \coqdockw{Definition} \coqdef{Coqdoc.links.eq0}{eq0}{\coqdocdefinition{eq0}} := 0 \coqref{Coqdoc.links.:type scope:x '=' x ':>' x}{\coqdocnotation{=}} 0 \coqref{Coqdoc.links.:type scope:x '=' x ':>' x}{\coqdocnotation{:>}} \coqexternalref{nat}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocinductive{nat}}.\coqdoceol diff --git a/test-suite/output/Extraction_infix.out b/test-suite/output/Extraction_infix.out new file mode 100644 index 0000000000..29d50775a9 --- /dev/null +++ b/test-suite/output/Extraction_infix.out @@ -0,0 +1,20 @@ +(** val test : foo **) + +let test = + (fun (b, p) -> bar) (True, False) +(** val test : foo **) + +let test = + True@@?False +(** val test : foo **) + +let test = + True#^^False +(** val test : foo **) + +let test = + True@?:::False +(** val test : foo **) + +let test = + True @?::: False diff --git a/test-suite/output/Extraction_infix.v b/test-suite/output/Extraction_infix.v new file mode 100644 index 0000000000..fe5926a36a --- /dev/null +++ b/test-suite/output/Extraction_infix.v @@ -0,0 +1,26 @@ +(* @herbelin's example for issue #6212 *) + +Require Import Extraction. +Inductive I := C : bool -> bool -> I. +Definition test := C true false. + +(* the parentheses around the function wrong signalled an infix operator *) + +Extract Inductive I => "foo" [ "(fun (b, p) -> bar)" ]. +Extraction test. + +(* some bonafide infix operators *) + +Extract Inductive I => "foo" [ "(@@?)" ]. +Extraction test. + +Extract Inductive I => "foo" [ "(#^^)" ]. +Extraction test. + +Extract Inductive I => "foo" [ "(@?:::)" ]. +Extraction test. + +(* allow whitespace around infix operator *) + +Extract Inductive I => "foo" [ "( @?::: )" ]. +Extraction test. diff --git a/test-suite/output/Notations.out b/test-suite/output/Notations.out index 7bcd7b041c..2f0ee765db 100644 --- a/test-suite/output/Notations.out +++ b/test-suite/output/Notations.out @@ -64,7 +64,7 @@ The command has indeed failed with message: Cannot find where the recursive pattern starts. The command has indeed failed with message: Both ends of the recursive pattern are the same. -SUM (nat * nat) nat +(nat * nat + nat)%type : Set FST (0; 1) : Z @@ -72,7 +72,7 @@ Nil : forall A : Type, list A NIL : list nat : list nat -(false && I 3)%bool /\ I 6 +(false && I 3)%bool /\ (I 6)%bool : Prop [|1, 2, 3; 4, 5, 6|] : Z * Z * Z * (Z * Z * Z) diff --git a/test-suite/output/Notations.v b/test-suite/output/Notations.v index fe6c05c39e..413812ee19 100644 --- a/test-suite/output/Notations.v +++ b/test-suite/output/Notations.v @@ -30,7 +30,7 @@ Check (decomp (true,true) as t, u in (t,u)). Section A. -Notation "! A" := (forall _:nat, A) (at level 60). +Notation "! A" := (forall _:nat, A) (at level 60) : type_scope. Check ! (0=0). Check forall n, n=0. @@ -194,9 +194,9 @@ Open Scope nat_scope. Coercion is_true := fun b => b=true. Coercion of_nat n := match n with 0 => true | _ => false end. -Notation "'I' x" := (of_nat (S x) || true)%bool (at level 10). +Notation "'I' x" := (of_nat (S x) || true)%bool (at level 10) : bool_scope. -Check (false && I 3)%bool /\ I 6. +Check (false && I 3)%bool /\ (I 6)%bool. (**********************************************************************) (* Check notations with several recursive patterns *) diff --git a/test-suite/output/Notations2.out b/test-suite/output/Notations2.out index 1ec701ae81..a1028bda0c 100644 --- a/test-suite/output/Notations2.out +++ b/test-suite/output/Notations2.out @@ -41,7 +41,7 @@ Notation plus2 n := (S(S(n))) match n with | nil => 2 | 0 :: _ => 2 -| list1 => 0 +| 1 :: nil => 0 | 1 :: _ :: _ => 2 | plus2 _ :: _ => 2 end @@ -84,3 +84,9 @@ a≡ : Set .α : Set +# a : .α => +# b : .α => +let res := 0 in +for i from 0 to a updating (res) +{{for j from 0 to b updating (res) {{S res}};; res}};; res + : .α -> .α -> .α diff --git a/test-suite/output/Notations2.v b/test-suite/output/Notations2.v index ceb29d1b9e..4c3eaa0c7b 100644 --- a/test-suite/output/Notations2.v +++ b/test-suite/output/Notations2.v @@ -70,6 +70,7 @@ Check let' f x y (a:=0) z (b:bool) := x+y+z+1 in f 0 1 2. (* Note: does not work for pattern *) Module A. Notation "f ( x )" := (f x) (at level 10, format "f ( x )"). +Open Scope nat_scope. Check fun f x => f x + S x. Open Scope list_scope. @@ -145,3 +146,24 @@ Check .a≡. Notation ".α" := nat. Check nat. Check .α. + +(* A test for #6304 *) + +Module M6304. +Notation "'for' m 'from' 0 'to' N 'updating' ( s1 ) {{ b }} ;; rest" := + (let s1 := + (fix rec(n: nat) := match n with + | 0 => s1 + | S m => let s1 := rec m in b + end) N + in rest) + (at level 20). + +Check fun (a b : nat) => + let res := 0 in + for i from 0 to a updating (res) {{ + for j from 0 to b updating (res) {{ S res }};; + res + }};; res. + +End M6304. diff --git a/test-suite/output/Notations3.out b/test-suite/output/Notations3.out index 6ef75dd135..1b57252752 100644 --- a/test-suite/output/Notations3.out +++ b/test-suite/output/Notations3.out @@ -128,3 +128,13 @@ return (1, 2, 3, 4) : nat *(1.2) : nat +[{0; 0}] + : list (list nat) +[{1; 2; 3}; + {4; 5; 6}; + {7; 8; 9}] + : list (list nat) +amatch = mmatch 0 (with 0 => 1| 1 => 2 end) + : unit +alist = [0; 1; 2] + : list nat diff --git a/test-suite/output/Notations3.v b/test-suite/output/Notations3.v index 8c7bbe5917..a8d6c97fbd 100644 --- a/test-suite/output/Notations3.v +++ b/test-suite/output/Notations3.v @@ -59,7 +59,7 @@ Check fun f => CURRYINVLEFT (x:nat) (y:bool), f. (* Notations with variables bound both as a term and as a binder *) (* This is #4592 *) -Notation "{# x | P }" := (ex2 (fun y => x = y) (fun x => P)). +Notation "{# x | P }" := (ex2 (fun y => x = y) (fun x => P)) : type_scope. Check forall n:nat, {# n | 1 > n}. Parameter foo : forall {T}(x : T)(P : T -> Prop), Prop. @@ -183,9 +183,13 @@ Check letpair x [1] = {0}; return (1,2,3,4). (* Test spacing in #5569 *) +Section S1. +Variable plus : nat -> nat -> nat. +Infix "+" := plus. Notation "{ { xL | xR // xcut } }" := (xL+xR+xcut) (at level 0, xR at level 39, format "{ { xL | xR // xcut } }"). Check 1+1+1. +End S1. (* 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). @@ -193,7 +197,59 @@ Check !!! (x y:nat), True. (* Allow level for leftmost nonterminal when printing-only, BZ#5739 *) -Notation "* x" := (id x) (only printing, at level 15, format "* x"). -Notation "x . y" := (x + y) (only printing, at level 20, x at level 14, left associativity, format "x . y"). +Section S2. +Notation "* x" := (id x) (only printing, at level 15, format "* x") : nat_scope. +Notation "x . y" := (x + y) (only printing, at level 20, x at level 14, left associativity, format "x . y") : nat_scope. Check (((id 1) + 2) + 3). Check (id (1 + 2)). +End S2. + +(* Test printing of notations guided by scope *) + +Module A. + +Delimit Scope line_scope with line. +Notation "{ }" := nil (format "{ }") : line_scope. +Notation "{ x }" := (cons x nil) : line_scope. +Notation "{ x ; y ; .. ; z }" := (cons x (cons y .. (cons z nil) ..)) : line_scope. +Notation "[ ]" := nil (format "[ ]") : matx_scope. +Notation "[ l ]" := (cons l%line nil) : matx_scope. +Notation "[ l ; l' ; .. ; l'' ]" := (cons l%line (cons l'%line .. (cons l''%line nil) ..)) + (format "[ '[v' l ; '/' l' ; '/' .. ; '/' l'' ']' ]") : matx_scope. + +Open Scope matx_scope. +Check [[0;0]]. +Check [[1;2;3];[4;5;6];[7;8;9]]. + +End A. + +(* Example by Beta Ziliani *) + +Require Import Lists.List. + +Module B. + +Import ListNotations. + +Delimit Scope pattern_scope with pattern. +Delimit Scope patterns_scope with patterns. + +Notation "a => b" := (a, b) (at level 201) : pattern_scope. +Notation "'with' p1 | .. | pn 'end'" := + ((cons p1%pattern (.. (cons pn%pattern nil) ..))) + (at level 91, p1 at level 210, pn at level 210) : patterns_scope. + +Definition mymatch (n:nat) (l : list (nat * nat)) := tt. +Arguments mymatch _ _%patterns. +Notation "'mmatch' n ls" := (mymatch n ls) (at level 0). + +Close Scope patterns_scope. +Close Scope pattern_scope. + +Definition amatch := mmatch 0 with 0 => 1 | 1 => 2 end. +Print amatch. (* Good: amatch = mmatch 0 (with 0 => 1| 1 => 2 end) *) + +Definition alist := [0;1;2]. +Print alist. + +End B. diff --git a/test-suite/output/UnivBinders.out b/test-suite/output/UnivBinders.out index 904ff68aa7..d6d410d1ae 100644 --- a/test-suite/output/UnivBinders.out +++ b/test-suite/output/UnivBinders.out @@ -1,12 +1,175 @@ +NonCumulative Inductive Empty@{u} : Type@{u} := +NonCumulative Record PWrap (A : Type@{u}) : Type@{u} := pwrap { punwrap : A } + +PWrap has primitive projections with eta conversion. +For PWrap: Argument scope is [type_scope] +For pwrap: Argument scopes are [type_scope _] +punwrap@{u} = +fun (A : Type@{u}) (p : PWrap@{u} A) => punwrap _ p + : forall A : Type@{u}, PWrap@{u} A -> A +(* u |= *) + +punwrap is universe polymorphic +Argument scopes are [type_scope _] +NonCumulative Record RWrap (A : Type@{u}) : Type@{u} := rwrap { runwrap : A } + +For RWrap: Argument scope is [type_scope] +For rwrap: Argument scopes are [type_scope _] +runwrap@{u} = +fun (A : Type@{u}) (r : RWrap@{u} A) => let (runwrap) := r in runwrap + : forall A : Type@{u}, RWrap@{u} A -> A +(* u |= *) + +runwrap is universe polymorphic +Argument scopes are [type_scope _] +Wrap@{u} = fun A : Type@{u} => A + : Type@{u} -> Type@{u} +(* u |= *) + +Wrap is universe polymorphic +Argument scope is [type_scope] +wrap@{u} = +fun (A : Type@{u}) (Wrap : Wrap@{u} A) => Wrap + : forall A : Type@{u}, Wrap@{u} A -> A +(* u |= *) + +wrap is universe polymorphic +Arguments A, Wrap are implicit and maximally inserted +Argument scopes are [type_scope _] bar@{u} = nat : Wrap@{u} Set (* u |= Set < u *) 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@{u Top.17 v} = +Type@{Top.17} -> Type@{v} -> Type@{u} + : Type@{max(u+1,Top.17+1,v+1)} +(* u Top.17 v |= *) foo is universe polymorphic +Monomorphic mono = Type@{mono.u} + : Type@{mono.u+1} +(* {mono.u} |= *) + +mono is not universe polymorphic +mono + : Type@{mono.u+1} +Type@{mono.u} + : Type@{mono.u+1} +The command has indeed failed with message: +Universe u already exists. +monomono + : Type@{MONOU+1} +mono.monomono + : Type@{mono.MONOU+1} +monomono + : Type@{MONOU+1} +mono + : Type@{mono.u+1} +The command has indeed failed with message: +Universe u already exists. +bobmorane = +let tt := Type@{tt.v} in let ff := Type@{ff.v} in tt -> ff + : Type@{max(tt.u,ff.u)} +The command has indeed failed with message: +Universe u already bound. +foo@{E M N} = +Type@{M} -> Type@{N} -> Type@{E} + : Type@{max(E+1,M+1,N+1)} +(* E M N |= *) + +foo is universe polymorphic +foo@{Top.16 Top.17 Top.18} = +Type@{Top.17} -> Type@{Top.18} -> Type@{Top.16} + : Type@{max(Top.16+1,Top.17+1,Top.18+1)} +(* Top.16 Top.17 Top.18 |= *) + +foo is universe polymorphic +NonCumulative Inductive Empty@{E} : Type@{E} := +NonCumulative Record PWrap (A : Type@{E}) : Type@{E} := pwrap { punwrap : A } + +PWrap has primitive projections with eta conversion. +For PWrap: Argument scope is [type_scope] +For pwrap: Argument scopes are [type_scope _] +punwrap@{K} : forall A : Type@{K}, PWrap@{K} A -> A +(* K |= *) + +punwrap is universe polymorphic +Argument scopes are [type_scope _] +punwrap is transparent +Expands to: Constant Top.punwrap +The command has indeed failed with message: +Universe instance should have length 3 +The command has indeed failed with message: +Universe instance should have length 0 +The command has indeed failed with message: +This object does not support universe names. +The command has indeed failed with message: +Cannot enforce v < u because u < gU < gV < v +Monomorphic bind_univs.mono = +Type@{bind_univs.mono.u} + : Type@{bind_univs.mono.u+1} +(* {bind_univs.mono.u} |= *) + +bind_univs.mono is not universe polymorphic +bind_univs.poly@{u} = Type@{u} + : Type@{u+1} +(* u |= *) + +bind_univs.poly is universe polymorphic +insec@{v} = Type@{u} -> Type@{v} + : Type@{max(u+1,v+1)} +(* v |= *) + +insec is universe polymorphic +insec@{u v} = Type@{u} -> Type@{v} + : Type@{max(u+1,v+1)} +(* u v |= *) + +insec is universe polymorphic +inmod@{u} = Type@{u} + : Type@{u+1} +(* u |= *) + +inmod is universe polymorphic +SomeMod.inmod@{u} = Type@{u} + : Type@{u+1} +(* u |= *) + +SomeMod.inmod is universe polymorphic +inmod@{u} = Type@{u} + : Type@{u+1} +(* u |= *) + +inmod is universe polymorphic +Applied.infunct@{u v} = +inmod@{u} -> Type@{v} + : Type@{max(u+1,v+1)} +(* u v |= *) + +Applied.infunct is universe polymorphic +axfoo@{i Top.41 Top.42} : Type@{Top.41} -> Type@{i} +(* i Top.41 Top.42 |= *) + +axfoo is universe polymorphic +Argument scope is [type_scope] +Expands to: Constant Top.axfoo +axbar@{i Top.41 Top.42} : Type@{Top.42} -> Type@{i} +(* i Top.41 Top.42 |= *) + +axbar is universe polymorphic +Argument scope is [type_scope] +Expands to: Constant Top.axbar +axfoo' : Type@{Top.44} -> Type@{axbar'.i} + +axfoo' is not universe polymorphic +Argument scope is [type_scope] +Expands to: Constant Top.axfoo' +axbar' : Type@{Top.44} -> Type@{axbar'.i} + +axbar' is not universe polymorphic +Argument scope is [type_scope] +Expands to: Constant Top.axbar' +The command has indeed failed with message: +When declaring multiple axioms in one command, only the first is allowed a universe binder (which will be shared by the whole block). diff --git a/test-suite/output/UnivBinders.v b/test-suite/output/UnivBinders.v index 8656ff1a39..266d94ad99 100644 --- a/test-suite/output/UnivBinders.v +++ b/test-suite/output/UnivBinders.v @@ -1,13 +1,146 @@ Set Universe Polymorphism. Set Printing Universes. -Unset Strict Universe Declaration. +(* Unset Strict Universe Declaration. *) + +(* universe binders on inductive types and record projections *) +Inductive Empty@{u} : Type@{u} := . +Print Empty. + +Set Primitive Projections. +Record PWrap@{u} (A:Type@{u}) := pwrap { punwrap : A }. +Print PWrap. +Print punwrap. + +Unset Primitive Projections. +Record RWrap@{u} (A:Type@{u}) := rwrap { runwrap : A }. +Print RWrap. +Print runwrap. -Class Wrap A := wrap : A. +(* universe binders also go on the constants for operational typeclasses. *) +Class Wrap@{u} (A:Type@{u}) := wrap : A. +Print Wrap. +Print wrap. -Instance bar@{u} : Wrap@{u} Set. Proof nat. +(* Instance in lemma mode used to ignore the binders. *) +Instance bar@{u} : Wrap@{u} Set. Proof. exact nat. Qed. Print bar. +Unset Strict Universe Declaration. (* 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. +Set Strict Universe Declaration. + +(* Binders even work with monomorphic definitions! *) +Monomorphic Definition mono@{u} := Type@{u}. +Print mono. +Check mono. +Check Type@{mono.u}. + +Module mono. + Fail Monomorphic Universe u. + Monomorphic Universe MONOU. + + Monomorphic Definition monomono := Type@{MONOU}. + Check monomono. +End mono. +Check mono.monomono. (* qualified MONOU *) +Import mono. +Check monomono. (* unqualified MONOU *) +Check mono. (* still qualified mono.u *) + +Monomorphic Constraint Set < Top.mono.u. + +Module mono2. + Monomorphic Universe u. +End mono2. + +Fail Monomorphic Definition mono2@{u} := Type@{u}. + +Module SecLet. + Unset Universe Polymorphism. + Section foo. + (* Fail Let foo@{} := Type@{u}. (* doesn't parse: Let foo@{...} doesn't exist *) *) + Unset Strict Universe Declaration. + Let tt : Type@{u} := Type@{v}. (* names disappear in the ether *) + Let ff : Type@{u}. Proof. exact Type@{v}. Qed. (* if Set Universe Polymorphism: universes are named ff.u and ff.v. Otherwise names disappear into space *) + Definition bobmorane := tt -> ff. + End foo. + Print bobmorane. (* + bobmorane@{Top.15 Top.16 ff.u ff.v} = + let tt := Type@{Top.16} in let ff := Type@{ff.v} in tt -> ff + : Type@{max(Top.15,ff.u)} + (* Top.15 Top.16 ff.u ff.v |= Top.16 < Top.15 + ff.v < ff.u + *) + + bobmorane is universe polymorphic + *) +End SecLet. + +(* fun x x => foo is nonsense with local binders *) +Fail Definition fo@{u u} := Type@{u}. + +(* Using local binders for printing. *) +Print foo@{E M N}. +(* Underscores discard the name if there's one. *) +Print foo@{_ _ _}. + +(* Also works for inductives and records. *) +Print Empty@{E}. +Print PWrap@{E}. + +(* Also works for About. *) +About punwrap@{K}. + +(* Instance length check. *) +Fail Print foo@{E}. +Fail Print mono@{E}. + +(* Not everything can be printed with custom universe names. *) +Fail Print Coq.Init.Logic@{E}. + +(* Nice error when constraints are impossible. *) +Monomorphic Universes gU gV. Monomorphic Constraint gU < gV. +Fail Lemma foo@{u v|u < gU, gV < v, v < u} : nat. + +(* Universe binders survive through compilation, sections and modules. *) +Require TestSuite.bind_univs. +Print bind_univs.mono. +Print bind_univs.poly. + +Section SomeSec. + Universe u. + Definition insec@{v} := Type@{u} -> Type@{v}. + Print insec. +End SomeSec. +Print insec. + +Module SomeMod. + Definition inmod@{u} := Type@{u}. + Print inmod. +End SomeMod. +Print SomeMod.inmod. +Import SomeMod. +Print inmod. + +Module Type SomeTyp. Definition inmod := Type. End SomeTyp. +Module SomeFunct (In : SomeTyp). + Definition infunct@{u v} := In.inmod@{u} -> Type@{v}. +End SomeFunct. +Module Applied := SomeFunct(SomeMod). +Print Applied.infunct. + +(* Multi-axiom declaration + + In polymorphic mode the domain Type gets separate universes for the + different axioms, but all axioms have to declare all universes. In + polymorphic mode they get the same universes, ie the type is only + interpd once. *) +Axiom axfoo@{i+} axbar : Type -> Type@{i}. +Monomorphic Axiom axfoo'@{i+} axbar' : Type -> Type@{i}. + +About axfoo. About axbar. About axfoo'. About axbar'. + +Fail Axiom failfoo failbar@{i} : Type. diff --git a/test-suite/output/ltac.out b/test-suite/output/ltac.out index 35c3057d84..eb9f571022 100644 --- a/test-suite/output/ltac.out +++ b/test-suite/output/ltac.out @@ -1,7 +1,7 @@ The command has indeed failed with message: Ltac variable y depends on pattern variable name z which is not bound in current context. Ltac f x y z := - symmetry in x, y; auto with z; auto; intros **; clearbody x; generalize + symmetry in x, y; auto with z; auto; intros; clearbody x; generalize dependent z The command has indeed failed with message: In nested Ltac calls to "g1" and "refine (uconstr)", last call failed. @@ -31,3 +31,10 @@ nat nat 0 0 +Ltac foo := + let x := intros in + let y := intros -> in + let v := constr:(nil) in + let w := () in + let z := 1 in + pose v diff --git a/test-suite/output/ltac.v b/test-suite/output/ltac.v index 76c37625aa..6adbe95dd5 100644 --- a/test-suite/output/ltac.v +++ b/test-suite/output/ltac.v @@ -57,3 +57,14 @@ match goal with |- ?x*?y => idtac x end. match goal with H: context [?x*?y] |- _ => idtac x end. match goal with |- context [?x*?y] => idtac x end. Abort. + +(* Check printing of let in Ltac and Tactic Notation *) + +Ltac foo := + let x := intros in + let y := intros -> in + let v := constr:(@ nil True) in + let w := () in + let z := 1 in + pose v. +Print Ltac foo. diff --git a/test-suite/output/ltac_missing_args.out b/test-suite/output/ltac_missing_args.out index 172612405f..7326f137c2 100644 --- a/test-suite/output/ltac_missing_args.out +++ b/test-suite/output/ltac_missing_args.out @@ -1,20 +1,40 @@ The command has indeed failed with message: -A fully applied tactic is expected: missing argument for variable x. +The user-defined tactic "Top.foo" was not fully applied: +There is a missing argument for variable x, +no arguments at all were provided. The command has indeed failed with message: -A fully applied tactic is expected: missing argument for variable x. +The user-defined tactic "Top.bar" was not fully applied: +There is a missing argument for variable x, +no arguments at all were provided. The command has indeed failed with message: -A fully applied tactic is expected: missing arguments for variables y and _. +The user-defined tactic "Top.bar" was not fully applied: +There are missing arguments for variables y and _, +an argument was provided for variable x. The command has indeed failed with message: -A fully applied tactic is expected: missing argument for variable x. +The user-defined tactic "Top.baz" was not fully applied: +There is a missing argument for variable x, +no arguments at all were provided. The command has indeed failed with message: -A fully applied tactic is expected: missing argument for variable x. +The user-defined tactic "Top.qux" was not fully applied: +There is a missing argument for variable x, +no arguments at all were provided. The command has indeed failed with message: -A fully applied tactic is expected: missing argument for variable _. +The user-defined tactic "Top.mydo" was not fully applied: +There is a missing argument for variable _, +no arguments at all were provided. The command has indeed failed with message: -A fully applied tactic is expected: missing argument for variable _. +An unnamed user-defined tactic was not fully applied: +There is a missing argument for variable _, +no arguments at all were provided. The command has indeed failed with message: -A fully applied tactic is expected: missing argument for variable _. +An unnamed user-defined tactic was not fully applied: +There is a missing argument for variable _, +no arguments at all were provided. The command has indeed failed with message: -A fully applied tactic is expected: missing argument for variable x. +The user-defined tactic "Top.rec" was not fully applied: +There is a missing argument for variable x, +no arguments at all were provided. The command has indeed failed with message: -A fully applied tactic is expected: missing argument for variable x. +An unnamed user-defined tactic was not fully applied: +There is a missing argument for variable x, +an argument was provided for variable tac. diff --git a/test-suite/prerequisite/bind_univs.v b/test-suite/prerequisite/bind_univs.v new file mode 100644 index 0000000000..e834fde113 --- /dev/null +++ b/test-suite/prerequisite/bind_univs.v @@ -0,0 +1,7 @@ +(* Used in output/UnivBinders.v *) + +Monomorphic Definition mono@{u} := Type@{u}. + +Polymorphic Definition poly@{u} := Type@{u}. + +Monomorphic Universe reqU. diff --git a/test-suite/success/Notations.v b/test-suite/success/Notations.v index e3f90f6d94..3c0ad20700 100644 --- a/test-suite/success/Notations.v +++ b/test-suite/success/Notations.v @@ -147,3 +147,9 @@ Inductive EQ {A} (x:A) : A -> Prop := REFL : x === x Fail Check {x@{u},y|x=x}. Fail Check {?[n],y|0=0}. + +(* Check that 10 is well declared left associative *) + +Section C. +Notation "f $$$ x" := (id f x) (at level 10, left associativity). +End C. diff --git a/test-suite/success/Notations2.v b/test-suite/success/Notations2.v index 9505a56e3f..2655b651a0 100644 --- a/test-suite/success/Notations2.v +++ b/test-suite/success/Notations2.v @@ -90,3 +90,18 @@ Check fun A (x :prod' bool A) => match x with #### 0 y 0 => 2 | _ => 1 end. Notation "##### x" := (pair' x) (at level 0, x at level 1). Check ##### 0 _ 0%bool 0%bool : prod' bool bool. Check fun A (x :prod' bool A) => match x with ##### 0 _ y 0%bool => 2 | _ => 1 end. + +(* 10. Check computation of binding variable through other notations *) +(* i should be detected as binding variable and the scopes not being checked *) + +Notation "'FUNNAT' i => t" := (fun i : nat => i = t) (at level 200). +Notation "'Funnat' i => t" := (FUNNAT i => t + i%nat) (at level 200). + +(* 11. Notations with needed factorization of a recursive pattern *) +(* See https://github.com/coq/coq/issues/6078#issuecomment-342287412 *) +Module A. +Notation "[:: x1 ; .. ; xn & s ]" := (cons x1 .. (cons xn s) ..). +Notation "[:: x1 ; .. ; xn ]" := (cons x1 .. (cons xn nil) ..). +Check [:: 1 ; 2 ; 3 ]. +Check [:: 1 ; 2 ; 3 & nil ]. (* was failing *) +End A. diff --git a/test-suite/success/Typeclasses.v b/test-suite/success/Typeclasses.v index 6b1f0315bc..cd6eac35cf 100644 --- a/test-suite/success/Typeclasses.v +++ b/test-suite/success/Typeclasses.v @@ -240,3 +240,20 @@ Module IterativeDeepening. Qed. End IterativeDeepening. + +Module AxiomsAreInstances. + Set Typeclasses Axioms Are Instances. + Class TestClass1 := {}. + Axiom testax1 : TestClass1. + Definition testdef1 : TestClass1 := _. + + Unset Typeclasses Axioms Are Instances. + Class TestClass2 := {}. + Axiom testax2 : TestClass2. + Fail Definition testdef2 : TestClass2 := _. + + (* we didn't break typeclasses *) + Existing Instance testax2. + Definition testdef2 : TestClass2 := _. + +End AxiomsAreInstances. diff --git a/test-suite/success/bteauto.v b/test-suite/success/bteauto.v index 3178c6fc15..730b367d60 100644 --- a/test-suite/success/bteauto.v +++ b/test-suite/success/bteauto.v @@ -55,6 +55,7 @@ Module Backtracking. Axiom A : Type. Existing Class A. Axioms a b c d e: A. + Existing Instances a b c d e. Ltac get_value H := eval cbv delta [H] in H. diff --git a/test-suite/success/polymorphism.v b/test-suite/success/polymorphism.v index 7eaafc3545..d76b307914 100644 --- a/test-suite/success/polymorphism.v +++ b/test-suite/success/polymorphism.v @@ -190,6 +190,8 @@ Module binders. Fail Defined. Abort. + Fail Lemma bar@{u v | } : let x := (fun x => x) : Type@{u} -> Type@{v} in nat. + Lemma bar@{i j| i < j} : Type@{j}. Proof. exact Type@{i}. @@ -200,6 +202,10 @@ Module binders. exact Type@{i}. Qed. + Monomorphic Universe M. + Fail Definition with_mono@{u|} : Type@{M} := Type@{u}. + Definition with_mono@{u|u < M} : Type@{M} := Type@{u}. + End binders. Section cats. @@ -399,6 +405,31 @@ Module Anonymous. End Anonymous. +Module Restrict. + (* Universes which don't appear in the term should be pruned, unless they have names *) + Set Universe Polymorphism. + + Ltac exact0 := let x := constr:(Type) in exact 0. + Definition dummy_pruned@{} : nat := ltac:(exact0). + + Definition named_not_pruned@{u} : nat := 0. + Check named_not_pruned@{_}. + + Definition named_not_pruned_nonstrict : nat := ltac:(let x := constr:(Type@{u}) in exact 0). + Check named_not_pruned_nonstrict@{_}. + + Lemma lemma_restrict_poly@{} : nat. + Proof. exact0. Defined. + + Unset Universe Polymorphism. + Lemma lemma_restrict_mono_qed@{} : nat. + Proof. exact0. Qed. + + Lemma lemma_restrict_abstract@{} : nat. + Proof. abstract exact0. Qed. + +End Restrict. + Module F. Context {A B : Type}. Definition foo : Type := B. @@ -430,3 +461,10 @@ Section test_letin_subtyping. Qed. End test_letin_subtyping. + +Module ObligationRegression. + (** Test for a regression encountered when fixing obligations for + stronger restriction of universe context. *) + Require Import CMorphisms. + Check trans_co_eq_inv_arrow_morphism@{_ _ _ _ _ _ _ _}. +End ObligationRegression. diff --git a/test-suite/success/unidecls.v b/test-suite/success/unidecls.v new file mode 100644 index 0000000000..c4a1d7c28f --- /dev/null +++ b/test-suite/success/unidecls.v @@ -0,0 +1,121 @@ +Set Printing Universes. + +Module unidecls. + Universes a b. +End unidecls. + +Universe a. + +Constraint a < unidecls.a. + +Print Universes. + +(** These are different universes *) +Check Type@{a}. +Check Type@{unidecls.a}. + +Check Type@{unidecls.b}. + +Fail Check Type@{unidecls.c}. + +Fail Check Type@{i}. +Universe foo. +Module Foo. + (** Already declared globaly: but universe names are scoped at the module level *) + Universe foo. + Universe bar. + + Check Type@{Foo.foo}. + Definition bar := 0. +End Foo. + +(** Already declared in the module *) +Universe bar. + +(** Accessible outside the module: universe declarations are global *) +Check Type@{bar}. +Check Type@{Foo.bar}. + +Check Type@{Foo.foo}. +(** The same *) +Check Type@{foo}. +Check Type@{Top.foo}. + +Universe secfoo. +Section Foo'. + Fail Universe secfoo. + Universe secfoo2. + Check Type@{Foo'.secfoo2}. + Constraint secfoo2 < a. +End Foo'. + +Check Type@{secfoo2}. +Fail Check Type@{Foo'.secfoo2}. +Fail Check eq_refl : Type@{secfoo2} = Type@{a}. + +(** Below, u and v are global, fixed universes *) +Module Type Arg. + Universe u. + Parameter T: Type@{u}. +End Arg. + +Module Fn(A : Arg). + Universes v. + + Check Type@{A.u}. + Constraint A.u < v. + + Definition foo : Type@{v} := nat. + Definition bar : Type@{A.u} := nat. + + Fail Definition foo(A : Type@{v}) : Type@{A.u} := A. +End Fn. + +Module ArgImpl : Arg. + Definition T := nat. +End ArgImpl. + +Module ArgImpl2 : Arg. + Definition T := bool. +End ArgImpl2. + +(** Two applications of the functor result in the exact same universes *) +Module FnApp := Fn(ArgImpl). + +Check Type@{FnApp.v}. +Check FnApp.foo. +Check FnApp.bar. + +Check (eq_refl : Type@{ArgImpl.u} = Type@{ArgImpl2.u}). + +Module FnApp2 := Fn(ArgImpl). +Check Type@{FnApp2.v}. +Check FnApp2.foo. +Check FnApp2.bar. + +Import ArgImpl2. +(** Now u refers to ArgImpl.u and ArgImpl2.u *) +Check FnApp2.bar. + +(** It can be shadowed *) +Universe u. + +(** This refers to the qualified name *) +Check FnApp2.bar. + +Constraint u = ArgImpl.u. +Print Universes. + +Set Universe Polymorphism. + +Section PS. + Universe poly. + + Definition id (A : Type@{poly}) (a : A) : A := a. +End PS. +(** The universe is polymorphic and discharged, does not persist *) +Fail Check Type@{poly}. + +Print Universes. +Check id nat. +Check id@{Set}. diff --git a/theories/Compat/Coq87.v b/theories/Compat/Coq87.v index ef1737bf85..aeef9595d3 100644 --- a/theories/Compat/Coq87.v +++ b/theories/Compat/Coq87.v @@ -15,3 +15,6 @@ and breaks at least fiat-crypto. *) Declare ML Module "omega_plugin". Unset Omega UseLocalDefs. + + +Set Typeclasses Axioms Are Instances. diff --git a/theories/Logic/FunctionalExtensionality.v b/theories/Logic/FunctionalExtensionality.v index ac95ddd0c5..82b04d1322 100644 --- a/theories/Logic/FunctionalExtensionality.v +++ b/theories/Logic/FunctionalExtensionality.v @@ -221,13 +221,12 @@ Tactic Notation "extensionality" "in" hyp(H) := (* If we [subst H], things break if we already have another equation of the form [_ = H] *) destruct Heq; rename H_out into H. -(** Eta expansion follows from extensionality. *) +(** Eta expansion is built into Coq. *) Lemma eta_expansion_dep {A} {B : A -> Type} (f : forall x : A, B x) : f = fun x => f x. Proof. intros. - extensionality x. reflexivity. Qed. diff --git a/theories/Program/Combinators.v b/theories/Program/Combinators.v index 90db10ef1a..237d878bfb 100644 --- a/theories/Program/Combinators.v +++ b/theories/Program/Combinators.v @@ -22,15 +22,13 @@ Open Scope program_scope. Lemma compose_id_left : forall A B (f : A -> B), id ∘ f = f. Proof. intros. - unfold id, compose. - symmetry. apply eta_expansion. + reflexivity. Qed. Lemma compose_id_right : forall A B (f : A -> B), f ∘ id = f. Proof. intros. - unfold id, compose. - symmetry ; apply eta_expansion. + reflexivity. Qed. Lemma compose_assoc : forall A B C D (f : A -> B) (g : B -> C) (h : C -> D), @@ -47,9 +45,7 @@ Hint Rewrite <- @compose_assoc : core. Lemma flip_flip : forall A B C, @flip A B C ∘ flip = id. Proof. - unfold flip, compose. intros. - extensionality x ; extensionality y ; extensionality z. reflexivity. Qed. @@ -57,9 +53,7 @@ Qed. Lemma prod_uncurry_curry : forall A B C, @prod_uncurry A B C ∘ prod_curry = id. Proof. - simpl ; intros. - unfold prod_uncurry, prod_curry, compose. - extensionality x ; extensionality y ; extensionality z. + intros. reflexivity. Qed. diff --git a/theories/Sets/Powerset_facts.v b/theories/Sets/Powerset_facts.v index 2dd559a95c..209c22f71b 100644 --- a/theories/Sets/Powerset_facts.v +++ b/theories/Sets/Powerset_facts.v @@ -40,6 +40,11 @@ Section Sets_as_an_algebra. auto 6 with sets. Qed. + Theorem Empty_set_zero_right : forall X:Ensemble U, Union U X (Empty_set U) = X. + Proof. + auto 6 with sets. + Qed. + Theorem Empty_set_zero' : forall x:U, Add U (Empty_set U) x = Singleton U x. Proof. unfold Add at 1; auto using Empty_set_zero with sets. @@ -131,6 +136,17 @@ Section Sets_as_an_algebra. elim H'; intros x0 H'0; elim H'0; auto with sets. Qed. + Lemma Distributivity_l + : forall (A B C : Ensemble U), + Intersection U (Union U A B) C = + Union U (Intersection U A C) (Intersection U B C). + Proof. + intros A B C. + rewrite Intersection_commutative. + rewrite Distributivity. + f_equal; apply Intersection_commutative. + Qed. + Theorem Distributivity' : forall A B C:Ensemble U, Union U A (Intersection U B C) = @@ -251,6 +267,81 @@ Section Sets_as_an_algebra. intros; apply Definition_of_covers; auto with sets. Qed. + Lemma Disjoint_Intersection: + forall A s1 s2, Disjoint A s1 s2 -> Intersection A s1 s2 = Empty_set A. + Proof. + intros. apply Extensionality_Ensembles. split. + * destruct H. + intros x H1. unfold In in *. exfalso. intuition. apply (H _ H1). + * intuition. + Qed. + + Lemma Intersection_Empty_set_l: + forall A s, Intersection A (Empty_set A) s = Empty_set A. + Proof. + intros. auto with sets. + Qed. + + Lemma Intersection_Empty_set_r: + forall A s, Intersection A s (Empty_set A) = Empty_set A. + Proof. + intros. auto with sets. + Qed. + + Lemma Seminus_Empty_set_l: + forall A s, Setminus A (Empty_set A) s = Empty_set A. + Proof. + intros. apply Extensionality_Ensembles. split. + * intros x H1. destruct H1. unfold In in *. assumption. + * intuition. + Qed. + + Lemma Seminus_Empty_set_r: + forall A s, Setminus A s (Empty_set A) = s. + Proof. + intros. apply Extensionality_Ensembles. split. + * intros x H1. destruct H1. unfold In in *. assumption. + * intuition. + Qed. + + Lemma Setminus_Union_l: + forall A s1 s2 s3, + Setminus A (Union A s1 s2) s3 = Union A (Setminus A s1 s3) (Setminus A s2 s3). + Proof. + intros. apply Extensionality_Ensembles. split. + * intros x H. inversion H. inversion H0; intuition. + * intros x H. constructor; inversion H; inversion H0; intuition. + Qed. + + Lemma Setminus_Union_r: + forall A s1 s2 s3, + Setminus A s1 (Union A s2 s3) = Setminus A (Setminus A s1 s2) s3. + Proof. + intros. apply Extensionality_Ensembles. split. + * intros x H. inversion H. constructor. intuition. contradict H1. intuition. + * intros x H. inversion H. inversion H0. constructor; intuition. inversion H4; intuition. + Qed. + + Lemma Setminus_Disjoint_noop: + forall A s1 s2, + Intersection A s1 s2 = Empty_set A -> Setminus A s1 s2 = s1. + Proof. + intros. apply Extensionality_Ensembles. split. + * intros x H1. inversion_clear H1. intuition. + * intros x H1. constructor; intuition. contradict H. + apply Inhabited_not_empty. + exists x. intuition. + Qed. + + Lemma Setminus_Included_empty: + forall A s1 s2, + Included A s1 s2 -> Setminus A s1 s2 = Empty_set A. + Proof. + intros. apply Extensionality_Ensembles. split. + * intros x H1. inversion_clear H1. contradiction H2. intuition. + * intuition. + Qed. + End Sets_as_an_algebra. Hint Resolve Empty_set_zero Empty_set_zero' Union_associative Union_add diff --git a/tools/CoqMakefile.in b/tools/CoqMakefile.in index 32abba0eb5..6e87e67bbc 100644 --- a/tools/CoqMakefile.in +++ b/tools/CoqMakefile.in @@ -172,13 +172,16 @@ COQDOCFLAGS?=-interpolate -utf8 $(COQLIBS_NOML) # The version of Coq being run and the version of coq_makefile that # generated this makefile -COQ_VERSION:=$(shell $(COQC) --print-version | cut -d ' ' -f 1) +COQ_VERSION:=$(shell $(COQC) --print-version | cut -d " " -f 1) COQMAKEFILE_VERSION:=@COQ_VERSION@ COQSRCLIBS?= $(foreach d,$(COQ_SRC_SUBDIRS), -I "$(COQLIB)$(d)") CAMLFLAGS+=$(OCAMLLIBS) $(COQSRCLIBS) -I $(CAMLP4LIB) $(OCAML_API_FLAGS) +# ocamldoc fails with unknown argument otherwise +CAMLDOCFLAGS=$(filter-out -annot, $(filter-out -bin-annot, $(CAMLFLAGS))) + # FIXME This should be generated by Coq GRAMMARS:=grammar.cma ifeq ($(CAMLP4),camlp5) @@ -391,7 +394,7 @@ checkproofs: .PHONY: checkproofs validate: $(VOFILES) - $(TIMER) $(COQCHK) $(COQCHKFLAGS) $(notdir $(^:.vo=)) + $(TIMER) $(COQCHK) $(COQCHKFLAGS) $^ .PHONY: validate only: $(TGTS) @@ -409,12 +412,12 @@ mlihtml: $(MLIFILES:.mli=.cmi) $(SHOW)'CAMLDOC -d $@' $(HIDE)mkdir $@ || rm -rf $@/* $(HIDE)$(CAMLDOC) -html \ - -d $@ -m A $(CAMLDEBUG) $(CAMLFLAGS) $(MLIFILES) + -d $@ -m A $(CAMLDEBUG) $(CAMLDOCFLAGS) $(MLIFILES) all-mli.tex: $(MLIFILES:.mli=.cmi) $(SHOW)'CAMLDOC -latex $@' $(HIDE)$(CAMLDOC) -latex \ - -o $@ -m A $(CAMLDEBUG) $(CAMLFLAGS) $(MLIFILES) + -o $@ -m A $(CAMLDEBUG) $(CAMLDOCFLAGS) $(MLIFILES) gallina: $(GFILES) diff --git a/tools/TimeFileMaker.py b/tools/TimeFileMaker.py index 7298ef5e8e..a5a5fa8fe5 100644 --- a/tools/TimeFileMaker.py +++ b/tools/TimeFileMaker.py @@ -55,12 +55,15 @@ def get_single_file_times(file_name): FORMAT = 'Chars %%0%dd - %%0%dd %%s' % (longest, longest) return dict((FORMAT % (int(start), int(stop), name), reformat_time_string(time)) for start, stop, name, time, extra in times) +def fix_sign_for_sorting(num, descending=True): + return -num if descending else num + def make_sorting_key(times_dict, descending=True): def get_key(name): minutes, seconds = times_dict[name].replace('s', '').split('m') - def fix_sign(num): - return -num if descending else num - return (fix_sign(int(minutes)), fix_sign(float(seconds)), name) + return (fix_sign_for_sorting(int(minutes), descending=descending), + fix_sign_for_sorting(float(seconds), descending=descending), + name) return get_key def get_sorted_file_list_from_times_dict(times_dict, descending=True): @@ -123,7 +126,7 @@ def make_diff_table_string(left_times_dict, right_times_dict, for name, lseconds, rseconds in prediff_times) # update to sort by approximate difference, first get_key = make_sorting_key(all_names_dict, descending=descending) - all_names_dict = dict((name, (abs(int(to_seconds(diff_times_dict[name]))), get_key(name))) + all_names_dict = dict((name, (fix_sign_for_sorting(int(abs(to_seconds(diff_times_dict[name]))), descending=descending), get_key(name))) for name in all_names_dict.keys()) names = sorted(all_names_dict.keys(), key=all_names_dict.get) #names = get_sorted_file_list_from_times_dict(all_names_dict, descending=descending) diff --git a/tools/coq-inferior.el b/tools/inferior-coq.el index b79d97d66e..b79d97d66e 100644 --- a/tools/coq-inferior.el +++ b/tools/inferior-coq.el diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml index c808992887..3a195c1df0 100644 --- a/toplevel/coqinit.ml +++ b/toplevel/coqinit.ml @@ -65,7 +65,7 @@ let add_stdlib_path ~load_init ~unix_path ~coq_root ~with_ml = let add_userlib_path ~unix_path = Mltop.add_rec_path Mltop.AddRecML ~unix_path - ~coq_root:Nameops.default_root_prefix ~implicit:false + ~coq_root:Libnames.default_root_prefix ~implicit:false (* Options -I, -I-as, and -R of the command line *) let includes = ref [] @@ -80,7 +80,7 @@ let init_load_path ~load_init = let user_contrib = coqlib/"user-contrib" in let xdg_dirs = Envars.xdg_dirs ~warn:(fun x -> Feedback.msg_warning (str x)) in let coqpath = Envars.coqpath in - let coq_root = Names.DirPath.make [Nameops.coq_root] in + let coq_root = Names.DirPath.make [Libnames.coq_root] in (* NOTE: These directories are searched from last to first *) (* first, developer specific directory to open *) if Coq_config.local then @@ -105,7 +105,7 @@ let init_load_path ~load_init = List.iter (fun s -> add_userlib_path ~unix_path:s) coqpath; (* then current directory (not recursively!) *) Mltop.add_ml_dir "."; - Loadpath.add_load_path "." Nameops.default_root_prefix ~implicit:false; + Loadpath.add_load_path "." Libnames.default_root_prefix ~implicit:false; (* additional loadpath, given with options -Q and -R *) List.iter (fun (unix_path, coq_root, implicit) -> diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index f3d5d9b859..553da2dc03 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -333,8 +333,8 @@ let compile ~verbosely ~f_in ~f_out = (Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1)); Aux_file.stop_aux_file (); Dumpglob.end_dump_glob () - | BuildVio -> + | BuildVio -> Flags.record_aux_file := false; Dumpglob.noglob (); @@ -734,9 +734,7 @@ let parse_args arglist = |"-profile-ltac" -> Flags.profile_ltac := true |"-q" -> Coqinit.no_load_rc () |"-quiet"|"-silent" -> Flags.quiet := true; Flags.make_warn false - |"-quick" -> - Safe_typing.allow_delayed_constants := true; - compilation_mode := BuildVio + |"-quick" -> compilation_mode := BuildVio |"-list-tags" -> print_tags := true |"-time" -> Flags.time := true |"-type-in-type" -> set_type_in_type () @@ -844,8 +842,10 @@ let start () = exit 1 | _ -> flush_all(); - if !output_context then - Feedback.msg_notice Flags.(with_option raw_print Prettyp.print_full_pure_context () ++ fnl ()); + if !output_context then begin + let sigma, env = Pfedit.get_current_context () in + Feedback.msg_notice (Flags.(with_option raw_print (Prettyp.print_full_pure_context env) sigma) ++ fnl ()) + end; Profile.print_profile (); exit 0 diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index cf63fbdc3d..8fdaedbaf7 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -100,7 +100,9 @@ let print_cmd_header ?loc com = Format.pp_print_flush !Topfmt.std_ft () let pr_open_cur_subgoals () = - try Printer.pr_open_subgoals () + try + let proof = Proof_global.give_me_the_proof () in + Printer.pr_open_subgoals ~proof with Proof_global.NoCurrentProof -> Pp.str "" (* Reenable when we get back to feedback printing *) diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index 9e63df51de..51dd5cd4f5 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -377,6 +377,7 @@ let do_replace_lb mode lb_scheme_key aavoid narg p q = Proofview.Goal.enter begin fun gl -> let type_of_pq = Tacmach.New.pf_unsafe_type_of gl p in let sigma = Tacmach.New.project gl in + let env = Tacmach.New.pf_env gl in let u,v = destruct_ind sigma type_of_pq in let lb_type_of_p = try @@ -389,7 +390,7 @@ let do_replace_lb mode lb_scheme_key aavoid narg p q = (str "Leibniz->boolean:" ++ str "You have to declare the" ++ str "decidability over " ++ - Printer.pr_econstr type_of_pq ++ + Printer.pr_econstr_env env sigma type_of_pq ++ str " first.") in Tacticals.New.tclZEROMSG err_msg @@ -442,6 +443,7 @@ let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt = Proofview.Goal.enter begin fun gl -> let tt1 = Tacmach.New.pf_unsafe_type_of gl t1 in let sigma = Tacmach.New.project gl in + let env = Tacmach.New.pf_env gl in if EConstr.eq_constr sigma t1 t2 then aux q1 q2 else ( let u,v = try destruct_ind sigma tt1 @@ -461,7 +463,7 @@ let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt = (str "boolean->Leibniz:" ++ str "You have to declare the" ++ str "decidability over " ++ - Printer.pr_econstr tt1 ++ + Printer.pr_econstr_env env sigma tt1 ++ str " first.") in user_err err_msg diff --git a/vernac/class.ml b/vernac/class.ml index 44f20a0887..943da8fa8a 100644 --- a/vernac/class.ml +++ b/vernac/class.ml @@ -212,10 +212,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 univs = Evd.const_univ_entry ~poly sigma in let constr_entry = (* Cast is necessary to express [val_f] is identity *) DefinitionEntry - (definition_entry ~types:typ_f ~poly ~univs + (definition_entry ~types:typ_f ~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 20cb43b24e..3e47f881c1 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -114,19 +114,20 @@ let instance_hook k info global imps ?hook cst = 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 + let evm = + let env = Global.env () in + let levels = Univ.LSet.union (Univops.universes_of_constr env termtype) + (Univops.universes_of_constr env term) in Evd.restrict_universe_context evm levels in - let pl, uctx = Evd.check_univ_decl evm decl in + let uctx = Evd.check_univ_decl ~poly evm decl in let entry = - Declare.definition_entry ~types:termtype ~poly ~univs:uctx term + Declare.definition_entry ~types:termtype ~univs:uctx term in let cdecl = (DefinitionEntry entry, kind) in let kn = Declare.declare_constant id cdecl in Declare.definition_message id; - Universes.register_universe_binders (ConstRef kn) pl; + Declare.declare_univ_binders (ConstRef kn) (Evd.universe_binders evm); instance_hook k info global imps ?hook (ConstRef kn); id @@ -200,16 +201,16 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) let nf, subst = Evarutil.e_nf_evars_and_universes evars in let termtype = let t = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in - nf t - in - Pretyping.check_evars env Evd.empty !evars (EConstr.of_constr termtype); - 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) - in - Universes.register_universe_binders (ConstRef cst) pl; - instance_hook k pri global imps ?hook (ConstRef cst); id + nf t + in + Pretyping.check_evars env Evd.empty !evars (EConstr.of_constr termtype); + let univs = Evd.check_univ_decl ~poly !evars decl in + let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest id + (ParameterEntry + (None,(termtype,univs),None), Decl_kinds.IsAssumption Decl_kinds.Logical) + in + Declare.declare_univ_binders (ConstRef cst) (Evd.universe_binders !evars); + instance_hook k pri global imps ?hook (ConstRef cst); id end else ( let props = @@ -384,14 +385,17 @@ let context poly l = let uctx = ref (Evd.universe_context_set !evars) in let fn status (id, b, t) = if Lib.is_modtype () && not (Lib.sections_are_opened ()) then - let ctx = Univ.ContextSet.to_context !uctx in (* Declare the universe context once *) + let univs = if poly + then Polymorphic_const_entry (Univ.ContextSet.to_context !uctx) + else Monomorphic_const_entry !uctx + in let () = uctx := Univ.ContextSet.empty in let decl = match b with | None -> - (ParameterEntry (None,poly,(t,ctx),None), IsAssumption Logical) + (ParameterEntry (None,(t,univs),None), IsAssumption Logical) | Some b -> - let entry = Declare.definition_entry ~poly ~univs:ctx ~types:t b in + let entry = Declare.definition_entry ~univs ~types:t b in (DefinitionEntry entry, IsAssumption Logical) in let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest id decl in @@ -409,16 +413,19 @@ let context poly l = in let impl = List.exists test impls in let decl = (Discharge, poly, Definitional) in + let univs = if poly + then Polymorphic_const_entry (Univ.ContextSet.to_context !uctx) + else Monomorphic_const_entry !uctx + in let nstatus = match b with | None -> - pi3 (Command.declare_assumption false decl (t, !uctx) [] [] impl + pi3 (Command.declare_assumption false decl (t, univs) Universes.empty_binders [] impl Vernacexpr.NoInline (Loc.tag id)) | Some b -> - let ctx = Univ.ContextSet.to_context !uctx in let decl = (Discharge, poly, Definition) in - let entry = Declare.definition_entry ~poly ~univs:ctx ~types:t b in + let entry = Declare.definition_entry ~univs ~types:t b in let hook = Lemmas.mk_hook (fun _ gr -> gr) in - let _ = DeclareDef.declare_definition id decl entry [] [] hook in + let _ = DeclareDef.declare_definition id decl entry Universes.empty_binders [] hook in Lib.sections_are_opened () || Lib.is_modtype_strict () in status && nstatus diff --git a/vernac/command.ml b/vernac/command.ml index be54f97b72..23be2c3082 100644 --- a/vernac/command.ml +++ b/vernac/command.ml @@ -8,8 +8,8 @@ open Pp open CErrors +open Sorts open Util -open Term open Constr open Vars open Termops @@ -22,7 +22,6 @@ open Globnames open Nameops open Constrexpr open Constrexpr_ops -open Topconstr open Constrintern open Nametab open Impargs @@ -89,14 +88,14 @@ let warn_implicits_in_term = strbrk "Implicit arguments declaration relies on type." ++ spc () ++ strbrk "The term declares more implicits than the type here.") -let interp_definition pl bl p red_option c ctypopt = +let interp_definition pl bl poly red_option c ctypopt = let env = Global.env() in let evd, decl = Univdecls.interp_univ_decl_opt env pl in let evdref = ref evd in let impls, ((env_bl, ctx), imps1) = interp_context_evars env evdref bl in let ctx = List.map (fun d -> map_rel_decl EConstr.Unsafe.to_constr d) ctx in let nb_args = Context.Rel.nhyps ctx in - let imps,pl,ce = + let imps,ce = match ctypopt with None -> let subst = evd_comb0 Evd.nf_univ_variables evdref in @@ -106,14 +105,14 @@ let interp_definition pl bl p red_option c ctypopt = let c = EConstr.Unsafe.to_constr c in let nf,subst = Evarutil.e_nf_evars_and_universes evdref in let body = nf (it_mkLambda_or_LetIn c ctx) in - let vars = Univops.universes_of_constr body in - let evd = Evd.restrict_universe_context !evdref vars 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 + let vars = EConstr.universes_of_constr env !evdref (EConstr.of_constr body) in + let () = evdref := Evd.restrict_universe_context !evdref vars in + let uctx = Evd.check_univ_decl ~poly !evdref decl in + imps1@(Impargs.lift_implicits nb_args imps2), + definition_entry ~univs:uctx body | Some ctyp -> - let ty, impsty = interp_type_evars_impls ~impls env_bl evdref ctyp in - let subst = evd_comb0 Evd.nf_univ_variables evdref in + let ty, impsty = interp_type_evars_impls ~impls env_bl evdref ctyp in + let subst = evd_comb0 Evd.nf_univ_variables evdref in let ctx = Context.Rel.map (Vars.subst_univs_constr subst) ctx in let env_bl = push_rel_context ctx env in let c, imps2 = interp_casted_constr_evars_impls ~impls env_bl evdref c ty in @@ -131,22 +130,22 @@ let interp_definition pl bl p red_option c ctypopt = in if not (try List.for_all chk imps2 with Not_found -> false) then warn_implicits_in_term (); - 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.check_univ_decl ctx decl in - imps1@(Impargs.lift_implicits nb_args impsty), pl, - definition_entry ~types:typ ~poly:p - ~univs:uctx body + let bodyvars = EConstr.universes_of_constr env !evdref (EConstr.of_constr body) in + let tyvars = EConstr.universes_of_constr env !evdref (EConstr.of_constr ty) in + let vars = Univ.LSet.union bodyvars tyvars in + let () = evdref := Evd.restrict_universe_context !evdref vars in + let uctx = Evd.check_univ_decl ~poly !evdref decl in + imps1@(Impargs.lift_implicits nb_args impsty), + definition_entry ~types:typ ~univs:uctx body in - red_constant_entry (Context.Rel.length ctx) ce !evdref red_option, !evdref, decl, pl, imps + (red_constant_entry (Context.Rel.length ctx) ce !evdref red_option, !evdref, decl, 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 univdecl bl red_option c ctypopt hook = - let (ce, evd, univdecl, pl', imps as def) = + let (ce, evd, univdecl, imps as def) = interp_definition univdecl bl (pi2 k) red_option c ctypopt in if Flags.is_program_mode () then @@ -167,15 +166,37 @@ let do_definition ident k univdecl bl red_option c ctypopt hook = 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 + ignore(DeclareDef.declare_definition ident k ce (Evd.universe_binders evd) imps (Lemmas.mk_hook (fun l r -> Lemmas.call_hook (fun exn -> exn) hook l r;r))) (* 2| Variable/Hypothesis/Parameter/Axiom declarations *) +let axiom_into_instance = ref false + +let _ = + let open Goptions in + declare_bool_option + { optdepr = false; + optname = "automatically declare axioms whose type is a typeclass as instances"; + optkey = ["Typeclasses";"Axioms";"Are";"Instances"]; + optread = (fun _ -> !axiom_into_instance); + optwrite = (:=) axiom_into_instance; } + +let should_axiom_into_instance = function + | Discharge -> + (* The typeclass behaviour of Variable and Context doesn't depend + on section status *) + true + | Global | Local -> !axiom_into_instance + let declare_assumption is_coe (local,p,kind) (c,ctx) pl imps impl nl (_,ident) = match local with | Discharge when Lib.sections_are_opened () -> + let ctx = match ctx with + | Monomorphic_const_entry ctx -> ctx + | Polymorphic_const_entry ctx -> Univ.ContextSet.of_context ctx + in let decl = (Lib.cwd(), SectionLocalAssum ((c,ctx),p,impl), IsAssumption kind) in let _ = declare_variable ident decl in let () = assumption_message ident in @@ -190,24 +211,24 @@ match local with (r,Univ.Instance.empty,true) | Global | Local | Discharge -> + let do_instance = should_axiom_into_instance local in let local = DeclareDef.get_locality ident ~kind:"axiom" local in let inl = match nl with | NoInline -> None | DefaultInline -> Some (Flags.get_inline_level()) | InlineAt i -> Some i in - let ctx = Univ.ContextSet.to_context ctx in - let decl = (ParameterEntry (None,p,(c,ctx),inl), IsAssumption kind) in + let decl = (ParameterEntry (None,(c,ctx),inl), IsAssumption kind) in let kn = declare_constant ident ~local decl in let gr = ConstRef kn in let () = maybe_declare_manual_implicits false gr imps in - let () = Universes.register_universe_binders gr pl in + let () = Declare.declare_univ_binders gr pl in let () = assumption_message ident in - let () = Typeclasses.declare_instance None false gr in + let () = if do_instance then Typeclasses.declare_instance None false gr in let () = if is_coe then Class.try_add_new_coercion gr ~local p in - let inst = - if p (* polymorphic *) then Univ.UContext.instance ctx - else Univ.Instance.empty + let inst = match ctx with + | Polymorphic_const_entry ctx -> Univ.UContext.instance ctx + | Monomorphic_const_entry _ -> Univ.Instance.empty in (gr,inst,Lib.is_modtype_strict ()) @@ -217,26 +238,63 @@ let interp_assumption evdref env impls bl c = let ty = EConstr.Unsafe.to_constr ty in (ty, impls) -let declare_assumptions idl is_coe k (c,ctx) pl imps impl_is_on nl = +(* When monomorphic the universe constraints are declared with the first declaration only. *) +let next_uctx = + let empty_uctx = Monomorphic_const_entry Univ.ContextSet.empty in + function + | Polymorphic_const_entry _ as uctx -> uctx + | Monomorphic_const_entry _ -> empty_uctx + +let declare_assumptions idl is_coe k (c,uctx) pl imps nl = let refs, status, _ = - List.fold_left (fun (refs,status,ctx) id -> + List.fold_left (fun (refs,status,uctx) id -> let ref',u',status' = - declare_assumption is_coe k (c,ctx) pl imps impl_is_on nl id in - (ref',u')::refs, status' && status, Univ.ContextSet.empty) - ([],true,ctx) idl + declare_assumption is_coe k (c,uctx) pl imps false nl id in + (ref',u')::refs, status' && status, next_uctx uctx) + ([],true,uctx) idl in List.rev refs, status -let do_assumptions_unbound_univs (_, poly, _ as kind) nl l = + +let maybe_error_many_udecls = function + | ((loc,id), Some _) -> + user_err ?loc ~hdr:"many_universe_declarations" + Pp.(str "When declaring multiple axioms in one command, " ++ + str "only the first is allowed a universe binder " ++ + str "(which will be shared by the whole block).") + | (_, None) -> () + +let process_assumptions_udecls kind l = + let udecl, first_id = match l with + | (coe, ((id, udecl)::rest, c))::rest' -> + List.iter maybe_error_many_udecls rest; + List.iter (fun (coe, (idl, c)) -> List.iter maybe_error_many_udecls idl) rest'; + udecl, id + | (_, ([], _))::_ | [] -> assert false + in + let () = match kind, udecl with + | (Discharge, _, _), Some _ when Lib.sections_are_opened () -> + let loc = fst first_id in + let msg = Pp.str "Section variables cannot be polymorphic." in + user_err ?loc msg + | _ -> () + in + udecl, List.map (fun (coe, (idl, c)) -> coe, (List.map fst idl, c)) l + +let do_assumptions kind nl l = let open Context.Named.Declaration in let env = Global.env () in - let evdref = ref (Evd.from_env env) in - let l = - if poly then + let udecl, l = process_assumptions_udecls kind l in + let evdref, udecl = + let evd, udecl = Univdecls.interp_univ_decl_opt env udecl in + ref evd, udecl + in + let l = + if pi2 kind (* poly *) then (* Separate declarations so that A B : Type puts A and B in different levels. *) List.fold_right (fun (is_coe,(idl,c)) acc -> - List.fold_right (fun id acc -> - (is_coe, ([id], c)) :: acc) idl acc) + List.fold_right (fun id acc -> + (is_coe, ([id], c)) :: acc) idl acc) l [] else l in @@ -248,65 +306,31 @@ let do_assumptions_unbound_univs (_, poly, _ as kind) nl l = let ienv = List.fold_right (fun (_,id) ienv -> let impls = compute_internalization_data env Variable t imps in Id.Map.add id impls ienv) idl ienv in - ((env,ienv),((is_coe,idl),t,imps))) + ((env,ienv),((is_coe,idl),t,imps))) (env,empty_internalization_env) l in let evd = solve_remaining_evars all_and_fail_flags env !evdref Evd.empty in (* The universe constraints come from the whole telescope. *) let evd = Evd.nf_constraints evd in - let ctx = Evd.universe_context_set evd in - let nf_evar c = EConstr.Unsafe.to_constr (nf_evar evd (EConstr.of_constr c)) in - let l = List.map (on_pi2 nf_evar) l in - pi2 (List.fold_left (fun (subst,status,ctx) ((is_coe,idl),t,imps) -> - let t = replace_vars subst t in - let (refs,status') = declare_assumptions idl is_coe kind (t,ctx) [] imps false nl in - let subst' = List.map2 - (fun (_,id) (c,u) -> (id,Universes.constr_of_global_univ (c,u))) - idl refs - in - (subst'@subst, status' && status, - (* The universe constraints are declared with the first declaration only. *) - Univ.ContextSet.empty)) ([],true,ctx) l) - -let do_assumptions_bound_univs coe kind nl id pl c = - let env = Global.env () 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.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 - -let do_assumptions kind nl l = match l with -| [coe, ([id, Some pl], c)] -> - let () = match kind with - | (Discharge, _, _) when Lib.sections_are_opened () -> - let loc = fst id in - let msg = Pp.str "Section variables cannot be polymorphic." in - user_err ?loc msg - | _ -> () + let nf_evar c = EConstr.to_constr evd (EConstr.of_constr c) in + let uvars, l = List.fold_left_map (fun uvars (coe,t,imps) -> + let t = nf_evar t in + let uvars = Univ.LSet.union uvars (Univops.universes_of_constr env t) in + uvars, (coe,t,imps)) + Univ.LSet.empty l in - do_assumptions_bound_univs coe kind nl id (Some pl) c -| _ -> - let map (coe, (idl, c)) = - let map (id, univs) = match univs with - | None -> id - | Some _ -> - let loc = fst id in - let msg = - Pp.str "Assumptions with bound universes can only be defined one at a time." in - user_err ?loc msg - in - (coe, (List.map map idl, c)) - in - let l = List.map map l in - do_assumptions_unbound_univs kind nl l + let evd = Evd.restrict_universe_context evd uvars in + let uctx = Evd.check_univ_decl ~poly:(pi2 kind) evd udecl in + let ubinders = Evd.universe_binders evd in + pi2 (List.fold_left (fun (subst,status,uctx) ((is_coe,idl),t,imps) -> + let t = replace_vars subst t in + let refs, status' = declare_assumptions idl is_coe kind (t,uctx) ubinders imps nl in + let subst' = List.map2 + (fun (_,id) (c,u) -> (id, Universes.constr_of_global_univ (c,u))) + idl refs + in + subst'@subst, status' && status, next_uctx uctx) + ([], true, uctx) l) (* 3a| Elimination schemes for mutual inductive definitions *) @@ -377,8 +401,8 @@ let rec check_anonymous_type ind = | _ -> false let make_conclusion_flexible evdref ty poly = - if poly && isArity ty then - let _, concl = destArity ty in + if poly && Term.isArity ty then + let _, concl = Term.destArity ty in match concl with | Type u -> (match Univ.universe_level u with @@ -551,12 +575,13 @@ let interp_mutual_inductive (paramsl,indl) notations cum poly prv finite = lift_implicits (Context.Rel.nhyps ctx_params) impls) arities in let arities = List.map pi1 arities and aritypoly = List.map pi2 arities in let impls = compute_internalization_env env0 ~impls (Inductive (params,true)) indnames fullarities indimpls in + let ntn_impls = compute_internalization_env env0 (Inductive (params,true)) indnames fullarities indimpls in let mldatas = List.map2 (mk_mltype_data evdref env_params params) arities indnames in let constructors = Metasyntax.with_syntax_protection (fun () -> (* Temporary declaration of notations and scopes *) - List.iter (Metasyntax.set_notation_for_interpretation env_params impls) notations; + List.iter (Metasyntax.set_notation_for_interpretation env_params ntn_impls) notations; (* Interpret the constructor types *) List.map3 (interp_cstrs env_ar_params evdref impls) mldatas arities indl) () in @@ -576,7 +601,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.check_univ_decl evd decl in + let uctx = Evd.check_univ_decl ~poly evd decl in List.iter (fun c -> check_evars env_params Evd.empty evd (EConstr.of_constr c)) arities; Context.Rel.iter (fun c -> check_evars env0 Evd.empty evd (EConstr.of_constr c)) ctx_params; List.iter (fun (_,ctyps,_) -> @@ -598,11 +623,12 @@ let interp_mutual_inductive (paramsl,indl) notations cum poly prv finite = userimpls @ (lift_implicits len impls)) cimpls) indimpls constructors in let univs = - if poly then + match uctx with + | Polymorphic_const_entry uctx -> if cum then Cumulative_ind_entry (Universes.univ_inf_ind_from_universe_context uctx) else Polymorphic_ind_entry uctx - else + | Monomorphic_const_entry uctx -> Monomorphic_ind_entry uctx in (* Build the mutual inductive entry *) @@ -617,7 +643,7 @@ let interp_mutual_inductive (paramsl,indl) notations cum poly prv finite = in (if poly && cum then Inductiveops.infer_inductive_subtyping env_ar evd mind_ent - else mind_ent), pl, impls + else mind_ent), Evd.universe_binders evd, impls (* Very syntactical equality *) let eq_local_binders bl1 bl2 = @@ -684,7 +710,7 @@ let declare_mutual_inductive_with_eliminations mie pl impls = let ind = (mind,i) in let gr = IndRef ind in maybe_declare_manual_implicits false gr indimpls; - Universes.register_universe_binders gr pl; + Declare.declare_univ_binders gr pl; List.iteri (fun j impls -> maybe_declare_manual_implicits false @@ -1019,23 +1045,22 @@ 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 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 ~extensible:plext !evdref in - (*FIXME poly? *) - let ce = definition_entry ~poly ~types:ty ~univs (EConstr.to_constr !evdref body) in - (** FIXME: include locality *) - let c = Declare.declare_constant recname (DefinitionEntry ce, IsDefinition Definition) in - let gr = ConstRef c in - if Impargs.is_implicit_args () || not (List.is_empty impls) then - Impargs.declare_manual_implicits false gr [impls] + let body = it_mkLambda_or_LetIn (mkApp (Evarutil.e_new_global evdref gr, [|make|])) binders_rel in + let ty = it_mkProd_or_LetIn top_arity binders_rel in + let ty = EConstr.Unsafe.to_constr ty in + let univs = Evd.check_univ_decl ~poly !evdref decl in + (*FIXME poly? *) + let ce = definition_entry ~types:ty ~univs (EConstr.to_constr !evdref body) in + (** FIXME: include locality *) + let c = Declare.declare_constant recname (DefinitionEntry ce, IsDefinition Definition) in + let gr = ConstRef c in + let () = Universes.register_universe_binders gr (Evd.universe_binders !evdref) in + if Impargs.is_implicit_args () || not (List.is_empty impls) then + Impargs.declare_manual_implicits false gr [impls] in let typ = it_mkProd_or_LetIn top_arity binders in hook, name, typ @@ -1163,12 +1188,13 @@ let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) ind let env = Global.env() in let indexes = search_guard env indexes fixdecls in let fiximps = List.map (fun (n,r,p) -> r) fiximps in - let vars = Univops.universes_of_constr (mkFix ((indexes,0),fixdecls)) in + let vars = Univops.universes_of_constr env (mkFix ((indexes,0),fixdecls)) in let fixdecls = List.map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 fixnames in let evd = Evd.from_ctx ctx in let evd = Evd.restrict_universe_context evd vars in - let pl, ctx = Evd.check_univ_decl evd pl in + let ctx = Evd.check_univ_decl ~poly evd pl in + let pl = Evd.universe_binders evd in let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in ignore (List.map4 (DeclareDef.declare_fix (local, poly, Fixpoint) pl ctx) fixnames fixdecls fixtypes fiximps); @@ -1195,12 +1221,14 @@ let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) n let fixdefs = List.map Option.get fixdefs in let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in let fixdecls = List.map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 fixnames in - let vars = Univops.universes_of_constr (List.hd fixdecls) in + let env = Global.env () in + let vars = Univops.universes_of_constr env (List.hd fixdecls) in let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in let fiximps = List.map (fun (len,imps,idx) -> imps) fiximps in let evd = Evd.from_ctx ctx in let evd = Evd.restrict_universe_context evd vars in - let pl, ctx = Evd.check_univ_decl evd pl in + let ctx = Evd.check_univ_decl ~poly evd pl in + let pl = Evd.universe_binders evd in ignore (List.map4 (DeclareDef.declare_fix (local, poly, CoFixpoint) pl ctx) fixnames fixdecls fixtypes fiximps); (* Declare the recursive definitions *) @@ -1239,7 +1267,7 @@ let collect_evars_of_term evd c ty = Evar.Set.fold (fun ev acc -> Evd.add acc ev (Evd.find_undefined evd ev)) evars (Evd.from_ctx (Evd.evar_universe_context evd)) -let do_program_recursive local p fixkind fixl ntns = +let do_program_recursive local poly fixkind fixl ntns = let isfix = fixkind != Obligations.IsCoFixpoint in let (env, rec_sign, pl, evd), fix, info = interp_recursive isfix fixl ntns @@ -1281,8 +1309,8 @@ let do_program_recursive local p fixkind fixl ntns = end in let ctx = Evd.evar_universe_context evd in let kind = match fixkind with - | Obligations.IsFixpoint _ -> (local, p, Fixpoint) - | Obligations.IsCoFixpoint -> (local, p, CoFixpoint) + | Obligations.IsFixpoint _ -> (local, poly, Fixpoint) + | Obligations.IsCoFixpoint -> (local, poly, CoFixpoint) in Obligations.add_mutual_definitions defs ~kind ~univdecl:pl ctx ntns fixkind diff --git a/vernac/command.mli b/vernac/command.mli index fb99a717b9..c7342e6da9 100644 --- a/vernac/command.mli +++ b/vernac/command.mli @@ -28,7 +28,7 @@ val do_constraint : polymorphic -> val interp_definition : Vernacexpr.universe_decl_expr option -> local_binder_expr list -> polymorphic -> red_expr option -> constr_expr -> constr_expr option -> Safe_typing.private_constants definition_entry * Evd.evar_map * - Univdecls.universe_decl * Universes.universe_binders * Impargs.manual_implicits + Univdecls.universe_decl * Impargs.manual_implicits val do_definition : Id.t -> definition_kind -> Vernacexpr.universe_decl_expr option -> local_binder_expr list -> red_expr option -> constr_expr -> @@ -43,7 +43,7 @@ val do_definition : Id.t -> definition_kind -> Vernacexpr.universe_decl_expr opt (** returns [false] if the assumption is neither local to a section, nor in a module type and meant to be instantiated. *) val declare_assumption : coercion_flag -> assumption_kind -> - types Univ.in_universe_context_set -> + types in_constant_universes_entry -> Universes.universe_binders -> Impargs.manual_implicits -> bool (** implicit *) -> Vernacexpr.inline -> variable Loc.located -> global_reference * Univ.Instance.t * bool @@ -82,7 +82,7 @@ type one_inductive_impls = val interp_mutual_inductive : structured_inductive_expr -> decl_notation list -> cumulative_inductive_flag -> - polymorphic -> private_flag -> Decl_kinds.recursivity_kind -> + polymorphic -> private_flag -> Declarations.recursivity_kind -> mutual_inductive_entry * Universes.universe_binders * one_inductive_impls list (** Registering a mutual inductive definition together with its @@ -96,7 +96,7 @@ val declare_mutual_inductive_with_eliminations : val do_mutual_inductive : (one_inductive_expr * decl_notation list) list -> cumulative_inductive_flag -> - polymorphic -> private_flag -> Decl_kinds.recursivity_kind -> unit + polymorphic -> private_flag -> Declarations.recursivity_kind -> unit (** {6 Fixpoints and cofixpoints} *) diff --git a/vernac/declareDef.ml b/vernac/declareDef.ml index c18744052e..dfac78c048 100644 --- a/vernac/declareDef.ml +++ b/vernac/declareDef.ml @@ -36,7 +36,7 @@ let declare_global_definition ident ce local k pl imps = let kn = declare_constant ident ~local (DefinitionEntry ce, IsDefinition k) in let gr = ConstRef kn in let () = maybe_declare_manual_implicits false gr imps in - let () = Universes.register_universe_binders gr pl in + let () = Declare.declare_univ_binders gr pl in let () = definition_message ident in gr @@ -49,6 +49,7 @@ let declare_definition ident (local, p, k) ce pl imps hook = let () = definition_message ident in let gr = VarRef ident in let () = maybe_declare_manual_implicits false gr imps in + let () = Declare.declare_univ_binders gr pl in let () = if Proof_global.there_are_pending_proofs () then warn_definition_not_visible ident in @@ -57,7 +58,7 @@ let declare_definition ident (local, p, k) ce pl imps hook = declare_global_definition ident ce local k pl imps in Lemmas.call_hook fix_exn hook local r -let declare_fix ?(opaque = false) (_,poly,_ as kind) pl ctx f ((def,_),eff) t imps = - let ce = definition_entry ~opaque ~types:t ~poly ~univs:ctx ~eff def in +let declare_fix ?(opaque = false) (_,poly,_ as kind) pl univs f ((def,_),eff) t imps = + let ce = definition_entry ~opaque ~types:t ~univs ~eff def in declare_definition f kind ce pl imps (Lemmas.mk_hook (fun _ r -> r)) diff --git a/vernac/declareDef.mli b/vernac/declareDef.mli index 01a87818a3..55f7c78616 100644 --- a/vernac/declareDef.mli +++ b/vernac/declareDef.mli @@ -15,5 +15,8 @@ val declare_definition : Id.t -> definition_kind -> Safe_typing.private_constants Entries.definition_entry -> Universes.universe_binders -> Impargs.manual_implicits -> Globnames.global_reference Lemmas.declaration_hook -> Globnames.global_reference -val declare_fix : ?opaque:bool -> definition_kind -> Universes.universe_binders -> Univ.UContext.t -> Id.t -> - Safe_typing.private_constants Entries.proof_output -> Constr.types -> Impargs.manual_implicits -> Globnames.global_reference +val declare_fix : ?opaque:bool -> definition_kind -> + Universes.universe_binders -> Entries.constant_universes_entry -> + Id.t -> Safe_typing.private_constants Entries.proof_output -> + Constr.types -> Impargs.manual_implicits -> + Globnames.global_reference diff --git a/vernac/explainErr.ml b/vernac/explainErr.ml index 2178a7caa0..3a8e8fb436 100644 --- a/vernac/explainErr.ml +++ b/vernac/explainErr.ml @@ -76,7 +76,8 @@ let process_vernac_interp_error exn = match fst exn with | Tacred.ReductionTacticError e -> wrap_vernac_error exn (Himsg.explain_reduction_tactic_error e) | Logic.RefinerError e -> - wrap_vernac_error exn (Himsg.explain_refiner_error e) + let sigma, env = Pfedit.get_current_context () in + wrap_vernac_error exn (Himsg.explain_refiner_error env sigma e) | Nametab.GlobalizationError q -> wrap_vernac_error exn (str "The reference" ++ spc () ++ Libnames.pr_qualid q ++ diff --git a/vernac/himsg.ml b/vernac/himsg.ml index d15a811ba1..e8c5aeedd1 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -11,7 +11,7 @@ open Util open Names open Nameops open Namegen -open Term +open Constr open Termops open Indtypes open Environ @@ -92,9 +92,7 @@ let jv_nf_betaiotaevar sigma jl = (** Printers *) -let pr_lconstr c = quote (pr_lconstr c) let pr_lconstr_env e s c = quote (pr_lconstr_env e s c) -let pr_leconstr c = quote (pr_leconstr c) let pr_leconstr_env e s c = quote (pr_leconstr_env e s c) let pr_ljudge_env e s c = let v,t = pr_ljudge_env e s c in (quote v,quote t) @@ -407,7 +405,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 Term.is_Type c then str " a sort" else (brk(1,1) ++ pr)) ++ str "." + (if Constr.is_Type c then str " a sort" else (brk(1,1) ++ pr)) ++ str "." (* TODO: use the names *) (* (co)fixpoints *) @@ -1037,52 +1035,52 @@ let explain_typeclass_error env = function (* Refiner errors *) -let explain_refiner_bad_type arg ty conclty = +let explain_refiner_bad_type env sigma arg ty conclty = str "Refiner was given an argument" ++ brk(1,1) ++ - pr_lconstr arg ++ spc () ++ - str "of type" ++ brk(1,1) ++ pr_lconstr ty ++ spc () ++ - str "instead of" ++ brk(1,1) ++ pr_lconstr conclty ++ str "." + pr_lconstr_env env sigma arg ++ spc () ++ + str "of type" ++ brk(1,1) ++ pr_lconstr_env env sigma ty ++ spc () ++ + str "instead of" ++ brk(1,1) ++ pr_lconstr_env env sigma conclty ++ str "." let explain_refiner_unresolved_bindings l = str "Unable to find an instance for the " ++ str (String.plural (List.length l) "variable") ++ spc () ++ prlist_with_sep pr_comma Name.print l ++ str"." -let explain_refiner_cannot_apply t harg = +let explain_refiner_cannot_apply env sigma t harg = str "In refiner, a term of type" ++ brk(1,1) ++ - pr_lconstr t ++ spc () ++ str "could not be applied to" ++ brk(1,1) ++ - pr_lconstr harg ++ str "." + pr_lconstr_env env sigma t ++ spc () ++ str "could not be applied to" ++ brk(1,1) ++ + pr_lconstr_env env sigma harg ++ str "." -let explain_refiner_not_well_typed c = - str "The term " ++ pr_lconstr c ++ str " is not well-typed." +let explain_refiner_not_well_typed env sigma c = + str "The term " ++ pr_lconstr_env env sigma c ++ str " is not well-typed." let explain_intro_needs_product () = str "Introduction tactics needs products." -let explain_does_not_occur_in c hyp = - str "The term" ++ spc () ++ pr_lconstr c ++ spc () ++ +let explain_does_not_occur_in env sigma c hyp = + str "The term" ++ spc () ++ pr_lconstr_env env sigma c ++ spc () ++ str "does not occur in" ++ spc () ++ Id.print hyp ++ str "." -let explain_non_linear_proof c = - str "Cannot refine with term" ++ brk(1,1) ++ pr_lconstr c ++ +let explain_non_linear_proof env sigma c = + str "Cannot refine with term" ++ brk(1,1) ++ pr_lconstr_env env sigma c ++ spc () ++ str "because a metavariable has several occurrences." -let explain_meta_in_type c = - str "In refiner, a meta appears in the type " ++ brk(1,1) ++ pr_leconstr c ++ +let explain_meta_in_type env sigma c = + str "In refiner, a meta appears in the type " ++ brk(1,1) ++ pr_leconstr_env env sigma c ++ str " of another meta" let explain_no_such_hyp id = str "No such hypothesis: " ++ Id.print id -let explain_refiner_error = function - | BadType (arg,ty,conclty) -> explain_refiner_bad_type arg ty conclty +let explain_refiner_error env sigma = function + | BadType (arg,ty,conclty) -> explain_refiner_bad_type env sigma arg ty conclty | UnresolvedBindings t -> explain_refiner_unresolved_bindings t - | CannotApply (t,harg) -> explain_refiner_cannot_apply t harg - | NotWellTyped c -> explain_refiner_not_well_typed c + | CannotApply (t,harg) -> explain_refiner_cannot_apply env sigma t harg + | NotWellTyped c -> explain_refiner_not_well_typed env sigma c | IntroNeedsProduct -> explain_intro_needs_product () - | DoesNotOccurIn (c,hyp) -> explain_does_not_occur_in c hyp - | NonLinearProof c -> explain_non_linear_proof c - | MetaInType c -> explain_meta_in_type c + | DoesNotOccurIn (c,hyp) -> explain_does_not_occur_in env sigma c hyp + | NonLinearProof c -> explain_non_linear_proof env sigma c + | MetaInType c -> explain_meta_in_type env sigma c | NoSuchHyp id -> explain_no_such_hyp id (* Inductive errors *) diff --git a/vernac/himsg.mli b/vernac/himsg.mli index 5b91f9e682..8945ebadb8 100644 --- a/vernac/himsg.mli +++ b/vernac/himsg.mli @@ -27,7 +27,7 @@ val explain_typeclass_error : env -> typeclass_error -> Pp.t val explain_recursion_scheme_error : recursion_scheme_error -> Pp.t -val explain_refiner_error : refiner_error -> Pp.t +val explain_refiner_error : env -> Evd.evar_map -> refiner_error -> Pp.t val explain_pattern_matching_error : env -> Evd.evar_map -> pattern_matching_error -> Pp.t diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index c0ddc7e2ce..e4ca98749c 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -109,10 +109,10 @@ let _ = let define id internal ctx c t = let f = declare_constant ~internal 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 + if Flags.is_universe_polymorphism () + then Polymorphic_const_entry (Evd.to_universe_context ctx) + else Monomorphic_const_entry (Evd.universe_context_set ctx) in let kn = f id (DefinitionEntry diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 7b8a38d5f6..200c2260ed 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -49,7 +49,8 @@ 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 ~names:[] ~extensible:true uctx in + (* we get the right order somehow but surely it could be enforced in a better way *) + let uctx = UState.context 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) @@ -176,7 +177,7 @@ let look_for_possibly_mutual_statements = function (* Saving a goal *) -let save ?export_seff id const cstrs pl do_guard (locality,poly,kind) hook = +let save ?export_seff id const uctx do_guard (locality,poly,kind) hook = let fix_exn = Future.fix_exn_of const.Entries.const_entry_body in try let const = adjust_guardness_conditions const do_guard in @@ -203,7 +204,7 @@ let save ?export_seff id const cstrs pl do_guard (locality,poly,kind) hook = (locality, ConstRef kn) in definition_message id; - Option.iter (Universes.register_universe_binders r) pl; + Declare.declare_univ_binders r (UState.universe_binders uctx); call_hook (fun exn -> exn) hook l r with e when CErrors.noncritical e -> let e = CErrors.push e in @@ -223,7 +224,7 @@ let compute_proof_name locality = function let avoid = Id.Set.of_list (Proof_global.get_all_proof_names ()) in next_global_ident_away default_thm_id avoid -let save_remaining_recthms (locality,p,kind) norm ctx binders body opaq i (id,(t_i,(_,imps))) = +let save_remaining_recthms (locality,p,kind) norm univs body opaq i (id,(t_i,(_,imps))) = let t_i = norm t_i in match body with | None -> @@ -231,7 +232,13 @@ let save_remaining_recthms (locality,p,kind) norm ctx binders body opaq i (id,(t | Discharge -> let impl = false in (* copy values from Vernacentries *) let k = IsAssumption Conjectural in - let c = SectionLocalAssum ((t_i,Univ.ContextSet.of_context ctx),p,impl) in + let univs = match univs with + | Polymorphic_const_entry univs -> + (* What is going on here? *) + Univ.ContextSet.of_context univs + | Monomorphic_const_entry univs -> univs + in + let c = SectionLocalAssum ((t_i, univs),p,impl) in let _ = declare_variable id (Lib.cwd(),c,k) in (Discharge, VarRef id,imps) | Local | Global -> @@ -241,7 +248,7 @@ let save_remaining_recthms (locality,p,kind) norm ctx binders body opaq i (id,(t | Global -> false | Discharge -> assert false in - let decl = (ParameterEntry (None,p,(t_i,ctx),None), k) in + let decl = (ParameterEntry (None,(t_i,univs),None), k) in let kn = declare_constant id ~local decl in (locality,ConstRef kn,imps)) | Some body -> @@ -253,12 +260,13 @@ let save_remaining_recthms (locality,p,kind) norm ctx binders body opaq i (id,(t | LetIn(na,t1,ty,t2) -> mkLetIn (na,t1,ty, body_i t2) | Lambda(na,ty,t) -> mkLambda(na,ty,body_i t) | App (t, args) -> mkApp (body_i t, args) - | _ -> anomaly Pp.(str "Not a proof by induction: " ++ Printer.pr_constr body ++ str ".") in + | _ -> + let sigma, env = Pfedit.get_current_context () in + anomaly Pp.(str "Not a proof by induction: " ++ Printer.pr_constr_env env sigma body ++ str ".") in let body_i = body_i body in match locality with | Discharge -> - let const = definition_entry ~types:t_i ~opaque:opaq ~poly:p - ~univs:ctx body_i in + let const = definition_entry ~types:t_i ~opaque:opaq ~univs body_i in let c = SectionLocalDef const in let _ = declare_variable id (Lib.cwd(), c, k) in (Discharge,VarRef id,imps) @@ -269,7 +277,7 @@ let save_remaining_recthms (locality,p,kind) norm ctx binders body opaq i (id,(t | Discharge -> assert false in let const = - Declare.definition_entry ~types:t_i ~poly:p ~univs:ctx ~opaque:opaq body_i + Declare.definition_entry ~types:t_i ~univs ~opaque:opaq body_i in let kn = declare_constant id ~local (DefinitionEntry const, k) in (locality,ConstRef kn,imps) @@ -278,17 +286,17 @@ let save_hook = ref ignore let set_save_hook f = save_hook := f let save_named ?export_seff proof = - let id,const,(cstrs,pl),do_guard,persistence,hook = proof in - save ?export_seff id const cstrs pl do_guard persistence hook + let id,const,uctx,do_guard,persistence,hook = proof in + save ?export_seff id const uctx do_guard persistence hook let check_anonymity id save_ident = if not (String.equal (atompart_of_id id) (Id.to_string (default_thm_id))) then user_err Pp.(str "This command can only be used for unnamed theorem.") let save_anonymous ?export_seff proof save_ident = - let id,const,(cstrs,pl),do_guard,persistence,hook = proof in + let id,const,uctx,do_guard,persistence,hook = proof in check_anonymity id save_ident; - save ?export_seff save_ident const cstrs pl do_guard persistence hook + save ?export_seff save_ident const uctx do_guard persistence hook (* Admitted *) @@ -304,7 +312,7 @@ let admit (id,k,e) pl hook () = | Local, _, _ | Discharge, _, _ -> warn_let_as_axiom id in let () = assumption_message id in - Option.iter (Universes.register_universe_binders (ConstRef kn)) pl; + Declare.declare_univ_binders (ConstRef kn) pl; call_hook (fun exn -> exn) hook Global (ConstRef kn) (* Starting a goal *) @@ -322,8 +330,8 @@ let get_proof proof do_guard hook opacity = let universe_proof_terminator compute_guard hook = let open Proof_global in make_terminator begin function - | Admitted (id,k,pe,(ctx,pl)) -> - admit (id,k,pe) pl (hook (Some ctx)) (); + | Admitted (id,k,pe,ctx) -> + admit (id,k,pe) (UState.universe_binders ctx) (hook (Some ctx)) (); Feedback.feedback Feedback.AddedAxiom | Proved (opaque,idopt,proof) -> let is_opaque, export_seff = match opaque with @@ -331,7 +339,7 @@ let universe_proof_terminator compute_guard hook = | Vernacexpr.Opaque -> true, false in let proof = get_proof proof compute_guard - (hook (Some (fst proof.Proof_global.universes))) is_opaque in + (hook (Some (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 @@ -409,7 +417,7 @@ let start_proof_with_initialization kind ctx decl recguard thms snl hook = | (id,(t,(_,imps)))::other_thms -> let hook ctx strength ref = let ctx = match ctx with - | None -> Evd.empty_evar_universe_context + | None -> UState.empty | Some ctx -> ctx in let other_thms_data = @@ -418,9 +426,9 @@ let start_proof_with_initialization kind ctx decl 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 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 binders body opaq) 1 other_thms in + let body = Option.map norm body in + let uctx = UState.check_univ_decl ~poly:(pi2 kind) ctx decl in + List.map_i (save_remaining_recthms kind norm uctx body opaq) 1 other_thms in let thms_data = (strength,ref,imps)::other_thms_data in List.iter (fun (strength,ref,imps) -> maybe_declare_manual_implicits false ref imps; @@ -451,9 +459,9 @@ 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 () = - if not decl.Misctypes.univdecl_extensible_instance then - ignore (Evd.universe_context evd ~names:decl.Misctypes.univdecl_instance ~extensible:false) - else () + let open Misctypes in + if not (decl.univdecl_extensible_instance && decl.univdecl_extensible_constraints) then + ignore (Evd.check_univ_decl ~poly:(pi2 kind) evd decl) in let evd = if pi2 kind then evd @@ -488,9 +496,9 @@ let save_proof ?proof = function if const_entry_type = None then user_err Pp.(str "Admitted requires an explicit statement"); let typ = Option.get const_entry_type in - let ctx = Evd.evar_context_universe_context (fst universes) in + let ctx = UState.const_univ_entry ~poly:(pi2 k) universes in let sec_vars = if !keep_admitted_vars then const_entry_secctx else None in - Admitted(id, k, (sec_vars, pi2 k, (typ, ctx), None), universes) + Admitted(id, k, (sec_vars, (typ, ctx), None), universes) | None -> let pftree = Proof_global.give_me_the_proof () in let id, k, typ = Pfedit.current_proof_statement () in @@ -510,12 +518,9 @@ let save_proof ?proof = function Some (Environ.keep_hyps env (Id.Set.union ids_typ ids_def)) | _ -> None in let decl = Proof_global.get_universe_decl () in - let evd = Evd.from_ctx universes in - 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)) + let ctx = UState.check_univ_decl ~poly universes decl in + Admitted(id,k,(sec_vars, (typ, ctx), None), universes) in Proof_global.apply_terminator (Proof_global.get_terminator ()) pe | Vernacexpr.Proved (is_opaque,idopt) -> @@ -530,7 +535,5 @@ let save_proof ?proof = function Proof_global.(apply_terminator terminator (Proved (is_opaque,idopt,proof_obj))) (* Miscellaneous *) +let get_current_context () = Pfedit.get_current_context () -let get_current_context () = - Pfedit.get_current_context () - diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli index 6972edd52f..a4854b4a6b 100644 --- a/vernac/lemmas.mli +++ b/vernac/lemmas.mli @@ -56,7 +56,7 @@ val standard_proof_terminator : (** {6 ... } *) (** A hook the next three functions pass to cook_proof *) -val set_save_hook : (Proof.proof -> unit) -> unit +val set_save_hook : (Proof.t -> unit) -> unit val save_proof : ?proof:Proof_global.closed_proof -> Vernacexpr.proof_end -> unit @@ -66,3 +66,4 @@ val save_proof : ?proof:Proof_global.closed_proof -> Vernacexpr.proof_end -> uni and the current global env *) val get_current_context : unit -> Evd.evar_map * Environ.env +[@@ocaml.deprecated "please use [Pfedit.get_current_context]"] diff --git a/vernac/locality.ml b/vernac/locality.ml index 054a451a46..87b4116252 100644 --- a/vernac/locality.ml +++ b/vernac/locality.ml @@ -6,46 +6,14 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Pp +open Decl_kinds (** * Managing locality *) let local_of_bool = function - | true -> Decl_kinds.Local - | false -> Decl_kinds.Global - -let check_locality locality_flag = - match locality_flag with - | Some b -> - let s = if b then "Local" else "Global" in - CErrors.user_err ~hdr:"Locality.check_locality" - (str "This command does not support the \"" ++ str s ++ str "\" prefix.") - | None -> () - -(** Extracting the locality flag *) - -(* Commands which supported an inlined Local flag *) - -let warn_deprecated_local_syntax = - CWarnings.create ~name:"deprecated-local-syntax" ~category:"deprecated" - (fun () -> - Pp.strbrk "Deprecated syntax: use \"Local\" as a prefix.") - -let enforce_locality_full locality_flag local = - let local = - match locality_flag with - | Some false when local -> - CErrors.user_err Pp.(str "Cannot be simultaneously Local and Global.") - | Some true when local -> - CErrors.user_err Pp.(str "Use only prefix \"Local\".") - | None -> - if local then begin - warn_deprecated_local_syntax (); - Some true - end else - None - | Some b -> Some b in - local + | true -> Local + | false -> Global + (** Positioning locality for commands supporting discharging and export outside of modules *) @@ -58,15 +26,16 @@ let make_non_locality = function Some false -> false | _ -> true let make_locality = function Some true -> true | _ -> false -let enforce_locality locality_flag local = - make_locality (enforce_locality_full locality_flag local) +let enforce_locality_exp locality_flag discharge = + match locality_flag, discharge with + | Some b, NoDischarge -> local_of_bool b + | None, NoDischarge -> Global + | None, DoDischarge -> Discharge + | Some true, DoDischarge -> CErrors.user_err Pp.(str "Local not allowed in this case") + | Some false, DoDischarge -> CErrors.user_err Pp.(str "Global not allowed in this case") -let enforce_locality_exp locality_flag local = - match locality_flag, local with - | None, Some local -> local - | Some b, None -> local_of_bool b - | None, None -> Decl_kinds.Global - | Some _, Some _ -> CErrors.user_err Pp.(str "Local non allowed in this case") +let enforce_locality locality_flag = + make_locality locality_flag (* For commands whose default is to not discharge but to export: Global in sections forces discharge, Global not in section is the default; @@ -75,8 +44,8 @@ let enforce_locality_exp locality_flag local = let make_section_locality = function Some b -> b | None -> Lib.sections_are_opened () -let enforce_section_locality locality_flag local = - make_section_locality (enforce_locality_full locality_flag local) +let enforce_section_locality locality_flag = + make_section_locality locality_flag (** Positioning locality for commands supporting export but not discharge *) @@ -93,15 +62,5 @@ let make_module_locality = function | Some true -> true | None -> false -let enforce_module_locality locality_flag local = - make_module_locality (enforce_locality_full locality_flag local) - -module LocalityFixme = struct - let locality = ref None - let set l = locality := l - let consume () = - let l = !locality in - locality := None; - l - let assert_consumed () = check_locality !locality -end +let enforce_module_locality locality_flag = + make_module_locality locality_flag diff --git a/vernac/locality.mli b/vernac/locality.mli index c1c45d6b0f..922538b233 100644 --- a/vernac/locality.mli +++ b/vernac/locality.mli @@ -8,10 +8,6 @@ (** * Managing locality *) -(** Commands which supported an inlined Local flag *) - -val enforce_locality_full : bool option -> bool -> bool option - (** * Positioning locality for commands supporting discharging and export outside of modules *) @@ -22,16 +18,15 @@ val enforce_locality_full : bool option -> bool -> bool option val make_locality : bool option -> bool val make_non_locality : bool option -> bool -val enforce_locality : bool option -> bool -> bool -val enforce_locality_exp : - bool option -> Decl_kinds.locality option -> Decl_kinds.locality +val enforce_locality_exp : bool option -> Decl_kinds.discharge -> Decl_kinds.locality +val enforce_locality : bool option -> bool (** For commands whose default is to not discharge but to export: Global in sections forces discharge, Global not in section is the default; Local in sections is the default, Local not in section forces non-export *) val make_section_locality : bool option -> bool -val enforce_section_locality : bool option -> bool -> bool +val enforce_section_locality : bool option -> bool (** * Positioning locality for commands supporting export but not discharge *) @@ -40,12 +35,4 @@ val enforce_section_locality : bool option -> bool -> bool Local in sections is the default, Local not in section forces non-export *) val make_module_locality : bool option -> bool -val enforce_module_locality : bool option -> bool -> bool - -(* This is the old imperative interface that is still used for - * VernacExtend vernaculars. Time permitting this could be trashed too *) -module LocalityFixme : sig - val set : bool option -> unit - val consume : unit -> bool option - val assert_consumed : unit -> unit -end +val enforce_module_locality : bool option -> bool diff --git a/vernac/mltop.ml b/vernac/mltop.ml index d3de10235f..00554e3bae 100644 --- a/vernac/mltop.ml +++ b/vernac/mltop.ml @@ -378,7 +378,7 @@ let unfreeze_ml_modules x = (fun (name,path) -> trigger_ml_object false false false ?path name) x let _ = - Summary.declare_summary Summary.ml_modules + Summary.declare_ml_modules_summary { Summary.freeze_function = (fun _ -> get_loaded_modules ()); Summary.unfreeze_function = unfreeze_ml_modules; Summary.init_function = reset_loaded_modules } diff --git a/vernac/obligations.ml b/vernac/obligations.ml index ed4d8b888e..181068089e 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -155,7 +155,7 @@ let evar_dependencies evm oev = let evi = Evd.find evm ev in let deps' = evars_of_filtered_evar_info evi in if Evar.Set.mem oev deps' then - invalid_arg ("Ill-formed evar map: cycle detected for evar " ^ string_of_existential oev) + invalid_arg ("Ill-formed evar map: cycle detected for evar " ^ Pp.string_of_ppcmds @@ Evar.print oev) else Evar.Set.union deps' s) deps deps in @@ -164,7 +164,7 @@ let evar_dependencies evm oev = if Evar.Set.equal deps deps' then deps else aux deps' in aux (Evar.Set.singleton oev) - + let move_after (id, ev, deps as obl) l = let rec aux restdeps = function | (id', _, _) as obl' :: tl -> @@ -429,8 +429,8 @@ let map_replace k v m = ProgMap.add k (CEphemeron.create v) (ProgMap.remove k m) let map_keys m = ProgMap.fold (fun k _ l -> k :: l) m [] -let from_prg : program_info ProgMap.t ref = - Summary.ref ProgMap.empty ~name:"program-tcc-table" +let from_prg, program_tcc_summary_tag = + Summary.ref_tag ProgMap.empty ~name:"program-tcc-table" let close sec = if not (ProgMap.is_empty !from_prg) then @@ -475,20 +475,20 @@ 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.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) - ~univs:(Evd.evar_context_universe_context prg.prg_ctx) (nf body) - in + let typ = nf typ in + let body = nf body in + let env = Global.env () in + let uvars = Univ.LSet.union + (Univops.universes_of_constr env typ) + (Univops.universes_of_constr env body) in + let uctx = UState.restrict prg.prg_ctx uvars in + let univs = UState.check_univ_decl ~poly:(pi2 prg.prg_kind) uctx prg.prg_univdecl in + let ce = definition_entry ~fix_exn ~opaque ~types:typ ~univs body in let () = progmap_remove prg in - let cst = - DeclareDef.declare_definition prg.prg_name - prg.prg_kind ce [] prg.prg_implicits - (Lemmas.mk_hook (fun l r -> Lemmas.call_hook fix_exn prg.prg_hook l r prg.prg_ctx; r)) - in - Universes.register_universe_binders cst pl; - cst + let ubinders = UState.universe_binders uctx in + DeclareDef.declare_definition prg.prg_name + prg.prg_kind ce ubinders prg.prg_implicits + (Lemmas.mk_hook (fun l r -> Lemmas.call_hook fix_exn prg.prg_hook l r uctx; r)) let rec lam_index n t acc = match Constr.kind t with @@ -552,9 +552,9 @@ let declare_mutual_definition l = mk_proof (mkCoFix (i,fixdecls))) 0 l in (* Declare the recursive definitions *) - let ctx = Evd.evar_context_universe_context first.prg_ctx in + let univs = UState.const_univ_entry ~poly first.prg_ctx in let fix_exn = Hook.get get_fix_exn () in - let kns = List.map4 (DeclareDef.declare_fix ~opaque (local, poly, kind) [] ctx) + let kns = List.map4 (DeclareDef.declare_fix ~opaque (local, poly, kind) Universes.empty_binders univs) fixnames fixdecls fixtypes fiximps in (* Declare notations *) List.iter (Metasyntax.add_notation_interpretation (Global.env())) first.prg_notations; @@ -636,12 +636,11 @@ let declare_obligation prg obl body ty uctx = shrink_body body ty else [], body, ty, [||] in let body = ((body,Univ.ContextSet.empty),Safe_typing.empty_private_constants) in - let univs = if poly then Polymorphic_const_entry uctx else Monomorphic_const_entry uctx in let ce = { const_entry_body = Future.from_val ~fix_exn:(fun x -> x) body; const_entry_secctx = None; const_entry_type = ty; - const_entry_universes = univs; + const_entry_universes = uctx; const_entry_opaque = opaque; const_entry_inline_code = false; const_entry_feedback = None; @@ -650,13 +649,15 @@ let declare_obligation prg obl body ty uctx = let constant = Declare.declare_constant obl.obl_name ~local:true (DefinitionEntry ce,IsProof Property) in - if not opaque then add_hint (Locality.make_section_locality None) prg constant; - definition_message obl.obl_name; - true, { obl with obl_body = - if poly then - Some (DefinedObl (constant, Univ.UContext.instance uctx)) - else - Some (TermObl (it_mkLambda_or_LetIn_or_clean (mkApp (mkConst constant, args)) ctx)) } + if not opaque then add_hint (Locality.make_section_locality None) prg constant; + definition_message obl.obl_name; + let body = match uctx with + | Polymorphic_const_entry uctx -> + Some (DefinedObl (constant, Univ.UContext.instance uctx)) + | Monomorphic_const_entry _ -> + Some (TermObl (it_mkLambda_or_LetIn_or_clean (mkApp (mkConst constant, args)) ctx)) + in + true, { obl with obl_body = body } let init_prog_info ?(opaque = false) sign n udecl b t ctx deps fixkind notations obls impls kind reduce hook = @@ -678,6 +679,7 @@ let init_prog_info ?(opaque = false) sign n udecl b t ctx deps fixkind obl_deps = d; obl_tac = tac }) obls, b in + let ctx = UState.make_flexible_nonalgebraic ctx in { prg_name = n ; prg_body = b; prg_type = reduce t; prg_ctx = ctx; prg_univdecl = udecl; prg_obligations = (obls', Array.length obls'); @@ -829,46 +831,63 @@ let obligation_terminator name num guard hook auto pf = match pf with | Admitted _ -> apply_terminator term pf | Proved (opq, id, proof) -> - if not !shrink_obligations then apply_terminator term pf - else - let (_, (entry, uctx, _)) = Pfedit.cook_this_proof proof in - let env = Global.env () in - let entry = Safe_typing.inline_private_constants_in_definition_entry env entry in - let ty = entry.Entries.const_entry_type in - let (body, cstr), () = Future.force entry.Entries.const_entry_body in - let sigma = Evd.from_ctx (fst uctx) in - let sigma = Evd.merge_context_set ~sideff:true Evd.univ_rigid sigma cstr in - Inductiveops.control_only_guard (Global.env ()) body; - (** Declare the obligation ourselves and drop the hook *) - let prg = get_info (ProgMap.find name !from_prg) in - let ctx = Evd.evar_universe_context sigma in - let prg = { prg with prg_ctx = ctx } in - let obls, rem = prg.prg_obligations in - 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.Define true), Vernacexpr.Transparent -> Evar_kinds.Define false - | (_, status), Vernacexpr.Transparent -> status - in - let obl = { obl with obl_status = false, status } in - let uctx = Evd.evar_context_universe_context ctx in - let (_, obl) = declare_obligation prg obl body ty uctx in - let obls = Array.copy obls in - let _ = obls.(num) <- obl in - try + let (_, (entry, uctx, _)) = Pfedit.cook_this_proof proof in + let env = Global.env () in + let entry = Safe_typing.inline_private_constants_in_definition_entry env entry in + let ty = entry.Entries.const_entry_type in + let (body, cstr), () = Future.force entry.Entries.const_entry_body in + let sigma = Evd.from_ctx uctx in + let sigma = Evd.merge_context_set ~sideff:true Evd.univ_rigid sigma cstr in + Inductiveops.control_only_guard (Global.env ()) body; + (** Declare the obligation ourselves and drop the hook *) + let prg = get_info (ProgMap.find name !from_prg) in + (** Ensure universes are substituted properly in body and type *) + let body = EConstr.to_constr sigma (EConstr.of_constr body) in + let ty = Option.map (fun x -> EConstr.to_constr sigma (EConstr.of_constr x)) ty in + let ctx = Evd.evar_universe_context sigma in + let obls, rem = prg.prg_obligations in + 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.Define true), Vernacexpr.Transparent -> + Evar_kinds.Define false + | (_, status), Vernacexpr.Transparent -> status + in + let obl = { obl with obl_status = false, status } in + let ctx = + if pi2 prg.prg_kind then ctx + else UState.union prg.prg_ctx ctx + in + let uctx = UState.const_univ_entry ~poly:(pi2 prg.prg_kind) ctx in + let (_, obl) = declare_obligation prg obl body ty uctx in + let obls = Array.copy obls in + let _ = obls.(num) <- obl in + let prg_ctx = + if pi2 (prg.prg_kind) then (* Polymorphic *) + (** We merge the new universes and constraints of the + polymorphic obligation with the existing ones *) + UState.union prg.prg_ctx ctx + else + (** The first obligation declares the univs of the constant, + each subsequent obligation declares its own additional + universes and constraints if any *) + UState.make (Global.universes ()) + in + let prg = { prg with prg_ctx } in + try ignore (update_obls prg obls (pred rem)); if pred rem > 0 then begin - let deps = dependencies obls num in - if not (Int.Set.is_empty deps) then - ignore (auto (Some name) None deps) - end - with e when CErrors.noncritical e -> - let e = CErrors.push e in - pperror (CErrors.iprint (ExplainErr.process_vernac_interp_error e)) + let deps = dependencies obls num in + if not (Int.Set.is_empty deps) then + ignore (auto (Some name) None deps) + end + with e when CErrors.noncritical e -> + let e = CErrors.push e in + pperror (CErrors.iprint (ExplainErr.process_vernac_interp_error e)) let obligation_hook prg obl num auto ctx' _ gr = let obls, rem = prg.prg_obligations in @@ -889,7 +908,8 @@ 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 ~names:[] ~extensible:true ctx' in + (* We get the right order somehow, but surely it could be enforced in a clearer way. *) + let uctx = UState.context ctx' in Univ.UContext.instance uctx, ctx' in let obl = { obl with obl_body = Some (DefinedObl (cst, inst)) } in @@ -965,13 +985,16 @@ and solve_obligation_by_tac prg obls i tac = let evd = Evd.from_ctx prg.prg_ctx in let evd = Evd.update_sigma_env evd (Global.env ()) in let t, ty, ctx = - solve_by_tac obl.obl_name (evar_of_obligation obl) tac - (pi2 prg.prg_kind) (Evd.evar_universe_context evd) - in - let uctx = Evd.evar_context_universe_context ctx in - let prg = {prg with prg_ctx = ctx} in - let def, obl' = declare_obligation prg obl t ty uctx in - obls.(i) <- obl'; + solve_by_tac obl.obl_name (evar_of_obligation obl) tac + (pi2 prg.prg_kind) (Evd.evar_universe_context evd) + in + let uctx = if pi2 prg.prg_kind + then Polymorphic_const_entry (UState.context ctx) + else Monomorphic_const_entry (UState.context_set ctx) + in + let prg = {prg with prg_ctx = ctx} in + let def, obl' = declare_obligation prg obl t ty uctx in + obls.(i) <- obl'; if def && not (pi2 prg.prg_kind) then ( (* Declare the term constraints with the first obligation only *) let evd = Evd.from_env (Global.env ()) in @@ -1119,9 +1142,9 @@ let admit_prog prg = match x.obl_body with | None -> let x = subst_deps_obl obls x in - let ctx = Evd.evar_context_universe_context prg.prg_ctx in + let ctx = Monomorphic_const_entry (UState.context_set prg.prg_ctx) in let kn = Declare.declare_constant x.obl_name ~local:true - (ParameterEntry (None,false,(x.obl_type,ctx),None), IsAssumption Conjectural) + (ParameterEntry (None,(x.obl_type,ctx),None), IsAssumption Conjectural) in assumption_message x.obl_name; obls.(i) <- { x with obl_body = Some (DefinedObl (kn, Univ.Instance.empty)) } diff --git a/vernac/obligations.mli b/vernac/obligations.mli index 481faadb8e..bdc97d48c0 100644 --- a/vernac/obligations.mli +++ b/vernac/obligations.mli @@ -32,7 +32,7 @@ val eterm_obligations : env -> Id.t -> evar_map -> int -> (* Existential key, obl. name, type as product, location of the original evar, associated tactic, status and dependencies as indexes into the array *) - * ((existential_key * Id.t) list * ((Id.t -> constr) -> constr -> constr)) * + * ((Evar.t * Id.t) list * ((Id.t -> constr) -> constr -> constr)) * constr * types (* Translations from existential identifiers to obligation identifiers and for terms with existentials to closed terms, given a @@ -104,3 +104,6 @@ exception NoObligations of Names.Id.t option val explain_no_obligations : Names.Id.t option -> Pp.t val set_program_mode : bool -> unit + +type program_info +val program_tcc_summary_tag : program_info Id.Map.t Summary.Dyn.tag diff --git a/vernac/record.ml b/vernac/record.ml index 1bd47a5562..1cdc538b5b 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -8,11 +8,12 @@ open Pp open CErrors +open Term +open Sorts open Util open Names open Globnames open Nameops -open Term open Constr open Vars open Environ @@ -94,7 +95,7 @@ let binder_of_decl = function let binders_of_decls = List.map binder_of_decl -let typecheck_params_and_fields finite def id pl t ps nots fs = +let typecheck_params_and_fields finite def id poly pl t ps nots fs = let env0 = Global.env () in let evd, decl = Univdecls.interp_univ_decl_opt env0 pl in let evars = ref evd in @@ -166,10 +167,11 @@ 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 + let univs = Evd.check_univ_decl ~poly evars decl in + let ubinders = Evd.universe_binders evars in List.iter (iter_constr ce) (List.rev newps); List.iter (iter_constr ce) (List.rev newfs); - univs, typ, template, imps, newps, impls, newfs + ubinders, univs, typ, template, imps, newps, impls, newfs let degenerate_decl decl = let id = match RelDecl.get_name decl with @@ -264,12 +266,14 @@ let warn_non_primitive_record = strbrk" could not be defined as a primitive record"))) (* We build projections *) -let declare_projections indsp ?(kind=StructureComponent) binder_name coers fieldimpls fields = +let declare_projections indsp ctx ?(kind=StructureComponent) binder_name coers ubinders fieldimpls fields = let env = Global.env() in let (mib,mip) = Global.lookup_inductive indsp in let poly = Declareops.inductive_is_polymorphic mib in - let ctx = Univ.AUContext.repr (Declareops.inductive_polymorphic_context mib) in - let u = Univ.UContext.instance ctx in + let u = match ctx with + | Polymorphic_const_entry ctx -> Univ.UContext.instance ctx + | Monomorphic_const_entry ctx -> Univ.Instance.empty + in let paramdecls = Inductive.inductive_paramdecls (mib, u) in let indu = indsp, u in let r = mkIndU (indsp,u) in @@ -303,9 +307,11 @@ let declare_projections indsp ?(kind=StructureComponent) binder_name coers field let kn, term = if is_local_assum decl && primitive then (** Already defined in the kernel silently *) - let kn = destConstRef (Nametab.locate (Libnames.qualid_of_ident fid)) in - Declare.definition_message fid; - kn, mkProj (Projection.make kn false,mkRel 1) + let gr = Nametab.locate (Libnames.qualid_of_ident fid) in + let kn = destConstRef gr in + Declare.definition_message fid; + Universes.register_universe_binders gr ubinders; + kn, mkProj (Projection.make kn false,mkRel 1) else let ccl = subst_projection fid subst ti in let body = match decl with @@ -324,16 +330,12 @@ let declare_projections indsp ?(kind=StructureComponent) binder_name coers field let projtyp = it_mkProd_or_LetIn (mkProd (x,rp,ccl)) paramdecls in try - let univs = - if poly then Polymorphic_const_entry ctx - else Monomorphic_const_entry ctx - in let entry = { const_entry_body = Future.from_val (Safe_typing.mk_pure_proof proj); const_entry_secctx = None; const_entry_type = Some projtyp; - const_entry_universes = univs; + const_entry_universes = ctx; const_entry_opaque = false; const_entry_inline_code = false; const_entry_feedback = None } in @@ -342,8 +344,9 @@ let declare_projections indsp ?(kind=StructureComponent) binder_name coers field let constr_fip = let proj_args = (*Rel 1 refers to "x"*) paramargs@[mkRel 1] in applist (mkConstU (kn,u),proj_args) - in - Declare.definition_message fid; + in + Declare.definition_message fid; + Universes.register_universe_binders (ConstRef kn) ubinders; kn, constr_fip with Type_errors.TypeError (ctx,te) -> raise (NotDefinable (BadTypedProj (fid,ctx,te))) @@ -381,17 +384,20 @@ let structure_signature ctx = open Typeclasses -let declare_structure finite univs id idbuild paramimpls params arity template +let declare_structure finite ubinders univs id idbuild paramimpls params arity template fieldimpls fields ?(kind=StructureComponent) ?name is_coe coers sign = let nparams = List.length params and nfields = List.length fields in let args = Context.Rel.to_extended_list mkRel nfields params in let ind = applist (mkRel (1+nparams+nfields), args) in let type_constructor = it_mkProd_or_LetIn ind fields in - let poly, ctx = + let template, ctx = match univs with - | Monomorphic_ind_entry ctx -> false, ctx - | Polymorphic_ind_entry ctx -> true, ctx - | Cumulative_ind_entry cumi -> true, (Univ.CumulativityInfo.univ_context cumi) + | Monomorphic_ind_entry ctx -> + template, Monomorphic_const_entry Univ.ContextSet.empty + | Polymorphic_ind_entry ctx -> + false, Polymorphic_const_entry ctx + | Cumulative_ind_entry cumi -> + false, Polymorphic_const_entry (Univ.CumulativityInfo.univ_context cumi) in let binder_name = match name with @@ -401,7 +407,7 @@ let declare_structure finite univs id idbuild paramimpls params arity template let mie_ind = { mind_entry_typename = id; mind_entry_arity = arity; - mind_entry_template = not poly && template; + mind_entry_template = template; mind_entry_consnames = [idbuild]; mind_entry_lc = [type_constructor] } in @@ -415,27 +421,21 @@ let declare_structure finite univs id idbuild paramimpls params arity template } in let mie = - if poly then - begin + match ctx with + | Polymorphic_const_entry ctx -> let env = Global.env () in let env' = Environ.push_context ctx env in let evd = Evd.from_env env' in Inductiveops.infer_inductive_subtyping env' evd mie - end - else + | Monomorphic_const_entry _ -> mie in - let kn = Command.declare_mutual_inductive_with_eliminations mie [] [(paramimpls,[])] in + let kn = Command.declare_mutual_inductive_with_eliminations mie ubinders [(paramimpls,[])] in let rsp = (kn,0) in (* This is ind path of idstruc *) let cstr = (rsp,1) in - let fields = - if poly then - let subst, _ = Univ.abstract_universes ctx in - Context.Rel.map (fun c -> Vars.subst_univs_level_constr subst c) fields - else fields - in - let kinds,sp_projs = declare_projections rsp ~kind binder_name coers fieldimpls fields in + let kinds,sp_projs = declare_projections rsp ctx ~kind binder_name coers ubinders fieldimpls fields in let build = ConstructRef cstr in + let poly = match ctx with | Polymorphic_const_entry _ -> true | Monomorphic_const_entry _ -> false in let () = if is_coe then Class.try_add_new_coercion build ~local:false poly in Recordops.declare_structure(rsp,cstr,List.rev kinds,List.rev sp_projs); rsp @@ -449,7 +449,7 @@ let implicits_of_context ctx = in ExplByPos (i, explname), (true, true, true)) 1 (List.rev (Anonymous :: (List.map RelDecl.get_name ctx))) -let declare_class finite def cum poly ctx id idbuild paramimpls params arity +let declare_class finite def cum ubinders univs id idbuild paramimpls params arity template fieldimpls fields ?(kind=StructureComponent) is_coe coers priorities sign = let fieldimpls = (* Make the class implicit in the projections, and the params if applicable. *) @@ -464,27 +464,29 @@ let declare_class finite def cum poly ctx id idbuild paramimpls params arity let class_body = it_mkLambda_or_LetIn field params in let class_type = it_mkProd_or_LetIn arity params in let class_entry = - Declare.definition_entry ~types:class_type ~poly ~univs:ctx class_body in + Declare.definition_entry ~types:class_type ~univs class_body in let cst = Declare.declare_constant (snd id) (DefinitionEntry class_entry, IsDefinition Definition) in - let cstu = (cst, if poly then Univ.UContext.instance ctx else Univ.Instance.empty) in + let cstu = (cst, match univs with + | Polymorphic_const_entry univs -> Univ.UContext.instance univs + | Monomorphic_const_entry _ -> Univ.Instance.empty) + in let inst_type = appvectc (mkConstU cstu) (Termops.rel_vect 0 (List.length params)) in let proj_type = it_mkProd_or_LetIn (mkProd(Name binder_name, inst_type, lift 1 field)) params in let proj_body = it_mkLambda_or_LetIn (mkLambda (Name binder_name, inst_type, mkRel 1)) params in - let proj_entry = - Declare.definition_entry ~types:proj_type ~poly - ~univs:(if poly then ctx else Univ.UContext.empty) proj_body - in + let proj_entry = Declare.definition_entry ~types:proj_type ~univs proj_body in let proj_cst = Declare.declare_constant proj_name (DefinitionEntry proj_entry, IsDefinition Definition) in let cref = ConstRef cst in Impargs.declare_manual_implicits false cref [paramimpls]; + Universes.register_universe_binders cref ubinders; Impargs.declare_manual_implicits false (ConstRef proj_cst) [List.hd fieldimpls]; + Universes.register_universe_binders (ConstRef proj_cst) ubinders; Classes.set_typeclass_transparency (EvalConstRef cst) false false; let sub = match List.hd coers with | Some b -> Some ((if b then Backward else Forward), List.hd priorities) @@ -493,15 +495,16 @@ let declare_class finite def cum poly ctx id idbuild paramimpls params arity cref, [Name proj_name, sub, Some proj_cst] | _ -> let univs = - if poly then + match univs with + | Polymorphic_const_entry univs -> if cum then - Cumulative_ind_entry (Universes.univ_inf_ind_from_universe_context ctx) + Cumulative_ind_entry (Universes.univ_inf_ind_from_universe_context univs) else - Polymorphic_ind_entry ctx - else - Monomorphic_ind_entry ctx + Polymorphic_ind_entry univs + | Monomorphic_const_entry univs -> + Monomorphic_ind_entry univs in - let ind = declare_structure BiFinite univs (snd id) idbuild paramimpls + let ind = declare_structure BiFinite ubinders univs (snd id) idbuild paramimpls params arity template fieldimpls fields ~kind:Method ~name:binder_name false (List.map (fun _ -> false) fields) sign in @@ -522,13 +525,15 @@ let declare_class finite def cum poly ctx id idbuild paramimpls params arity params, params in let univs, ctx_context, fields = - if poly then - let usubst, auctx = Univ.abstract_universes ctx in + match univs with + | Polymorphic_const_entry univs -> + let usubst, auctx = Univ.abstract_universes univs in let map c = Vars.subst_univs_level_constr usubst c in let fields = Context.Rel.map map fields in let ctx_context = on_snd (fun d -> Context.Rel.map map d) ctx_context in auctx, ctx_context, fields - else Univ.AUContext.empty, ctx_context, fields + | Monomorphic_const_entry _ -> + Univ.AUContext.empty, ctx_context, fields in let k = { cl_univs = univs; @@ -604,14 +609,14 @@ let definition_structure (kind,cum,poly,finite,(is_coe,((loc,idstruc),pl)),ps,cf if isnot_class && List.exists (fun opt -> not (Option.is_empty opt)) priorities then user_err Pp.(str "Priorities only allowed for type class substructures"); (* Now, younger decl in params and fields is on top *) - let (pl, ctx), arity, template, implpars, params, implfs, fields = + let pl, univs, arity, template, implpars, params, implfs, fields = States.with_state_protection (fun () -> - typecheck_params_and_fields finite (kind = Class true) idstruc pl s ps notations fs) () in + typecheck_params_and_fields finite (kind = Class true) idstruc poly pl s ps notations fs) () in let sign = structure_signature (fields@params) in let gr = match kind with | Class def -> let priorities = List.map (fun id -> {hint_priority = id; hint_pattern = None}) priorities in - let gr = declare_class finite def cum poly ctx (loc,idstruc) idbuild + let gr = declare_class finite def cum pl univs (loc,idstruc) idbuild implpars params arity template implfs fields is_coe coers priorities sign in gr | _ -> @@ -620,18 +625,19 @@ let definition_structure (kind,cum,poly,finite,(is_coe,((loc,idstruc),pl)),ps,cf (succ (List.length params)) impls) implfs in let univs = - if poly then + match univs with + | Polymorphic_const_entry univs -> if cum then - Cumulative_ind_entry (Universes.univ_inf_ind_from_universe_context ctx) + Cumulative_ind_entry (Universes.univ_inf_ind_from_universe_context univs) else - Polymorphic_ind_entry ctx - else - Monomorphic_ind_entry ctx + Polymorphic_ind_entry univs + | Monomorphic_const_entry univs -> + Monomorphic_ind_entry univs in - let ind = declare_structure finite univs idstruc + let ind = declare_structure finite pl univs idstruc idbuild implpars params arity template implfs fields is_coe (List.map (fun coe -> not (Option.is_empty coe)) coers) sign in IndRef ind in - Universes.register_universe_binders gr pl; + Declare.declare_univ_binders gr pl; gr diff --git a/vernac/record.mli b/vernac/record.mli index 33c2fba89c..e632e7bbff 100644 --- a/vernac/record.mli +++ b/vernac/record.mli @@ -7,39 +7,15 @@ (************************************************************************) open Names -open Constr open Vernacexpr open Constrexpr -open Impargs open Globnames val primitive_flag : bool ref -(** [declare_projections ref name coers params fields] declare projections of - record [ref] (if allowed) using the given [name] as argument, and put them - as coercions accordingly to [coers]; it returns the absolute names of projections *) - -val declare_projections : - inductive -> ?kind:Decl_kinds.definition_object_kind -> Id.t -> - coercion_flag list -> manual_explicitation list list -> Context.Rel.t -> - (Name.t * bool) list * Constant.t option list - -val declare_structure : - Decl_kinds.recursivity_kind -> - Entries.inductive_universes -> - Id.t -> Id.t -> - manual_explicitation list -> Context.Rel.t -> (** params *) constr -> (** arity *) - bool (** template arity ? *) -> - Impargs.manual_explicitation list list -> Context.Rel.t -> (** fields *) - ?kind:Decl_kinds.definition_object_kind -> ?name:Id.t -> - bool -> (** coercion? *) - bool list -> (** field coercions *) - Evd.evar_map -> - inductive - val definition_structure : inductive_kind * Decl_kinds.cumulative_inductive_flag * Decl_kinds.polymorphic * - Decl_kinds.recursivity_kind * ident_decl with_coercion * local_binder_expr list * + Declarations.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 6a10eb43a2..7e96f28de4 100644 --- a/vernac/topfmt.ml +++ b/vernac/topfmt.ml @@ -288,7 +288,6 @@ let init_terminal_output ~color = *) 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 @@ -311,17 +310,23 @@ let print_err_exn ?extra any = std_logger ~pre_hdr Feedback.Error msg let with_output_to_file fname func input = - (* XXX FIXME: redirect std_ft *) - (* let old_logger = !logger in *) let channel = open_out (String.concat "." [fname; "out"]) in - (* logger := ft_logger old_logger (Format.formatter_of_out_channel channel); *) + let old_fmt = !std_ft, !err_ft, !deep_ft in + let new_ft = Format.formatter_of_out_channel channel in + std_ft := new_ft; + err_ft := new_ft; + deep_ft := new_ft; try let output = func input in - (* logger := old_logger; *) + std_ft := Util.pi1 old_fmt; + err_ft := Util.pi2 old_fmt; + deep_ft := Util.pi3 old_fmt; close_out channel; output with reraise -> let reraise = Backtrace.add_backtrace reraise in - (* logger := old_logger; *) + std_ft := Util.pi1 old_fmt; + err_ft := Util.pi2 old_fmt; + deep_ft := Util.pi3 old_fmt; close_out channel; Exninfo.iraise reraise diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib index 850902d6ba..8673155e28 100644 --- a/vernac/vernac.mllib +++ b/vernac/vernac.mllib @@ -15,6 +15,7 @@ Command Classes Record Assumptions +Vernacstate Vernacinterp Mltop Topfmt diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 5bcb3b1e15..63768d9b88 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -29,6 +29,7 @@ open Redexpr open Lemmas open Misctypes open Locality +open Vernacinterp module NamedDecl = Context.Named.Declaration @@ -56,20 +57,19 @@ let scope_class_of_qualid qid = let show_proof () = (* spiwack: this would probably be cooler with a bit of polishing. *) let p = Proof_global.give_me_the_proof () in + let sigma, env = Pfedit.get_current_context () in let pprf = Proof.partial_proof p in - Feedback.msg_notice (Pp.prlist_with_sep Pp.fnl Printer.pr_econstr pprf) + Feedback.msg_notice (Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf) let show_top_evars () = (* spiwack: new as of Feb. 2010: shows goal evars in addition to non-goal evars. *) let pfts = Proof_global.give_me_the_proof () in - let gls = Proof.V82.subgoals pfts in - let sigma = gls.Evd.sigma in + let gls,_,_,_,sigma = Proof.proof pfts in Feedback.msg_notice (pr_evars_int sigma 1 (Evd.undefined_map sigma)) let show_universes () = let pfts = Proof_global.give_me_the_proof () in - let gls = Proof.V82.subgoals pfts in - let sigma = gls.Evd.sigma in + let gls,_,_,_,sigma = Proof.proof pfts in let ctx = Evd.universe_context_set (Evd.nf_constraints sigma) in Feedback.msg_notice (Termops.pr_evar_universe_context (Evd.evar_universe_context sigma)); Feedback.msg_notice (str"Normalized constraints: " ++ Univ.pr_universe_context_set (Termops.pr_evd_level sigma) ctx) @@ -78,7 +78,7 @@ let show_universes () = let show_intro all = let open EConstr in let pf = Proof_global.give_me_the_proof() in - let {Evd.it=gls ; sigma=sigma; } = Proof.V82.subgoals pf in + let gls,_,_,_,sigma = Proof.proof pf in if not (List.is_empty gls) then begin let gl = {Evd.it=List.hd gls ; sigma = sigma; } in let l,_= decompose_prod_assum sigma (Termops.strip_outer_cast sigma (pf_concl gl)) in @@ -153,8 +153,8 @@ let show_match id = (* "Print" commands *) let print_path_entry p = - let dir = pr_dirpath (Loadpath.logical p) in - let path = str (Loadpath.physical p) in + let dir = DirPath.print (Loadpath.logical p) in + let path = str (CUnix.escaped_string_of_physical_path (Loadpath.physical p)) in Pp.hov 2 (dir ++ spc () ++ path) let print_loadpath dir = @@ -176,9 +176,9 @@ let print_modules () = let loaded_opened = List.intersect DirPath.equal opened loaded and only_loaded = List.subtract DirPath.equal loaded opened in str"Loaded and imported library files: " ++ - pr_vertical_list pr_dirpath loaded_opened ++ fnl () ++ + pr_vertical_list DirPath.print loaded_opened ++ fnl () ++ str"Loaded and not imported library files: " ++ - pr_vertical_list pr_dirpath only_loaded + pr_vertical_list DirPath.print only_loaded let print_module r = @@ -186,8 +186,8 @@ let print_module r = try let globdir = Nametab.locate_dir qid in match globdir with - DirModule (dirpath,(mp,_)) -> - Feedback.msg_notice (Printmod.print_module (Printmod.printable_body dirpath) mp) + DirModule { obj_dir; obj_mp; _ } -> + Feedback.msg_notice (Printmod.print_module (Printmod.printable_body obj_dir) obj_mp) | _ -> raise Not_found with Not_found -> Feedback.msg_error (str"Unknown Module " ++ pr_qualid qid) @@ -257,7 +257,8 @@ let print_namespace ns = let print_constant k body = (* FIXME: universes *) let t = body.Declarations.const_type in - print_kn k ++ str":" ++ spc() ++ Printer.pr_type t + let sigma, env = Pfedit.get_current_context () in + print_kn k ++ str":" ++ spc() ++ Printer.pr_type_env env sigma t in let matches mp = match match_modulepath ns mp with | Some [] -> true @@ -361,29 +362,29 @@ let locate_file f = let msg_found_library = function | Library.LibLoaded, fulldir, file -> Feedback.msg_info (hov 0 - (pr_dirpath fulldir ++ strbrk " has been loaded from file " ++ + (DirPath.print fulldir ++ strbrk " has been loaded from file " ++ str file)) | Library.LibInPath, fulldir, file -> Feedback.msg_info (hov 0 - (pr_dirpath fulldir ++ strbrk " is bound to file " ++ str file)) + (DirPath.print fulldir ++ strbrk " is bound to file " ++ str file)) let err_unmapped_library ?loc ?from qid = let dir = fst (repr_qualid qid) in let prefix = match from with | None -> str "." | Some from -> - str " and prefix " ++ pr_dirpath from ++ str "." + str " and prefix " ++ DirPath.print from ++ str "." in user_err ?loc ~hdr:"locate_library" (strbrk "Cannot find a physical path bound to logical path matching suffix " ++ - pr_dirpath dir ++ prefix) + DirPath.print dir ++ prefix) let err_notfound_library ?loc ?from qid = let prefix = match from with | None -> str "." | Some from -> - str " with prefix " ++ pr_dirpath from ++ str "." + str " with prefix " ++ DirPath.print from ++ str "." in user_err ?loc ~hdr:"locate_library" (strbrk "Unable to locate library " ++ pr_qualid qid ++ prefix) @@ -408,8 +409,8 @@ let dump_global r = (**********) (* Syntax *) -let vernac_syntax_extension locality local infix l = - let local = enforce_module_locality locality local in +let vernac_syntax_extension atts infix l = + let local = enforce_module_locality atts.locality in if infix then Metasyntax.check_infix_modifiers (snd l); Metasyntax.add_syntax_extension local l @@ -420,20 +421,20 @@ let vernac_delimiters sc = function let vernac_bind_scope sc cll = Metasyntax.add_class_scope sc (List.map scope_class_of_qualid cll) -let vernac_open_close_scope locality local (b,s) = - let local = enforce_section_locality locality local in +let vernac_open_close_scope ~atts (b,s) = + let local = enforce_section_locality atts.locality in Notation.open_close_scope (local,b,s) -let vernac_arguments_scope locality r scl = - let local = make_section_locality locality in +let vernac_arguments_scope ~atts r scl = + let local = make_section_locality atts.locality in Notation.declare_arguments_scope local (smart_global r) scl -let vernac_infix locality local = - let local = enforce_module_locality locality local in +let vernac_infix ~atts = + let local = enforce_module_locality atts.locality in Metasyntax.add_infix local (Global.env()) -let vernac_notation locality local = - let local = enforce_module_locality locality local in +let vernac_notation ~atts = + let local = enforce_module_locality atts.locality in Metasyntax.add_notation local (Global.env()) (***********) @@ -471,33 +472,33 @@ let vernac_definition_hook p = function | SubClass -> Class.add_subclass_hook p | _ -> no_hook -let vernac_definition locality p (local,k) ((loc,id as lid),pl) def = - let local = enforce_locality_exp locality local in - let hook = vernac_definition_hook p k in +let vernac_definition ~atts discharge kind ((loc,id as lid),pl) def = + let local = enforce_locality_exp atts.locality discharge in + let hook = vernac_definition_hook atts.polymorphic kind in let () = match local with | Discharge -> Dumpglob.dump_definition lid true "var" | Local | Global -> Dumpglob.dump_definition lid false "def" in (match def with | ProveBody (bl,t) -> (* local binders, typ *) - start_proof_and_print (local,p,DefinitionBody k) + start_proof_and_print (local, atts.polymorphic, DefinitionBody kind) [Some (lid,pl), (bl,t)] hook | DefineBody (bl,red_option,c,typ_opt) -> - let red_option = match red_option with + let red_option = match red_option with | None -> None | Some r -> - let (evc,env)= get_current_context () in - Some (snd (Hook.get f_interp_redexp env evc r)) in - do_definition id (local,p,k) pl bl red_option c typ_opt hook) + let sigma, env = Pfedit.get_current_context () in + Some (snd (Hook.get f_interp_redexp env sigma r)) in + do_definition id (local, atts.polymorphic, kind) pl bl red_option c typ_opt hook) -let vernac_start_proof locality p kind l = - let local = enforce_locality_exp locality None in +let vernac_start_proof ~atts kind l = + let local = enforce_locality_exp atts.locality NoDischarge in if Dumpglob.dump () then List.iter (fun (id, _) -> match id with | Some (lid,_) -> Dumpglob.dump_definition lid false "prf" | None -> ()) l; - start_proof_and_print (local, p, Proof kind) l no_hook + start_proof_and_print (local, atts.polymorphic, Proof kind) l no_hook let vernac_end_proof ?proof = function | Admitted -> save_proof ?proof Admitted @@ -510,10 +511,10 @@ let vernac_exact_proof c = save_proof (Vernacexpr.(Proved(Opaque,None))); if not status then Feedback.feedback Feedback.AddedAxiom -let vernac_assumption locality poly (local, kind) l nl = - let local = enforce_locality_exp locality local in +let vernac_assumption ~atts discharge kind l nl = + let local = enforce_locality_exp atts.locality discharge in let global = local == Global in - let kind = local, poly, kind in + let kind = local, atts.polymorphic, kind in List.iter (fun (is_coe,(idl,c)) -> if Dumpglob.dump () then List.iter (fun (lid, _) -> @@ -553,8 +554,8 @@ let vernac_record cum k poly finite struc binders sort nameopt cfs = then the type is declared private (as per the [Private] keyword). [finite] indicates whether the type is inductive, co-inductive or neither. *) -let vernac_inductive cum poly lo finite indl = - let is_cumulative = should_treat_as_cumulative cum poly in +let vernac_inductive ~atts cum lo finite indl = + let is_cumulative = should_treat_as_cumulative cum atts.polymorphic in if Dumpglob.dump () then List.iter (fun (((coe,(lid,_)), _, _, _, cstrs), _) -> match cstrs with @@ -571,13 +572,13 @@ let vernac_inductive cum poly lo finite indl = user_err Pp.(str "The Variant keyword does not support syntax { ... }.") | [ ( id , bl , c , b, RecordDecl (oc,fs) ), [] ] -> vernac_record cum (match b with Class _ -> Class false | _ -> b) - poly finite id bl c oc fs + atts.polymorphic finite id bl c oc fs | [ ( id , bl , c , Class _, Constructors [l]), [] ] -> let f = let (coe, ((loc, id), ce)) = l in let coe' = if coe then Some true else None in (((coe', AssumExpr ((loc, Name id), ce)), None), []) - in vernac_record cum (Class true) poly finite id bl c None [f] + in vernac_record cum (Class true) atts.polymorphic finite id bl c None [f] | [ ( _ , _, _, Class _, Constructors _), [] ] -> user_err Pp.(str "Inductive classes not supported") | [ ( id , bl , c , Class _, _), _ :: _ ] -> @@ -591,19 +592,19 @@ let vernac_inductive cum poly lo finite indl = | _ -> user_err Pp.(str "Cannot handle mutually (co)inductive records.") in let indl = List.map unpack indl in - do_mutual_inductive indl is_cumulative poly lo finite + do_mutual_inductive indl is_cumulative atts.polymorphic lo finite -let vernac_fixpoint locality poly local l = - let local = enforce_locality_exp locality local in +let vernac_fixpoint ~atts discharge l = + let local = enforce_locality_exp atts.locality discharge in if Dumpglob.dump () then List.iter (fun (((lid,_), _, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; - do_fixpoint local poly l + do_fixpoint local atts.polymorphic l -let vernac_cofixpoint locality poly local l = - let local = enforce_locality_exp locality local in +let vernac_cofixpoint ~atts discharge l = + let local = enforce_locality_exp atts.locality discharge in if Dumpglob.dump () then List.iter (fun (((lid,_), _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; - do_cofixpoint local poly l + do_cofixpoint local atts.polymorphic l let vernac_scheme l = if Dumpglob.dump () then @@ -621,19 +622,19 @@ let vernac_combined_scheme lid l = List.iter (fun lid -> dump_global (Misctypes.AN (Ident lid))) l); Indschemes.do_combined_scheme lid l -let vernac_universe loc poly l = - if poly && not (Lib.sections_are_opened ()) then - user_err ?loc ~hdr:"vernac_universe" +let vernac_universe ~atts l = + if atts.polymorphic && not (Lib.sections_are_opened ()) then + user_err ?loc:atts.loc ~hdr:"vernac_universe" (str"Polymorphic universes can only be declared inside sections, " ++ str "use Monomorphic Universe instead"); - do_universe poly l + do_universe atts.polymorphic l -let vernac_constraint loc poly l = - if poly && not (Lib.sections_are_opened ()) then - user_err ?loc ~hdr:"vernac_constraint" +let vernac_constraint ~atts l = + if atts.polymorphic && not (Lib.sections_are_opened ()) then + user_err ?loc:atts.loc ~hdr:"vernac_constraint" (str"Polymorphic universe constraints can only be declared" ++ str " inside sections, use Monomorphic Constraint instead"); - do_constraint poly l + do_constraint atts.polymorphic l (**********************) (* Modules *) @@ -811,32 +812,32 @@ let vernac_require from import qidl = let vernac_canonical r = Recordops.declare_canonical_structure (smart_global r) -let vernac_coercion locality poly local ref qids qidt = - let local = enforce_locality locality local in +let vernac_coercion ~atts ref qids qidt = + let local = enforce_locality atts.locality in let target = cl_of_qualid qidt in 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; + Class.try_add_new_coercion_with_target ref' ~local atts.polymorphic ~source ~target; 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 +let vernac_identity_coercion ~atts id qids qidt = + let local = enforce_locality atts.locality in let target = cl_of_qualid qidt in let source = cl_of_qualid qids in - Class.try_add_new_identity_coercion id ~local poly ~source ~target + Class.try_add_new_identity_coercion id ~local atts.polymorphic ~source ~target (* Type classes *) -let vernac_instance abst locality poly sup inst props pri = - let global = not (make_section_locality locality) in +let vernac_instance ~atts abst sup inst props pri = + let global = not (make_section_locality atts.locality) in Dumpglob.dump_constraint inst false "inst"; - ignore(Classes.new_instance ~abstract:abst ~global poly sup inst props pri) + ignore(Classes.new_instance ~abstract:abst ~global atts.polymorphic sup inst props pri) -let vernac_context poly l = - if not (Classes.context poly l) then Feedback.feedback Feedback.AddedAxiom +let vernac_context ~atts l = + if not (Classes.context atts.polymorphic l) then Feedback.feedback Feedback.AddedAxiom -let vernac_declare_instances locality insts = - let glob = not (make_section_locality locality) in +let vernac_declare_instances ~atts insts = + let glob = not (make_section_locality atts.locality) in List.iter (fun (id, info) -> Classes.existing_instance glob id (Some info)) insts let vernac_declare_class id = @@ -893,7 +894,7 @@ let expand filename = let vernac_add_loadpath implicit pdir ldiropt = let pdir = expand pdir in - let alias = Option.default Nameops.default_root_prefix ldiropt in + let alias = Option.default Libnames.default_root_prefix ldiropt in Mltop.add_rec_path Mltop.AddTopML ~unix_path:pdir ~coq_root:alias ~implicit let vernac_remove_loadpath path = @@ -904,8 +905,8 @@ let vernac_remove_loadpath path = let vernac_add_ml_path isrec path = (if isrec then Mltop.add_rec_ml_dir else Mltop.add_ml_dir) (expand path) -let vernac_declare_ml_module locality l = - let local = make_locality locality in +let vernac_declare_ml_module ~atts l = + let local = make_locality atts.locality in Mltop.declare_ml_modules local (List.map expand l) let vernac_chdir = function @@ -938,25 +939,25 @@ let vernac_restore_state file = (************) (* Commands *) -let vernac_create_hintdb locality id b = - let local = make_module_locality locality in +let vernac_create_hintdb ~atts id b = + let local = make_module_locality atts.locality in Hints.create_hint_db local id full_transparent_state b -let vernac_remove_hints locality dbs ids = - let local = make_module_locality locality in +let vernac_remove_hints ~atts dbs ids = + let local = make_module_locality atts.locality in Hints.remove_hints local dbs (List.map Smartlocate.global_with_alias ids) -let vernac_hints locality poly local lb h = - let local = enforce_module_locality locality local in - Hints.add_hints local lb (Hints.interp_hints poly h) +let vernac_hints ~atts lb h = + let local = enforce_module_locality atts.locality in + Hints.add_hints local lb (Hints.interp_hints atts.polymorphic h) -let vernac_syntactic_definition locality lid x local y = +let vernac_syntactic_definition ~atts lid x y = Dumpglob.dump_definition lid false "syndef"; - let local = enforce_module_locality locality local in + let local = enforce_module_locality atts.locality in Metasyntax.add_syntactic_definition (Global.env()) (snd lid) x local y -let vernac_declare_implicits locality r l = - let local = make_section_locality locality in +let vernac_declare_implicits ~atts r l = + let local = make_section_locality atts.locality in match l with | [] -> Impargs.declare_implicits local (smart_global r) @@ -976,7 +977,7 @@ let warn_arguments_assert = (* [nargs_for_red] is the number of arguments required to trigger reduction, [args] is the main list of arguments statuses, [more_implicits] is a list of extra lists of implicit statuses *) -let vernac_arguments locality reference args more_implicits nargs_for_red flags = +let vernac_arguments ~atts reference args more_implicits nargs_for_red flags = let assert_flag = List.mem `Assert flags in let rename_flag = List.mem `Rename flags in let clear_scopes_flag = List.mem `ClearScopes flags in @@ -1184,7 +1185,7 @@ let vernac_arguments locality reference args more_implicits nargs_for_red flags (* Actions *) if renaming_specified then begin - let local = make_section_locality locality in + let local = make_section_locality atts.locality in Arguments_renaming.rename_arguments local sr names end; @@ -1194,20 +1195,20 @@ let vernac_arguments locality reference args more_implicits nargs_for_red flags with UserError _ -> Notation.find_delimiters_scope ?loc k)) scopes in - vernac_arguments_scope locality reference scopes + vernac_arguments_scope ~atts reference scopes end; if implicits_specified || clear_implicits_flag then - vernac_declare_implicits locality reference implicits; + vernac_declare_implicits ~atts reference implicits; if default_implicits_flag then - vernac_declare_implicits locality reference []; + vernac_declare_implicits ~atts reference []; if red_modifiers_specified then begin match sr with | ConstRef _ as c -> Reductionops.ReductionBehaviour.set - (make_section_locality locality) c + (make_section_locality atts.locality) c (rargs, Option.default ~-1 nargs_for_red, red_flags) | _ -> user_err (strbrk "Modifiers of the behavior of the simpl tactic "++ @@ -1235,8 +1236,8 @@ let vernac_reserve bl = Reserve.declare_reserved_type idl t) in List.iter sb_decl bl -let vernac_generalizable locality = - let local = make_non_locality locality in +let vernac_generalizable ~atts = + let local = make_non_locality atts.locality in Implicit_quantifiers.declare_generalizable local let _ = @@ -1473,8 +1474,8 @@ let _ = optread = Nativenorm.get_profiling_enabled; optwrite = Nativenorm.set_profiling_enabled } -let vernac_set_strategy locality l = - let local = make_locality locality in +let vernac_set_strategy ~atts l = + let local = make_locality atts.locality in let glob_ref r = match smart_global r with | ConstRef sp -> EvalConstRef sp @@ -1484,8 +1485,8 @@ let vernac_set_strategy locality l = let l = List.map (fun (lev,ql) -> (lev,List.map glob_ref ql)) l in Redexpr.set_strategy local l -let vernac_set_opacity locality (v,l) = - let local = make_non_locality locality in +let vernac_set_opacity ~atts (v,l) = + let local = make_non_locality atts.locality in let glob_ref r = match smart_global r with | ConstRef sp -> EvalConstRef sp @@ -1495,18 +1496,18 @@ let vernac_set_opacity locality (v,l) = let l = List.map glob_ref l in Redexpr.set_strategy local [v,l] -let vernac_set_option locality key = function - | StringValue s -> set_string_option_value_gen locality key s - | StringOptValue (Some s) -> set_string_option_value_gen locality key s - | StringOptValue None -> unset_option_value_gen locality key - | IntValue n -> set_int_option_value_gen locality key n - | BoolValue b -> set_bool_option_value_gen locality key b +let vernac_set_option ~atts key = function + | StringValue s -> set_string_option_value_gen atts.locality key s + | StringOptValue (Some s) -> set_string_option_value_gen atts.locality key s + | StringOptValue None -> unset_option_value_gen atts.locality key + | IntValue n -> set_int_option_value_gen atts.locality key n + | BoolValue b -> set_bool_option_value_gen atts.locality key b -let vernac_set_append_option locality key s = - set_string_option_append_value_gen locality key s +let vernac_set_append_option ~atts key s = + set_string_option_append_value_gen atts.locality key s -let vernac_unset_option locality key = - unset_option_value_gen locality key +let vernac_unset_option ~atts key = + unset_option_value_gen atts.locality key let vernac_add_option key lv = let f = function @@ -1539,7 +1540,7 @@ let vernac_print_option key = let get_current_context_of_args = function | Some n -> Pfedit.get_goal_context n - | None -> get_current_context () + | None -> Pfedit.get_current_context () let query_command_selector ?loc = function | None -> None @@ -1547,16 +1548,16 @@ let query_command_selector ?loc = function | _ -> user_err ?loc ~hdr:"query_command_selector" (str "Query commands only support the single numbered goal selector.") -let vernac_check_may_eval ?loc redexp glopt rc = - let glopt = query_command_selector ?loc glopt in +let vernac_check_may_eval ~atts redexp glopt rc = + let glopt = query_command_selector ?loc:atts.loc glopt in let (sigma, env) = get_current_context_of_args glopt in let sigma', c = interp_open_constr env sigma rc in let c = EConstr.Unsafe.to_constr c in 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 ~names:[] ~extensible:true sigma' in - let env = Environ.push_context uctx (Evarutil.nf_env_evar sigma' env) in + let uctx = Evd.universe_context_set sigma' in + let env = Environ.push_context_set uctx (Evarutil.nf_env_evar sigma' env) in let c = nf c in let j = if Evarutil.has_undefined_evars sigma' (EConstr.of_constr c) then @@ -1572,7 +1573,7 @@ let vernac_check_may_eval ?loc redexp glopt rc = let j = { j with Environ.uj_type = Reductionops.nf_betaiota sigma' j.Environ.uj_type } in Feedback.msg_notice (print_judgment env sigma' j ++ pr_ne_evar_set (fnl () ++ str "where" ++ fnl ()) (mt ()) sigma' l ++ - Printer.pr_universe_ctx sigma uctx) + Printer.pr_universe_ctx_set sigma uctx) | Some r -> let (sigma',r_interp) = Hook.get f_interp_redexp env sigma' r in let redfun env evm c = @@ -1582,8 +1583,8 @@ let vernac_check_may_eval ?loc redexp glopt rc = in Feedback.msg_notice (print_eval redfun env sigma' rc j) -let vernac_declare_reduction locality s r = - let local = make_locality locality in +let vernac_declare_reduction ~atts s r = + let local = make_locality atts.locality in declare_red_expr local s (snd (Hook.get f_interp_redexp (Global.env()) Evd.empty r)) (* The same but avoiding the current goal context if any *) @@ -1601,7 +1602,7 @@ let vernac_global_check c = let get_nth_goal n = let pf = Proof_global.give_me_the_proof() in - let {Evd.it=gls ; sigma=sigma; } = Proof.V82.subgoals pf in + let gls,_,_,_,sigma = Proof.proof pf in let gl = {Evd.it=List.nth gls (n-1) ; sigma = sigma; } in gl @@ -1609,9 +1610,10 @@ exception NoHyp (* Printing "About" information of a hypothesis of the current goal. We only print the type and a small statement to this comes from the goal. Precondition: there must be at least one current goal. *) -let print_about_hyp_globs ?loc ref_or_by_not glopt = +let print_about_hyp_globs ?loc ref_or_by_not udecl glopt = let open Context.Named.Declaration in try + (* FIXME error on non None udecl if we find the hyp. *) let glnumopt = query_command_selector ?loc glopt in let gl,id = match glnumopt,ref_or_by_not with @@ -1628,17 +1630,22 @@ let print_about_hyp_globs ?loc ref_or_by_not glopt = let natureofid = match decl with | LocalAssum _ -> "Hypothesis" | LocalDef (_,bdy,_) ->"Constant (let in)" in - v 0 (Id.print id ++ str":" ++ pr_econstr (NamedDecl.get_type decl) ++ fnl() ++ fnl() + let sigma, env = Pfedit.get_current_context () in + v 0 (Id.print id ++ str":" ++ pr_econstr_env env sigma (NamedDecl.get_type decl) ++ fnl() ++ fnl() ++ str natureofid ++ str " of the goal context.") with (* fallback to globals *) - | NoHyp | Not_found -> print_about ref_or_by_not + | NoHyp | Not_found -> + let sigma, env = Pfedit.get_current_context () in + print_about env sigma ref_or_by_not udecl - -let vernac_print ?loc = let open Feedback in function +let vernac_print ~atts env sigma = + let open Feedback in + let loc = atts.loc in + function | PrintTables -> msg_notice (print_tables ()) - | PrintFullContext-> msg_notice (print_full_context_typ ()) - | PrintSectionContext qid -> msg_notice (print_sec_context_typ qid) - | PrintInspect n -> msg_notice (inspect n) + | PrintFullContext-> msg_notice (print_full_context_typ env sigma) + | PrintSectionContext qid -> msg_notice (print_sec_context_typ env sigma qid) + | PrintInspect n -> msg_notice (inspect env sigma n) | PrintGrammar ent -> msg_notice (Metasyntax.pr_grammar ent) | PrintLoadPath dir -> (* For compatibility ? *) msg_notice (print_loadpath dir) | PrintModules -> msg_notice (print_modules ()) @@ -1648,15 +1655,15 @@ let vernac_print ?loc = let open Feedback in function | PrintMLLoadPath -> msg_notice (Mltop.print_ml_path ()) | PrintMLModules -> msg_notice (Mltop.print_ml_modules ()) | PrintDebugGC -> msg_notice (Mltop.print_gc ()) - | PrintName qid -> dump_global qid; msg_notice (print_name qid) + | PrintName (qid,udecl) -> dump_global qid; msg_notice (print_name env sigma qid udecl) | PrintGraph -> msg_notice (Prettyp.print_graph()) | PrintClasses -> msg_notice (Prettyp.print_classes()) | PrintTypeClasses -> msg_notice (Prettyp.print_typeclasses()) | PrintInstances c -> msg_notice (Prettyp.print_instances (smart_global c)) - | PrintCoercions -> msg_notice (Prettyp.print_coercions()) + | PrintCoercions -> msg_notice (Prettyp.print_coercions env sigma) | PrintCoercionPaths (cls,clt) -> msg_notice (Prettyp.print_path_between (cl_of_qualid cls) (cl_of_qualid clt)) - | PrintCanonicalConversions -> msg_notice (Prettyp.print_canonical_projections ()) + | PrintCanonicalConversions -> msg_notice (Prettyp.print_canonical_projections env sigma) | PrintUniverses (b, dst) -> let univ = Global.universes () in let univ = if b then UGraph.sort_universes univ else univ in @@ -1668,18 +1675,18 @@ let vernac_print ?loc = let open Feedback in function | None -> msg_notice (UGraph.pr_universes Universes.pr_with_global_universes univ ++ pr_remaining) | Some s -> dump_universes_gen univ s end - | PrintHint r -> msg_notice (Hints.pr_hint_ref (smart_global r)) + | PrintHint r -> msg_notice (Hints.pr_hint_ref env sigma (smart_global r)) | PrintHintGoal -> msg_notice (Hints.pr_applicable_hint ()) - | PrintHintDbName s -> msg_notice (Hints.pr_hint_db_by_name s) - | PrintHintDb -> msg_notice (Hints.pr_searchtable ()) + | PrintHintDbName s -> msg_notice (Hints.pr_hint_db_by_name env sigma s) + | PrintHintDb -> msg_notice (Hints.pr_searchtable env sigma) | PrintScopes -> - msg_notice (Notation.pr_scopes (Constrextern.without_symbols pr_lglob_constr)) + msg_notice (Notation.pr_scopes (Constrextern.without_symbols (pr_lglob_constr_env env))) | PrintScope s -> - msg_notice (Notation.pr_scope (Constrextern.without_symbols pr_lglob_constr) s) + msg_notice (Notation.pr_scope (Constrextern.without_symbols (pr_lglob_constr_env env)) s) | PrintVisibility s -> - msg_notice (Notation.pr_visibility (Constrextern.without_symbols pr_lglob_constr) s) - | PrintAbout (ref_or_by_not,glnumopt) -> - msg_notice (print_about_hyp_globs ?loc ref_or_by_not glnumopt) + msg_notice (Notation.pr_visibility (Constrextern.without_symbols (pr_lglob_constr_env env)) s) + | PrintAbout (ref_or_by_not,udecl,glnumopt) -> + msg_notice (print_about_hyp_globs ?loc ref_or_by_not udecl glnumopt) | PrintImplicit qid -> dump_global qid; msg_notice (print_impargs qid) | PrintAssumptions (o,t,r) -> @@ -1743,8 +1750,8 @@ let _ = optread = (fun () -> !search_output_name_only); optwrite = (:=) search_output_name_only } -let vernac_search ?loc s gopt r = - let gopt = query_command_selector ?loc gopt in +let vernac_search ~atts s gopt r = + let gopt = query_command_selector ?loc:atts.loc gopt in let r = interp_search_restriction r in let env,gopt = match gopt with | None -> @@ -1780,9 +1787,10 @@ let vernac_locate = let open Feedback in function | LocateTerm (AN qid) -> msg_notice (print_located_term qid) | LocateAny (ByNotation (_, (ntn, sc))) (** TODO : handle Ltac notations *) | LocateTerm (ByNotation (_, (ntn, sc))) -> - msg_notice - (Notation.locate_notation - (Constrextern.without_symbols pr_lglob_constr) ntn sc) + let _, env = Pfedit.get_current_context () in + msg_notice + (Notation.locate_notation + (Constrextern.without_symbols (pr_lglob_constr_env env)) ntn sc) | LocateLibrary qid -> print_located_library qid | LocateModule qid -> msg_notice (print_located_module qid) | LocateOther (s, qid) -> msg_notice (print_located_other s qid) @@ -1849,10 +1857,11 @@ let vernac_bullet (bullet : Proof_bullet.t) = let vernac_show = let open Feedback in function | ShowScript -> assert false (* Only the stm knows the script *) | ShowGoal goalref -> + let proof = Proof_global.give_me_the_proof () in let info = match goalref with - | OpenSubgoals -> pr_open_subgoals () - | NthGoal n -> pr_nth_open_subgoal n - | GoalId id -> pr_goal_by_id id + | OpenSubgoals -> pr_open_subgoals ~proof + | NthGoal n -> pr_nth_open_subgoal ~proof n + | GoalId id -> pr_goal_by_id ~proof id in msg_notice info | ShowProof -> show_proof () @@ -1909,7 +1918,8 @@ let vernac_load interp fname = * is the outdated/deprecated "Local" attribute of some vernacular commands * still parsed as the obsolete_locality grammar entry for retrocompatibility. * loc is the Loc.t of the vernacular command being interpreted. *) -let interp ?proof ?loc locality poly c = +let interp ?proof ~atts ~st c = + let open Vernacinterp in vernac_pperr_endline (fun () -> str "interpreting: " ++ Ppvernac.pr_vernac c); match c with (* The below vernac are candidates for removal from the main type @@ -1948,31 +1958,33 @@ let interp ?proof ?loc locality poly c = | VernacLocal _ -> assert false (* Syntax *) - | VernacSyntaxExtension (infix, local,sl) -> - vernac_syntax_extension locality local infix sl + | VernacSyntaxExtension (infix, sl) -> + vernac_syntax_extension atts 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 - | VernacArgumentsScope (qid,scl) -> vernac_arguments_scope locality qid scl - | VernacInfix (local,mv,qid,sc) -> vernac_infix locality local mv qid sc - | VernacNotation (local,c,infpl,sc) -> - vernac_notation locality local c infpl sc + | VernacOpenCloseScope (b, s) -> vernac_open_close_scope ~atts (b,s) + | VernacArgumentsScope (qid,scl) -> vernac_arguments_scope ~atts qid scl + | VernacInfix (mv,qid,sc) -> vernac_infix ~atts mv qid sc + | VernacNotation (c,infpl,sc) -> + vernac_notation ~atts c infpl sc | VernacNotationAddFormat(n,k,v) -> Metasyntax.add_notation_extra_printing_rule n k v (* Gallina *) - | VernacDefinition (k,lid,d) -> vernac_definition locality poly k lid d - | VernacStartTheoremProof (k,l) -> vernac_start_proof locality poly k l + | VernacDefinition ((discharge,kind),lid,d) -> + vernac_definition ~atts discharge kind lid d + | VernacStartTheoremProof (k,l) -> vernac_start_proof ~atts k l | VernacEndProof e -> vernac_end_proof ?proof e | VernacExactProof c -> vernac_exact_proof c - | VernacAssumption (stre,nl,l) -> vernac_assumption locality poly stre l nl - | VernacInductive (cum, priv,finite,l) -> vernac_inductive cum poly priv finite l - | VernacFixpoint (local, l) -> vernac_fixpoint locality poly local l - | VernacCoFixpoint (local, l) -> vernac_cofixpoint locality poly local l + | VernacAssumption ((discharge,kind),nl,l) -> + vernac_assumption ~atts discharge kind l nl + | VernacInductive (cum, priv,finite,l) -> vernac_inductive ~atts cum priv finite l + | VernacFixpoint (discharge, l) -> vernac_fixpoint ~atts discharge l + | VernacCoFixpoint (discharge, l) -> vernac_cofixpoint ~atts discharge l | VernacScheme l -> vernac_scheme l | VernacCombinedScheme (id, l) -> vernac_combined_scheme id l - | VernacUniverse l -> vernac_universe loc poly l - | VernacConstraint l -> vernac_constraint loc poly l + | VernacUniverse l -> vernac_universe ~atts l + | VernacConstraint l -> vernac_constraint ~atts l (* Modules *) | VernacDeclareModule (export,lid,bl,mtyo) -> @@ -1993,15 +2005,15 @@ let interp ?proof ?loc locality poly c = | VernacRequire (from, export, qidl) -> vernac_require from export qidl | VernacImport (export,qidl) -> vernac_import export qidl | VernacCanonical qid -> vernac_canonical qid - | VernacCoercion (local,r,s,t) -> vernac_coercion locality poly local r s t - | VernacIdentityCoercion (local,(_,id),s,t) -> - vernac_identity_coercion locality poly local id s t + | VernacCoercion (r,s,t) -> vernac_coercion ~atts r s t + | VernacIdentityCoercion ((_,id),s,t) -> + vernac_identity_coercion ~atts id s t (* Type classes *) | VernacInstance (abst, sup, inst, props, info) -> - vernac_instance abst locality poly sup inst props info - | VernacContext sup -> vernac_context poly sup - | VernacDeclareInstances insts -> vernac_declare_instances locality insts + vernac_instance ~atts abst sup inst props info + | VernacContext sup -> vernac_context ~atts sup + | VernacDeclareInstances insts -> vernac_declare_instances ~atts insts | VernacDeclareClass id -> vernac_declare_class id (* Solving *) @@ -2011,7 +2023,7 @@ let interp ?proof ?loc locality poly c = | VernacAddLoadPath (isrec,s,alias) -> vernac_add_loadpath isrec s alias | VernacRemoveLoadPath s -> vernac_remove_loadpath s | VernacAddMLPath (isrec,s) -> vernac_add_ml_path isrec s - | VernacDeclareMLModule l -> vernac_declare_ml_module locality l + | VernacDeclareMLModule l -> vernac_declare_ml_module ~atts l | VernacChdir s -> vernac_chdir s (* State management *) @@ -2019,38 +2031,40 @@ let interp ?proof ?loc locality poly c = | VernacRestoreState s -> vernac_restore_state s (* Commands *) - | VernacCreateHintDb (dbname,b) -> vernac_create_hintdb locality dbname b - | VernacRemoveHints (dbnames,ids) -> vernac_remove_hints locality dbnames ids - | VernacHints (local,dbnames,hints) -> - vernac_hints locality poly local dbnames hints - | VernacSyntacticDefinition (id,c,local,b) -> - vernac_syntactic_definition locality id c local b + | VernacCreateHintDb (dbname,b) -> vernac_create_hintdb ~atts dbname b + | VernacRemoveHints (dbnames,ids) -> vernac_remove_hints ~atts dbnames ids + | VernacHints (dbnames,hints) -> + vernac_hints ~atts dbnames hints + | VernacSyntacticDefinition (id,c,b) -> + vernac_syntactic_definition ~atts id c b | VernacDeclareImplicits (qid,l) -> - vernac_declare_implicits locality qid l + vernac_declare_implicits ~atts qid l | VernacArguments (qid, args, more_implicits, nargs, flags) -> - vernac_arguments locality qid args more_implicits nargs flags + vernac_arguments ~atts qid args more_implicits nargs flags | VernacReserve bl -> vernac_reserve bl - | VernacGeneralizable gen -> vernac_generalizable locality gen - | VernacSetOpacity qidl -> vernac_set_opacity locality qidl - | VernacSetStrategy l -> vernac_set_strategy locality l - | VernacSetOption (key,v) -> vernac_set_option locality key v - | VernacSetAppendOption (key,v) -> vernac_set_append_option locality key v - | VernacUnsetOption key -> vernac_unset_option locality key + | VernacGeneralizable gen -> vernac_generalizable ~atts gen + | VernacSetOpacity qidl -> vernac_set_opacity ~atts qidl + | VernacSetStrategy l -> vernac_set_strategy ~atts l + | VernacSetOption (key,v) -> vernac_set_option ~atts key v + | VernacSetAppendOption (key,v) -> vernac_set_append_option ~atts key v + | VernacUnsetOption key -> vernac_unset_option ~atts key | VernacRemoveOption (key,v) -> vernac_remove_option key v | VernacAddOption (key,v) -> vernac_add_option key v | VernacMemOption (key,v) -> vernac_mem_option key v | VernacPrintOption key -> vernac_print_option key - | VernacCheckMayEval (r,g,c) -> vernac_check_may_eval ?loc r g c - | VernacDeclareReduction (s,r) -> vernac_declare_reduction locality s r + | VernacCheckMayEval (r,g,c) -> vernac_check_may_eval ~atts r g c + | VernacDeclareReduction (s,r) -> vernac_declare_reduction ~atts s r | VernacGlobalCheck c -> vernac_global_check c - | VernacPrint p -> vernac_print ?loc p - | VernacSearch (s,g,r) -> vernac_search ?loc s g r + | VernacPrint p -> + let sigma, env = Pfedit.get_current_context () in + vernac_print ~atts env sigma p + | VernacSearch (s,g,r) -> vernac_search ~atts s g r | VernacLocate l -> vernac_locate l | VernacRegister (id, r) -> vernac_register id r | VernacComments l -> Flags.if_verbose Feedback.msg_info (str "Comments ok\n") (* Proof management *) - | VernacGoal t -> vernac_start_proof locality poly Theorem [None,([],t)] + | VernacGoal t -> vernac_start_proof ~atts Theorem [None,([],t)] | VernacFocus n -> vernac_focus n | VernacUnfocus -> vernac_unfocus () | VernacUnfocused -> vernac_unfocused () @@ -2063,13 +2077,16 @@ let interp ?proof ?loc locality poly c = let using = Option.append using (Proof_using.get_default_proof_using ()) in let tacs = if Option.is_empty tac then "tac:no" else "tac:yes" in let usings = if Option.is_empty using then "using:no" else "using:yes" in - Aux_file.record_in_aux_at ?loc "VernacProof" (tacs^" "^usings); + Aux_file.record_in_aux_at ?loc:atts.loc "VernacProof" (tacs^" "^usings); Option.iter vernac_set_end_tac tac; Option.iter vernac_set_used_variables using | VernacProofMode mn -> Proof_global.set_proof_mode mn [@ocaml.warning "-3"] (* Extensions *) - | VernacExtend (opn,args) -> Vernacinterp.call ?locality ?loc (opn,args) + | VernacExtend (opn,args) -> + (* XXX: Here we are returning the state! :) *) + let _st : Vernacstate.t = Vernacinterp.call ~atts opn args ~st in + () (* Vernaculars that take a locality flag *) let check_vernac_supports_locality c l = @@ -2100,7 +2117,7 @@ let check_vernac_supports_polymorphism c p = | None, _ -> () | Some _, ( VernacDefinition _ | VernacFixpoint _ | VernacCoFixpoint _ - | VernacAssumption _ | VernacInductive _ + | VernacAssumption _ | VernacInductive _ | VernacStartTheoremProof _ | VernacCoercion _ | VernacIdentityCoercion _ | VernacInstance _ | VernacDeclareInstances _ @@ -2109,7 +2126,7 @@ let check_vernac_supports_polymorphism c p = | Some _, _ -> user_err Pp.(str "This command does not support Polymorphism") let enforce_polymorphism = function - | None -> Flags.is_universe_polymorphism () + | None -> Flags.is_universe_polymorphism () | Some b -> Flags.make_polymorphic_flag b; b (** A global default timeout, controlled by option "Set Default Timeout n". @@ -2134,7 +2151,7 @@ let vernac_timeout f = match !current_timeout, !default_timeout with | Some n, _ | None, Some n -> let f () = f (); current_timeout := None in - Control.timeout n f Timeout + Control.timeout n f () Timeout | None, None -> f () let restore_timeout () = current_timeout := None @@ -2147,28 +2164,6 @@ let locate_if_not_already ?loc (e, info) = exception HasNotFailed exception HasFailed of Pp.t -type interp_state = { (* TODO: inline records in OCaml 4.03 *) - system : States.state; (* summary + libstack *) - proof : Proof_global.state; (* proof state *) - shallow : bool (* is the state trimmed down (libstack) *) -} - -let s_cache = ref (States.freeze ~marshallable:`No) -let s_proof = ref (Proof_global.freeze ~marshallable:`No) - -let invalidate_cache () = - s_cache := Obj.magic 0; - s_proof := Obj.magic 0 - -let freeze_interp_state marshallable = - { system = (s_cache := States.freeze ~marshallable; !s_cache); - proof = (s_proof := Proof_global.freeze ~marshallable; !s_proof); - shallow = marshallable = `Shallow } - -let unfreeze_interp_state { system; proof } = - if (!s_cache != system) then (s_cache := system; States.unfreeze system); - if (!s_proof != proof) then (s_proof := proof; Proof_global.unfreeze proof) - (* XXX STATE: this type hints that restoring the state should be the caller's responsibility *) let with_fail st b f = @@ -2187,8 +2182,8 @@ let with_fail st b f = (ExplainErr.process_vernac_interp_error ~allow_uncaught:false e))) with e when CErrors.noncritical e -> (* Restore the previous state XXX Careful here with the cache! *) - invalidate_cache (); - unfreeze_interp_state st; + Vernacstate.invalidate_cache (); + Vernacstate.unfreeze_interp_state st; let (e, _) = CErrors.push e in match e with | HasNotFailed -> @@ -2199,42 +2194,57 @@ let with_fail st b f = | _ -> assert false end -let interp ?(verbosely=true) ?proof st (loc,c) = +let interp ?(verbosely=true) ?proof ~st (loc,c) = let orig_program_mode = Flags.is_program_mode () in - let rec aux ?locality ?polymorphism isprogcmd = function - - | 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 -> - aux ~locality:b ?polymorphism isprogcmd c - | VernacPolymorphic (b, c) when polymorphism = None -> - aux ?locality ~polymorphism:b isprogcmd c - | VernacPolymorphic (b, c) -> user_err Pp.(str "Polymorphism specified twice") - | VernacLocal _ -> user_err Pp.(str "Locality specified twice") + let rec aux ?polymorphism ~atts isprogcmd = function + + | VernacProgram c when not isprogcmd -> + aux ?polymorphism ~atts true c + + | VernacProgram _ -> + user_err Pp.(str "Program mode specified twice") + + | VernacPolymorphic (b, c) when polymorphism = None -> + aux ~polymorphism:b ~atts:atts isprogcmd c + + | VernacPolymorphic (b, c) -> + user_err Pp.(str "Polymorphism specified twice") + + | VernacLocal (b, c) when Option.is_empty atts.locality -> + aux ?polymorphism ~atts:{atts with locality = Some b} isprogcmd c + + | VernacLocal _ -> + user_err Pp.(str "Locality specified twice") + | VernacFail v -> - with_fail st true (fun () -> aux ?locality ?polymorphism isprogcmd v) + with_fail st true (fun () -> aux ?polymorphism ~atts isprogcmd v) + | VernacTimeout (n,v) -> - current_timeout := Some n; - aux ?locality ?polymorphism isprogcmd v + current_timeout := Some n; + aux ?polymorphism ~atts isprogcmd v + | VernacRedirect (s, (_,v)) -> - Topfmt.with_output_to_file s (aux ?locality ?polymorphism isprogcmd) v + Topfmt.with_output_to_file s (aux ?polymorphism ~atts isprogcmd) v + | VernacTime (_,v) -> - System.with_time !Flags.time - (aux ?locality ?polymorphism isprogcmd) v; - | VernacLoad (_,fname) -> vernac_load (aux false) fname - | c -> - check_vernac_supports_locality c locality; - check_vernac_supports_polymorphism c polymorphism; - let poly = enforce_polymorphism polymorphism in - Obligations.set_program_mode isprogcmd; - try - vernac_timeout begin fun () -> + System.with_time !Flags.time (aux ?polymorphism ~atts isprogcmd) v; + + | VernacLoad (_,fname) -> vernac_load (aux ?polymorphism ~atts false) fname + + | c -> + check_vernac_supports_locality c atts.locality; + check_vernac_supports_polymorphism c polymorphism; + let polymorphic = enforce_polymorphism polymorphism in + Obligations.set_program_mode isprogcmd; + try + vernac_timeout begin fun () -> + let atts = { atts with polymorphic } in if verbosely - then Flags.verbosely (interp ?proof ?loc locality poly) c - else Flags.silently (interp ?proof ?loc locality poly) c; + then Flags.verbosely (interp ?proof ~atts ~st) c + else Flags.silently (interp ?proof ~atts ~st) c; if orig_program_mode || not !Flags.program_mode || isprogcmd then Flags.program_mode := orig_program_mode; - ignore (Flags.use_polymorphic_flag ()) + ignore (Flags.use_polymorphic_flag ()) end with | reraise when @@ -2249,10 +2259,19 @@ let interp ?(verbosely=true) ?proof st (loc,c) = ignore (Flags.use_polymorphic_flag ()); iraise e in - if verbosely then Flags.verbosely (aux false) c - else aux false c - -let interp ?verbosely ?proof st cmd = - unfreeze_interp_state st; - interp ?verbosely ?proof st cmd; - freeze_interp_state `No + let atts = { loc; locality = None; polymorphic = false; } in + if verbosely + then Flags.verbosely (aux ~atts orig_program_mode) c + else aux ~atts orig_program_mode c + +(* XXX: There is a bug here in case of an exception, see @gares + comments on the PR *) +let interp ?verbosely ?proof ~st cmd = + Vernacstate.unfreeze_interp_state st; + try + interp ?verbosely ?proof ~st cmd; + Vernacstate.freeze_interp_state `No + with exn -> + let exn = CErrors.push exn in + Vernacstate.invalidate_cache (); + iraise exn diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index 56635c8011..a559912a09 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -14,21 +14,11 @@ val dump_global : Libnames.reference or_by_notation -> unit val vernac_require : Libnames.reference option -> bool option -> Libnames.reference list -> unit -type interp_state = { (* TODO: inline records in OCaml 4.03 *) - system : States.state; (* summary + libstack *) - proof : Proof_global.state; (* proof state *) - shallow : bool (* is the state trimmed down (libstack) *) -} - -val freeze_interp_state : Summary.marshallable -> interp_state -val unfreeze_interp_state : interp_state -> unit - (** The main interpretation function of vernacular expressions *) val interp : ?verbosely:bool -> ?proof:Proof_global.closed_proof -> - interp_state -> - Vernacexpr.vernac_expr Loc.located -> interp_state + st:Vernacstate.t -> Vernacexpr.vernac_expr Loc.located -> Vernacstate.t (** Prepare a "match" template for a given inductive type. For each branch of the match, we list the constructor name @@ -40,7 +30,7 @@ val make_cases : string -> string list list (* XXX STATE: this type hints that restoring the state should be the caller's responsibility *) -val with_fail : interp_state -> bool -> (unit -> unit) -> unit +val with_fail : Vernacstate.t -> bool -> (unit -> unit) -> unit val command_focus : unit Proof.focus_kind diff --git a/vernac/vernacinterp.ml b/vernac/vernacinterp.ml index 41fee6bd08..c0b93c1638 100644 --- a/vernac/vernacinterp.ml +++ b/vernac/vernacinterp.ml @@ -11,12 +11,21 @@ open Pp open CErrors type deprecation = bool -type vernac_command = Genarg.raw_generic_argument list -> Loc.t option -> unit + +type atts = { + loc : Loc.t option; + locality : bool option; + polymorphic : bool; +} + +type 'a vernac_command = 'a -> atts:atts -> st:Vernacstate.t -> Vernacstate.t + +type plugin_args = Genarg.raw_generic_argument list (* Table of vernac entries *) let vernac_tab = - (Hashtbl.create 51 : - (Vernacexpr.extend_name, deprecation * vernac_command) Hashtbl.t) + (Hashtbl.create 211 : + (Vernacexpr.extend_name, deprecation * plugin_args vernac_command) Hashtbl.t) let vinterp_add depr s f = try @@ -49,7 +58,7 @@ let warn_deprecated_command = (* Interpretation of a vernac command *) -let call ?locality ?loc (opn,converted_args) = +let call opn converted_args ~atts ~st = let phase = ref "Looking up command" in try let depr, callback = vinterp_map opn in @@ -65,9 +74,7 @@ let call ?locality ?loc (opn,converted_args) = phase := "Checking arguments"; let hunk = callback converted_args in phase := "Executing command"; - Locality.LocalityFixme.set locality; - hunk loc; - Locality.LocalityFixme.assert_consumed() + hunk ~atts ~st with | Drop -> raise Drop | reraise -> diff --git a/vernac/vernacinterp.mli b/vernac/vernacinterp.mli index 84370fdc29..ab3d4bfc52 100644 --- a/vernac/vernacinterp.mli +++ b/vernac/vernacinterp.mli @@ -9,12 +9,19 @@ (** Interpretation of extended vernac phrases. *) type deprecation = bool -type vernac_command = Genarg.raw_generic_argument list -> Loc.t option -> unit -val vinterp_add : deprecation -> Vernacexpr.extend_name -> - vernac_command -> unit -val overwriting_vinterp_add : - Vernacexpr.extend_name -> vernac_command -> unit +type atts = { + loc : Loc.t option; + locality : bool option; + polymorphic : bool; +} + +type 'a vernac_command = 'a -> atts:atts -> st:Vernacstate.t -> Vernacstate.t + +type plugin_args = Genarg.raw_generic_argument list val vinterp_init : unit -> unit -val call : ?locality:bool -> ?loc:Loc.t -> Vernacexpr.extend_name * Genarg.raw_generic_argument list -> unit +val vinterp_add : deprecation -> Vernacexpr.extend_name -> plugin_args vernac_command -> unit +val overwriting_vinterp_add : Vernacexpr.extend_name -> plugin_args vernac_command -> unit + +val call : Vernacexpr.extend_name -> plugin_args -> atts:atts -> st:Vernacstate.t -> Vernacstate.t diff --git a/vernac/vernacstate.ml b/vernac/vernacstate.ml new file mode 100644 index 0000000000..4980333b5d --- /dev/null +++ b/vernac/vernacstate.ml @@ -0,0 +1,41 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +type t = { + system : States.state; (* summary + libstack *) + proof : Proof_global.t; (* proof state *) + shallow : bool (* is the state trimmed down (libstack) *) +} + +let s_cache = ref None +let s_proof = ref None + +let invalidate_cache () = + s_cache := None; + s_proof := None + +let update_cache rf v = + rf := Some v; v + +let do_if_not_cached rf f v = + match !rf with + | None -> + rf := Some v; f v + | Some vc when vc != v -> + rf := Some v; f v + | Some _ -> + () + +let freeze_interp_state marshallable = + { system = update_cache s_cache (States.freeze ~marshallable); + proof = update_cache s_proof (Proof_global.freeze ~marshallable); + shallow = marshallable = `Shallow } + +let unfreeze_interp_state { system; proof } = + do_if_not_cached s_cache States.unfreeze system; + do_if_not_cached s_proof Proof_global.unfreeze proof diff --git a/vernac/vernacstate.mli b/vernac/vernacstate.mli new file mode 100644 index 0000000000..3ed27ddb7a --- /dev/null +++ b/vernac/vernacstate.mli @@ -0,0 +1,19 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +type t = { + system : States.state; (* summary + libstack *) + proof : Proof_global.t; (* proof state *) + shallow : bool (* is the state trimmed down (libstack) *) +} + +val freeze_interp_state : Summary.marshallable -> t +val unfreeze_interp_state : t -> unit + +(* WARNING: Do not use, it will go away in future releases *) +val invalidate_cache : unit -> unit |